From fb9d0d19cd76383b42ccbf6cc7c9698998c729f4 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sat, 3 Aug 2019 09:11:42 +0200 Subject: Simplify invocation of Emacs + Proof General PG now uses the _Coqproject file and finds relevant paths there. --- pg | 20 +++----------------- 1 file changed, 3 insertions(+), 17 deletions(-) diff --git a/pg b/pg index 28926baa..398d618f 100755 --- a/pg +++ b/pg @@ -1,10 +1,7 @@ #!/bin/sh -# Start Proof General with the right -I options +# Start Proof General with the right Coq version # Use the Makefile to rebuild dependencies if needed -# Recompile the modified file after coqide editing - -PWD=`pwd` -INCLUDES=`make print-includes` +# Recompile the modified file after editing make -q ${1}o || { make -n ${1}o | grep -v "\\b${1}\\b" | \ @@ -15,16 +12,5 @@ make -q ${1}o || { COQPROGNAME="${COQBIN}coqtop" -COQPROGARGS="" -for arg in $INCLUDES; do - case "$arg" in - -I|-R|-as|compcert*) - COQPROGARGS="$COQPROGARGS \"$arg\"";; - *) - COQPROGARGS="$COQPROGARGS \"$PWD/$arg\"";; - esac -done - -emacs --eval "(setq coq-prog-name \"$COQPROGNAME\")" \ - --eval "(setq coq-prog-args '($COQPROGARGS))" $1 \ +emacs --eval "(setq coq-prog-name \"$COQPROGNAME\")" $1 \ && make ${1}o -- cgit From 136d25dcbf2829e63c20b96acf86d34c94474fde Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Fri, 2 Aug 2019 10:41:29 +0200 Subject: Coq 8.10 compatibility: make explicit the "core" hint database "Hint Resolve foo." becomes "Hint Resolve foo : core", or "Local Hint Resolve foo : core". --- backend/Conventions.v | 2 -- cfrontend/Cexec.v | 11 ++++++----- cfrontend/Cop.v | 4 ++-- cfrontend/Cstrategy.v | 10 +++++----- cfrontend/SimplExprspec.v | 2 +- common/Separation.v | 2 +- common/Values.v | 10 +++++----- lib/Floats.v | 4 ++-- 8 files changed, 22 insertions(+), 23 deletions(-) diff --git a/backend/Conventions.v b/backend/Conventions.v index 989bfa05..6025c6b4 100644 --- a/backend/Conventions.v +++ b/backend/Conventions.v @@ -128,8 +128,6 @@ Definition callee_save_loc (l: loc) := | S sl ofs ty => sl <> Outgoing end. -Hint Unfold callee_save_loc. - Definition agree_callee_save (ls1 ls2: Locmap.t) : Prop := forall l, callee_save_loc l -> ls1 l = ls2 l. diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index e6bf2129..2942080b 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -1124,8 +1124,8 @@ Proof. induction 1; intros; constructor; eauto. Qed. -Hint Constructors context contextlist. -Hint Resolve context_compose contextlist_compose. +Local Hint Constructors context contextlist : core. +Local Hint Resolve context_compose contextlist_compose : core. Definition reduction_ok (k: kind) (a: expr) (m: mem) (rd: reduction) : Prop := match k, rd with @@ -1691,8 +1691,9 @@ Proof. change (In (f (C0, rd)) (map f res2)). apply in_map; auto. Qed. -Hint Resolve reducts_incl_val reducts_incl_loc reducts_incl_listval - reducts_incl_incontext reducts_incl_incontext2_left reducts_incl_incontext2_right. +Local Hint Resolve reducts_incl_val reducts_incl_loc reducts_incl_listval + reducts_incl_incontext reducts_incl_incontext2_left + reducts_incl_incontext2_right : core. Lemma step_expr_context: forall from to C, context from to C -> @@ -2077,7 +2078,7 @@ Ltac myinv := | _ => idtac end. -Hint Extern 3 => exact I. +Local Hint Extern 3 => exact I : core. Theorem do_step_sound: forall w S rule t S', diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index 782fb32a..aa73abb0 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -1131,7 +1131,7 @@ Qed. Remark val_inject_vptrofs: forall n, Val.inject f (Vptrofs n) (Vptrofs n). Proof. intros. unfold Vptrofs. destruct Archi.ptr64; auto. Qed. -Hint Resolve val_inject_vtrue val_inject_vfalse val_inject_of_bool val_inject_vptrofs. +Local Hint Resolve val_inject_vtrue val_inject_vfalse val_inject_of_bool val_inject_vptrofs : core. Ltac TrivialInject := match goal with @@ -1517,7 +1517,7 @@ Inductive val_casted: val -> type -> Prop := | val_casted_void: forall v, val_casted v Tvoid. -Hint Constructors val_casted. +Local Hint Constructors val_casted : core. Remark cast_int_int_idem: forall sz sg i, cast_int_int sz sg (cast_int_int sz sg i) = cast_int_int sz sg i. diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v index 28c8eeb8..c235031f 100644 --- a/cfrontend/Cstrategy.v +++ b/cfrontend/Cstrategy.v @@ -222,7 +222,7 @@ Proof. induction 1; constructor; auto. Qed. -Hint Resolve leftcontext_context. +Local Hint Resolve leftcontext_context : core. (** Strategy for reducing expressions. We reduce the leftmost innermost non-simple subexpression, evaluating its arguments (which are necessarily @@ -398,8 +398,8 @@ Proof. induction 1; intros; constructor; eauto. Qed. -Hint Constructors context contextlist. -Hint Resolve context_compose contextlist_compose. +Local Hint Constructors context contextlist : core. +Local Hint Resolve context_compose contextlist_compose : core. (** * Safe executions. *) @@ -975,7 +975,7 @@ Proof. apply extensionality; intros. f_equal. f_equal. apply exprlist_app_assoc. Qed. -Hint Resolve contextlist'_head contextlist'_tail. +Local Hint Resolve contextlist'_head contextlist'_tail : core. Lemma eval_simple_list_steps: forall rl vl, eval_simple_list' rl vl -> @@ -1049,7 +1049,7 @@ Scheme expr_ind2 := Induction for expr Sort Prop with exprlist_ind2 := Induction for exprlist Sort Prop. Combined Scheme expr_expr_list_ind from expr_ind2, exprlist_ind2. -Hint Constructors leftcontext leftcontextlist. +Local Hint Constructors leftcontext leftcontextlist : core. Lemma decompose_expr: (forall a from C, diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v index 37e2cd96..e7d57a1c 100644 --- a/cfrontend/SimplExprspec.v +++ b/cfrontend/SimplExprspec.v @@ -687,7 +687,7 @@ Hint Resolve gensym_within within_widen contained_widen in_eq in_cons Ple_trans Ple_refl: gensym. -Hint Resolve dest_for_val_below dest_for_effect_below. +Local Hint Resolve dest_for_val_below dest_for_effect_below : core. (** ** Correctness of the translation functions *) diff --git a/common/Separation.v b/common/Separation.v index 1493b535..27065d1f 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -113,7 +113,7 @@ Proof. intros P Q [[A B] [C D]]. split; auto. Qed. -Hint Resolve massert_imp_refl massert_eqv_refl. +Hint Resolve massert_imp_refl massert_eqv_refl : core. (** * Separating conjunction *) diff --git a/common/Values.v b/common/Values.v index a51a390f..2eb778a5 100644 --- a/common/Values.v +++ b/common/Values.v @@ -1949,7 +1949,7 @@ Inductive lessdef_list: list val -> list val -> Prop := lessdef v1 v2 -> lessdef_list vl1 vl2 -> lessdef_list (v1 :: vl1) (v2 :: vl2). -Hint Resolve lessdef_refl lessdef_undef lessdef_list_nil lessdef_list_cons. +Hint Resolve lessdef_refl lessdef_undef lessdef_list_nil lessdef_list_cons : core. Lemma lessdef_list_inv: forall vl1 vl2, lessdef_list vl1 vl2 -> vl1 = vl2 \/ In Vundef vl1. @@ -2174,7 +2174,7 @@ Inductive inject (mi: meminj): val -> val -> Prop := | val_inject_undef: forall v, inject mi Vundef v. -Hint Constructors inject. +Hint Constructors inject : core. Inductive inject_list (mi: meminj): list val -> list val-> Prop:= | inject_list_nil : @@ -2183,7 +2183,7 @@ Inductive inject_list (mi: meminj): list val -> list val-> Prop:= inject mi v v' -> inject_list mi vl vl'-> inject_list mi (v :: vl) (v' :: vl'). -Hint Resolve inject_list_nil inject_list_cons. +Hint Resolve inject_list_nil inject_list_cons : core. Lemma inject_ptrofs: forall mi i, inject mi (Vptrofs i) (Vptrofs i). @@ -2191,7 +2191,7 @@ Proof. unfold Vptrofs; intros. destruct Archi.ptr64; auto. Qed. -Hint Resolve inject_ptrofs. +Hint Resolve inject_ptrofs : core. Section VAL_INJ_OPS. @@ -2494,7 +2494,7 @@ Proof. constructor. eapply val_inject_incr; eauto. auto. Qed. -Hint Resolve inject_incr_refl val_inject_incr val_inject_list_incr. +Hint Resolve inject_incr_refl val_inject_incr val_inject_list_incr : core. Lemma val_inject_lessdef: forall v1 v2, Val.lessdef v1 v2 <-> Val.inject (fun b => Some(b, 0)) v1 v2. diff --git a/lib/Floats.v b/lib/Floats.v index 7677e3c8..13350dd0 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -139,8 +139,8 @@ Definition default_nan_32 := quiet_nan_32 Archi.default_nan_32. Local Notation __ := (eq_refl Datatypes.Lt). -Local Hint Extern 1 (Prec_gt_0 _) => exact (eq_refl Datatypes.Lt). -Local Hint Extern 1 (_ < _) => exact (eq_refl Datatypes.Lt). +Local Hint Extern 1 (Prec_gt_0 _) => exact (eq_refl Datatypes.Lt) : core. +Local Hint Extern 1 (_ < _) => exact (eq_refl Datatypes.Lt) : core. (** * Double-precision FP numbers *) -- cgit From efb5f52493345a1e17cc10b56023dfe00beb6074 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Fri, 2 Aug 2019 10:48:27 +0200 Subject: Coq 8.10 compatibility: tweak Argument command --- lib/Maps.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Maps.v b/lib/Maps.v index cfb866ba..9e44a7fe 100644 --- a/lib/Maps.v +++ b/lib/Maps.v @@ -190,7 +190,7 @@ Module PTree <: TREE. | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. - Arguments Leaf [A]. + Arguments Leaf {A}. Arguments Node [A]. Scheme tree_ind := Induction for tree Sort Prop. -- cgit From f19b7fd7a0b87d7fcce021a264f9b95c43a24a09 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 5 Aug 2019 16:01:46 +0200 Subject: Coq 8.10 compatibility: (temporarily) silence new warning The "undeclared-scope" warning fires when we use a "notation" scope before having declared it. This is a good thing, except that the "Declare Scope" vernacular that declares a scope was introduced in Coq 8.10 and is not available in earlier versions. Hence there is no way to avoid triggering the warning yet remain compatible with pre-8.10 Coq versions. This commit silences the warning. It will have to revisited when Coq 8.10 is the oldest version of Coq we support in CompCert. --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index ae19225a..80eca80d 100644 --- a/Makefile +++ b/Makefile @@ -30,6 +30,7 @@ RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight \ COQINCLUDES=$(foreach d, $(RECDIRS), -R $(d) compcert.$(d)) +COQCOPTS ?= -w -undeclared-scope COQC="$(COQBIN)coqc" -q $(COQINCLUDES) $(COQCOPTS) COQDEP="$(COQBIN)coqdep" $(COQINCLUDES) COQDOC="$(COQBIN)coqdoc" -- cgit From 5148617b7961c1d67acb70bfc783bc5616537486 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 5 Aug 2019 16:05:53 +0200 Subject: Add support for Coq 8.10 --- configure | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure b/configure index d586436a..9a2db366 100755 --- a/configure +++ b/configure @@ -503,14 +503,14 @@ 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.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1) + 8.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" 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.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" + echo "Error: CompCert requires one of the following Coq versions: 8.10, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" missingtools=true fi;; "") -- cgit From 4e3d57e84a0ebf96723fc7a6deeb9fd27f56770a Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 6 Aug 2019 13:34:23 +0200 Subject: x86: wrong expansion of __builtin_fmadd et al There was a misunderstanding on the asm syntax for 3-operand instructions such as vfmadd132: when the Intel manual reads vfmadd132 res, arg2, arg3 the corresponding GNU asm syntax is vfmadd132 arg3, arg2, res but not vfmadd132 arg2, arg3, res Closes: #188 --- x86/TargetPrinter.ml | 32 +++++++++++++++++++------------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index cd54e08b..6159437e 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -399,7 +399,13 @@ module Target(System: SYSTEM):TARGET = (* Printing of instructions *) -(* Reminder on AT&T syntax: op source, dest *) +(* Reminder on X86 assembly syntaxes: + AT&T syntax Intel syntax + (used by GNU as) (used in reference manuals) + dst <- op(src) op src, dst op dst, src + dst <- op(dst, src2) op src2, dst op dst, src2 + dst <- op(dst, src2, src3) op src3, src2, dst op dst, src2, src3 +*) let print_instruction oc = function (* Moves *) @@ -752,29 +758,29 @@ module Target(System: SYSTEM):TARGET = | Pcfi_adjust sz -> cfi_adjust oc (camlint_of_coqint sz) | Pfmadd132 (res,a1,a2) -> - fprintf oc " vfmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfmadd132sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfmadd213 (res,a1,a2) -> - fprintf oc " vfmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfmadd213sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfmadd231 (res,a1,a2) -> - fprintf oc " vfmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfmadd231sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfmsub132 (res,a1,a2) -> - fprintf oc " vfmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfmsub132sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfmsub213 (res,a1,a2) -> - fprintf oc " vfmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfmsub213sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfmsub231 (res,a1,a2) -> - fprintf oc " vfmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfmsub231sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfnmadd132 (res,a1,a2) -> - fprintf oc " vfnmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfnmadd132sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfnmadd213 (res,a1,a2) -> - fprintf oc " vfnmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfnmadd213sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfnmadd231 (res,a1,a2) -> - fprintf oc " vfnmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfnmadd231sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfnmsub132 (res,a1,a2) -> - fprintf oc " vfnmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfnmsub132sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfnmsub213 (res,a1,a2) -> - fprintf oc " vfnmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfnmsub213sd %a, %a, %a\n" freg a2 freg a1 freg res | Pfnmsub231 (res,a1,a2) -> - fprintf oc " vfnmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res + fprintf oc " vfnmsub231sd %a, %a, %a\n" freg a2 freg a1 freg res | Pmaxsd (res,a1) -> fprintf oc " maxsd %a, %a\n" freg a1 freg res | Pminsd (res,a1) -> -- cgit From 1f73810ca4f9754f3da8bd02f85a6e294129813a Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 6 May 2019 15:30:48 +0200 Subject: Zbits.v: add bit extraction and bit insertion --- lib/Zbits.v | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) diff --git a/lib/Zbits.v b/lib/Zbits.v index dca2a5a2..459e891b 100644 --- a/lib/Zbits.v +++ b/lib/Zbits.v @@ -1026,3 +1026,60 @@ Proof. exploit (Zsize_interval_1 y). omega. omega. Qed. + +(** ** Bit insertion, bit extraction *) + +(** Extract and optionally sign-extend bits [from...from+len-1] of [x] *) +Definition Zextract_u (x: Z) (from: Z) (len: Z) : Z := + Zzero_ext len (Z.shiftr x from). + +Definition Zextract_s (x: Z) (from: Z) (len: Z) : Z := + Zsign_ext len (Z.shiftr x from). + +Lemma Zextract_u_spec: + forall x from len i, + 0 <= from -> 0 <= len -> 0 <= i -> + Z.testbit (Zextract_u x from len) i = + if zlt i len then Z.testbit x (from + i) else false. +Proof. + unfold Zextract_u; intros. rewrite Zzero_ext_spec, Z.shiftr_spec by auto. + rewrite Z.add_comm. auto. +Qed. + +Lemma Zextract_s_spec: + forall x from len i, + 0 <= from -> 0 < len -> 0 <= i -> + Z.testbit (Zextract_s x from len) i = + Z.testbit x (from + (if zlt i len then i else len - 1)). +Proof. + unfold Zextract_s; intros. rewrite Zsign_ext_spec by auto. rewrite Z.shiftr_spec. + rewrite Z.add_comm. auto. + destruct (zlt i len); omega. +Qed. + +(** Insert bits [0...len-1] of [y] into bits [to...to+len-1] of [x] *) + +Definition Zinsert (x y: Z) (to: Z) (len: Z) : Z := + let mask := Z.shiftl (two_p len - 1) to in + Z.lor (Z.land (Z.shiftl y to) mask) (Z.ldiff x mask). + +Lemma Zinsert_spec: + forall x y to len i, + 0 <= to -> 0 <= len -> 0 <= i -> + Z.testbit (Zinsert x y to len) i = + if zle to i && zlt i (to + len) + then Z.testbit y (i - to) + else Z.testbit x i. +Proof. + unfold Zinsert; intros. set (mask := two_p len - 1). + assert (M: forall j, 0 <= j -> Z.testbit mask j = if zlt j len then true else false). + { intros; apply Ztestbit_two_p_m1; auto. } + rewrite Z.lor_spec, Z.land_spec, Z.ldiff_spec by auto. + destruct (zle to i). +- rewrite ! Z.shiftl_spec by auto. rewrite ! M by omega. + unfold proj_sumbool; destruct (zlt (i - to) len); simpl; + rewrite andb_true_r, andb_false_r. ++ rewrite zlt_true by omega. apply orb_false_r. ++ rewrite zlt_false by omega; auto. +- rewrite ! Z.shiftl_spec_low by omega. simpl. apply andb_true_r. +Qed. -- cgit From 62c92241a69cd4597650d8408744ff922ca34245 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 8 May 2019 16:05:56 +0200 Subject: Define integer sign extension for zero bits Just ensure sign_ext 0 x = zero. This simplifies some statements and proofs. --- lib/Integers.v | 41 +++++++++++++++++++++++++++-------------- lib/Zbits.v | 58 ++++++++++++++++++++++++++++++---------------------------- 2 files changed, 57 insertions(+), 42 deletions(-) diff --git a/lib/Integers.v b/lib/Integers.v index f4213332..1b0375b1 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -1139,6 +1139,12 @@ Proof. intros. apply Ztestbit_above with wordsize; auto. apply unsigned_range. Qed. +Lemma bits_below: + forall x i, i < 0 -> testbit x i = false. +Proof. + intros. apply Z.testbit_neg_r; auto. +Qed. + Lemma bits_zero: forall i, testbit zero i = false. Proof. @@ -2511,12 +2517,11 @@ Proof. Qed. Lemma bits_sign_ext: - forall n x i, 0 <= i < zwordsize -> 0 < n -> + forall n x i, 0 <= i < zwordsize -> testbit (sign_ext n x) i = testbit x (if zlt i n then i else n - 1). Proof. intros. unfold sign_ext. - rewrite testbit_repr; auto. rewrite Zsign_ext_spec. destruct (zlt i n); auto. - omega. auto. + rewrite testbit_repr; auto. apply Zsign_ext_spec. omega. Qed. Hint Rewrite bits_zero_ext bits_sign_ext: ints. @@ -2528,12 +2533,24 @@ Proof. rewrite bits_zero_ext. apply zlt_true. omega. omega. Qed. +Theorem zero_ext_below: + forall n x, n <= 0 -> zero_ext n x = zero. +Proof. + intros. bit_solve. destruct (zlt i n); auto. apply bits_below; omega. omega. +Qed. + Theorem sign_ext_above: forall n x, n >= zwordsize -> sign_ext n x = x. Proof. intros. apply same_bits_eq; intros. unfold sign_ext; rewrite testbit_repr; auto. - rewrite Zsign_ext_spec. rewrite zlt_true. auto. omega. omega. omega. + rewrite Zsign_ext_spec. rewrite zlt_true. auto. omega. omega. +Qed. + +Theorem sign_ext_below: + forall n x, n <= 0 -> sign_ext n x = zero. +Proof. + intros. bit_solve. apply bits_below. destruct (zlt i n); omega. Qed. Theorem zero_ext_and: @@ -2570,7 +2587,7 @@ Proof. Qed. Theorem sign_ext_widen: - forall x n n', 0 < n <= n' -> + forall x n n', 0 < n <= n' -> sign_ext n' (sign_ext n x) = sign_ext n x. Proof. intros. destruct (zlt n' zwordsize). @@ -2578,9 +2595,8 @@ Proof. auto. rewrite (zlt_false _ i n). destruct (zlt (n' - 1) n); f_equal; omega. - omega. omega. + omega. destruct (zlt i n'); omega. - omega. omega. apply sign_ext_above; auto. Qed. @@ -2594,7 +2610,6 @@ Proof. auto. rewrite !zlt_false. auto. omega. omega. omega. destruct (zlt i n'); omega. - omega. apply sign_ext_above; auto. Qed. @@ -2614,9 +2629,7 @@ Theorem sign_ext_narrow: Proof. intros. destruct (zlt n zwordsize). bit_solve. destruct (zlt i n); f_equal; apply zlt_true; omega. - omega. destruct (zlt i n); omega. - omega. omega. rewrite (sign_ext_above n'). auto. omega. Qed. @@ -2628,7 +2641,7 @@ Proof. bit_solve. destruct (zlt i n); auto. rewrite zlt_true; auto. omega. - omega. omega. omega. + omega. omega. rewrite sign_ext_above; auto. Qed. @@ -2643,7 +2656,7 @@ Theorem sign_ext_idem: Proof. intros. apply sign_ext_widen. omega. Qed. - + Theorem sign_ext_zero_ext: forall n x, 0 < n -> sign_ext n (zero_ext n x) = sign_ext n x. Proof. @@ -2706,7 +2719,7 @@ Proof. rewrite zlt_true. rewrite bits_shl. rewrite zlt_false. f_equal. omega. omega. omega. omega. rewrite zlt_false. rewrite bits_shl. rewrite zlt_false. f_equal. omega. - omega. omega. omega. omega. omega. + omega. omega. omega. omega. Qed. (** [zero_ext n x] is the unique integer congruent to [x] modulo [2^n] @@ -2766,7 +2779,7 @@ Proof. apply eqmod_same_bits; intros. rewrite H0 in H1. rewrite H0. fold (testbit (sign_ext n x) i). rewrite bits_sign_ext. - rewrite zlt_true. auto. omega. omega. omega. + rewrite zlt_true. auto. omega. omega. Qed. Lemma eqmod_sign_ext: diff --git a/lib/Zbits.v b/lib/Zbits.v index 459e891b..fb40ccb5 100644 --- a/lib/Zbits.v +++ b/lib/Zbits.v @@ -557,7 +557,7 @@ Definition Zzero_ext (n: Z) (x: Z) : Z := Definition Zsign_ext (n: Z) (x: Z) : Z := Z.iter (Z.pred n) (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x))) - (fun x => if Z.odd x then -1 else 0) + (fun x => if Z.odd x && zlt 0 n then -1 else 0) x. Lemma Ziter_base: @@ -606,32 +606,34 @@ Proof. Qed. Lemma Zsign_ext_spec: - forall n x i, 0 <= i -> 0 < n -> + forall n x i, 0 <= i -> Z.testbit (Zsign_ext n x) i = Z.testbit x (if zlt i n then i else n - 1). Proof. - intros n0 x i I0 N0. - revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1). - - unfold Zsign_ext. intros. - destruct (zeq x 1). - + subst x; simpl. - replace (if zlt i 1 then i else 0) with 0. - rewrite Ztestbit_base. - destruct (Z.odd x0). - apply Ztestbit_m1; auto. - apply Ztestbit_0. - destruct (zlt i 1); omega. - + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)). - rewrite Ziter_succ. rewrite Ztestbit_shiftin. - destruct (zeq i 0). - * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega. - * rewrite H. unfold x1. destruct (zlt (Z.pred i) (Z.pred x)). - rewrite zlt_true. rewrite (Ztestbit_eq i x0); auto. rewrite zeq_false; auto. omega. - rewrite zlt_false. rewrite (Ztestbit_eq (x - 1) x0). rewrite zeq_false; auto. - omega. omega. omega. unfold x1; omega. omega. - * omega. - * unfold x1; omega. - * omega. - - omega. + intros n0 x i I0. unfold Zsign_ext. + unfold proj_sumbool; destruct (zlt 0 n0) as [N0|N0]; simpl. +- revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1); [ | omega ]. + unfold Zsign_ext. intros. + destruct (zeq x 1). + + subst x; simpl. + replace (if zlt i 1 then i else 0) with 0. + rewrite Ztestbit_base. + destruct (Z.odd x0); [ apply Ztestbit_m1; auto | apply Ztestbit_0 ]. + destruct (zlt i 1); omega. + + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)) by omega. + rewrite Ziter_succ by (unfold x1; omega). rewrite Ztestbit_shiftin by auto. + destruct (zeq i 0). + * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega. + * rewrite H by (unfold x1; omega). + unfold x1; destruct (zlt (Z.pred i) (Z.pred x)). + ** rewrite zlt_true by omega. + rewrite (Ztestbit_eq i x0) by omega. + rewrite zeq_false by omega. auto. + ** rewrite zlt_false by omega. + rewrite (Ztestbit_eq (x - 1) x0) by omega. + rewrite zeq_false by omega. auto. +- rewrite Ziter_base by omega. rewrite andb_false_r. + rewrite Z.testbit_0_l, Z.testbit_neg_r. auto. + destruct (zlt i n0); omega. Qed. (** [Zzero_ext n x] is [x modulo 2^n] *) @@ -661,7 +663,7 @@ Qed. (** Relation between [Zsign_ext n x] and (Zzero_ext n x] *) Lemma Zsign_ext_zero_ext: - forall n, 0 < n -> forall x, + forall n, 0 <= n -> forall x, Zsign_ext n x = Zzero_ext n x - (if Z.testbit x (n - 1) then two_p n else 0). Proof. intros. apply equal_same_bits; intros. @@ -698,12 +700,12 @@ Proof. assert (C: two_p n = 2 * two_p (n - 1)). { rewrite <- two_p_S by omega. f_equal; omega. } rewrite Zzero_ext_spec, zlt_true in B by omega. - rewrite Zsign_ext_zero_ext by auto. rewrite B. + rewrite Zsign_ext_zero_ext by omega. rewrite B. destruct (zlt (Zzero_ext n x) (two_p (n - 1))); omega. Qed. Lemma eqmod_Zsign_ext: - forall n x, 0 < n -> + forall n x, 0 <= n -> eqmod (two_p n) (Zsign_ext n x) x. Proof. intros. rewrite Zsign_ext_zero_ext by auto. -- cgit From 862b0a23ad6c2caf2b81e502584d369fe9bc0d14 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 8 May 2019 18:37:54 +0200 Subject: Properties of combinations of shifts and zero-/sign-extension --- lib/Integers.v | 249 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 249 insertions(+) diff --git a/lib/Integers.v b/lib/Integers.v index 1b0375b1..369584c3 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -2794,6 +2794,132 @@ Proof. apply eqmod_sign_ext'; auto. Qed. +(** Combinations of shifts and zero/sign extensions *) + +Lemma shl_zero_ext: + forall n m x, 0 <= n -> + shl (zero_ext n x) m = zero_ext (n + unsigned m) (shl x m). +Proof. + intros. apply same_bits_eq; intros. + rewrite bits_zero_ext, ! bits_shl by omega. + destruct (zlt i (unsigned m)). +- rewrite zlt_true by omega; auto. +- rewrite bits_zero_ext by omega. + destruct (zlt (i - unsigned m) n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +Qed. + +Lemma shl_sign_ext: + forall n m x, 0 < n -> + shl (sign_ext n x) m = sign_ext (n + unsigned m) (shl x m). +Proof. + intros. generalize (unsigned_range m); intros. + apply same_bits_eq; intros. + rewrite bits_sign_ext, ! bits_shl by omega. + destruct (zlt i (n + unsigned m)). +- rewrite bits_shl by auto. destruct (zlt i (unsigned m)); auto. + rewrite bits_sign_ext by omega. f_equal. apply zlt_true. omega. +- rewrite zlt_false by omega. rewrite bits_shl by omega. rewrite zlt_false by omega. + rewrite bits_sign_ext by omega. f_equal. rewrite zlt_false by omega. omega. +Qed. + +Lemma shru_zero_ext: + forall n m x, 0 <= n -> + shru (zero_ext (n + unsigned m) x) m = zero_ext n (shru x m). +Proof. + intros. bit_solve. +- destruct (zlt (i + unsigned m) zwordsize). +* destruct (zlt i n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +* destruct (zlt i n); auto. +- generalize (unsigned_range m); omega. +- omega. +Qed. + +Lemma shru_zero_ext_0: + forall n m x, n <= unsigned m -> + shru (zero_ext n x) m = zero. +Proof. + intros. bit_solve. +- destruct (zlt (i + unsigned m) zwordsize); auto. + apply zlt_false. omega. +- generalize (unsigned_range m); omega. +Qed. + +Lemma shr_sign_ext: + forall n m x, 0 < n -> n + unsigned m < zwordsize -> + shr (sign_ext (n + unsigned m) x) m = sign_ext n (shr x m). +Proof. + intros. generalize (unsigned_range m); intros. + apply same_bits_eq; intros. + rewrite bits_sign_ext, bits_shr by auto. + rewrite bits_sign_ext, bits_shr. +- f_equal. + destruct (zlt i n), (zlt (i + unsigned m) zwordsize). ++ apply zlt_true; omega. ++ apply zlt_true; omega. ++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. ++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. +- destruct (zlt i n); omega. +- destruct (zlt (i + unsigned m) zwordsize); omega. +Qed. + +Lemma zero_ext_shru_min: + forall s x n, ltu n iwordsize = true -> + zero_ext s (shru x n) = zero_ext (Z.min s (zwordsize - unsigned n)) (shru x n). +Proof. + intros. apply ltu_iwordsize_inv in H. + apply Z.min_case_strong; intros; auto. + bit_solve; try omega. + destruct (zlt i (zwordsize - unsigned n)). + rewrite zlt_true by omega. auto. + destruct (zlt i s); auto. rewrite zlt_false by omega; auto. +Qed. + +Lemma sign_ext_shr_min: + forall s x n, ltu n iwordsize = true -> + sign_ext s (shr x n) = sign_ext (Z.min s (zwordsize - unsigned n)) (shr x n). +Proof. + intros. apply ltu_iwordsize_inv in H. + rewrite Z.min_comm. + destruct (Z.min_spec (zwordsize - unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. + apply same_bits_eq; intros. rewrite ! bits_sign_ext by auto. + destruct (zlt i (zwordsize - unsigned n)). + rewrite zlt_true by omega. auto. + assert (C: testbit (shr x n) (zwordsize - unsigned n - 1) = testbit x (zwordsize - 1)). + { rewrite bits_shr by omega. rewrite zlt_true by omega. f_equal; omega. } + rewrite C. destruct (zlt i s); rewrite bits_shr by omega. + rewrite zlt_false by omega. auto. + rewrite zlt_false by omega. auto. +Qed. + +Lemma shl_zero_ext_min: + forall s x n, ltu n iwordsize = true -> + shl (zero_ext s x) n = shl (zero_ext (Z.min s (zwordsize - unsigned n)) x) n. +Proof. + intros. apply ltu_iwordsize_inv in H. + apply Z.min_case_strong; intros; auto. + apply same_bits_eq; intros. rewrite ! bits_shl by auto. + destruct (zlt i (unsigned n)); auto. + rewrite ! bits_zero_ext by omega. + destruct (zlt (i - unsigned n) s). + rewrite zlt_true by omega; auto. + rewrite zlt_false by omega; auto. +Qed. + +Lemma shl_sign_ext_min: + forall s x n, ltu n iwordsize = true -> + shl (sign_ext s x) n = shl (sign_ext (Z.min s (zwordsize - unsigned n)) x) n. +Proof. + intros. apply ltu_iwordsize_inv in H. + rewrite Z.min_comm. + destruct (Z.min_spec (zwordsize - unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. + apply same_bits_eq; intros. rewrite ! bits_shl by auto. + destruct (zlt i (unsigned n)); auto. + rewrite ! bits_sign_ext by omega. f_equal. + destruct (zlt (i - unsigned n) s). + rewrite zlt_true by omega; auto. + omegaContradiction. +Qed. + (** ** Properties of [one_bits] (decomposition in sum of powers of two) *) Theorem one_bits_range: @@ -3512,6 +3638,129 @@ Proof. unfold shr, shr'; rewrite <- A; auto. Qed. +Lemma shl'_zero_ext: + forall n m x, 0 <= n -> + shl' (zero_ext n x) m = zero_ext (n + Int.unsigned m) (shl' x m). +Proof. + intros. apply same_bits_eq; intros. + rewrite bits_zero_ext, ! bits_shl' by omega. + destruct (zlt i (Int.unsigned m)). +- rewrite zlt_true by omega; auto. +- rewrite bits_zero_ext by omega. + destruct (zlt (i - Int.unsigned m) n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +Qed. + +Lemma shl'_sign_ext: + forall n m x, 0 < n -> + shl' (sign_ext n x) m = sign_ext (n + Int.unsigned m) (shl' x m). +Proof. + intros. generalize (Int.unsigned_range m); intros. + apply same_bits_eq; intros. + rewrite bits_sign_ext, ! bits_shl' by omega. + destruct (zlt i (n + Int.unsigned m)). +- rewrite bits_shl' by auto. destruct (zlt i (Int.unsigned m)); auto. + rewrite bits_sign_ext by omega. f_equal. apply zlt_true. omega. +- rewrite zlt_false by omega. rewrite bits_shl' by omega. rewrite zlt_false by omega. + rewrite bits_sign_ext by omega. f_equal. rewrite zlt_false by omega. omega. +Qed. + +Lemma shru'_zero_ext: + forall n m x, 0 <= n -> + shru' (zero_ext (n + Int.unsigned m) x) m = zero_ext n (shru' x m). +Proof. + intros. generalize (Int.unsigned_range m); intros. + bit_solve; [|omega]. rewrite bits_shru', bits_zero_ext, bits_shru' by omega. + destruct (zlt (i + Int.unsigned m) zwordsize). +* destruct (zlt i n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. +* destruct (zlt i n); auto. +Qed. + +Lemma shru'_zero_ext_0: + forall n m x, n <= Int.unsigned m -> + shru' (zero_ext n x) m = zero. +Proof. + intros. generalize (Int.unsigned_range m); intros. + bit_solve. rewrite bits_shru', bits_zero_ext by omega. + destruct (zlt (i + Int.unsigned m) zwordsize); auto. + apply zlt_false. omega. +Qed. + +Lemma shr'_sign_ext: + forall n m x, 0 < n -> n + Int.unsigned m < zwordsize -> + shr' (sign_ext (n + Int.unsigned m) x) m = sign_ext n (shr' x m). +Proof. + intros. generalize (Int.unsigned_range m); intros. + apply same_bits_eq; intros. + rewrite bits_sign_ext, bits_shr' by auto. + rewrite bits_sign_ext, bits_shr'. +- f_equal. + destruct (zlt i n), (zlt (i + Int.unsigned m) zwordsize). ++ apply zlt_true; omega. ++ apply zlt_true; omega. ++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. ++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega. +- destruct (zlt i n); omega. +- destruct (zlt (i + Int.unsigned m) zwordsize); omega. +Qed. + +Lemma zero_ext_shru'_min: + forall s x n, Int.ltu n iwordsize' = true -> + zero_ext s (shru' x n) = zero_ext (Z.min s (zwordsize - Int.unsigned n)) (shru' x n). +Proof. + intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H. + apply Z.min_case_strong; intros; auto. + bit_solve; try omega. rewrite ! bits_shru' by omega. + destruct (zlt i (zwordsize - Int.unsigned n)). + rewrite zlt_true by omega. auto. + destruct (zlt i s); auto. rewrite zlt_false by omega; auto. +Qed. + +Lemma sign_ext_shr'_min: + forall s x n, Int.ltu n iwordsize' = true -> + sign_ext s (shr' x n) = sign_ext (Z.min s (zwordsize - Int.unsigned n)) (shr' x n). +Proof. + intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H. + rewrite Z.min_comm. + destruct (Z.min_spec (zwordsize - Int.unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. + apply same_bits_eq; intros. rewrite ! bits_sign_ext by auto. + destruct (zlt i (zwordsize - Int.unsigned n)). + rewrite zlt_true by omega. auto. + assert (C: testbit (shr' x n) (zwordsize - Int.unsigned n - 1) = testbit x (zwordsize - 1)). + { rewrite bits_shr' by omega. rewrite zlt_true by omega. f_equal; omega. } + rewrite C. destruct (zlt i s); rewrite bits_shr' by omega. + rewrite zlt_false by omega. auto. + rewrite zlt_false by omega. auto. +Qed. + +Lemma shl'_zero_ext_min: + forall s x n, Int.ltu n iwordsize' = true -> + shl' (zero_ext s x) n = shl' (zero_ext (Z.min s (zwordsize - Int.unsigned n)) x) n. +Proof. + intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H. + apply Z.min_case_strong; intros; auto. + apply same_bits_eq; intros. rewrite ! bits_shl' by auto. + destruct (zlt i (Int.unsigned n)); auto. + rewrite ! bits_zero_ext by omega. + destruct (zlt (i - Int.unsigned n) s). + rewrite zlt_true by omega; auto. + rewrite zlt_false by omega; auto. +Qed. + +Lemma shl'_sign_ext_min: + forall s x n, Int.ltu n iwordsize' = true -> + shl' (sign_ext s x) n = shl' (sign_ext (Z.min s (zwordsize - Int.unsigned n)) x) n. +Proof. + intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H. + rewrite Z.min_comm. + destruct (Z.min_spec (zwordsize - Int.unsigned n) s) as [[A B] | [A B]]; rewrite B; auto. + apply same_bits_eq; intros. rewrite ! bits_shl' by auto. + destruct (zlt i (Int.unsigned n)); auto. + rewrite ! bits_sign_ext by omega. f_equal. + destruct (zlt (i - Int.unsigned n) s). + rewrite zlt_true by omega; auto. + omegaContradiction. +Qed. + (** Powers of two with exponents given as 32-bit ints *) Definition one_bits' (x: int) : list Int.int := -- cgit From 8be12dfcd60d40cc5ba90657bc6a2f5528b45e55 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 12 May 2019 19:16:40 +0200 Subject: Added Int.same_if_eq Should simplify reasoning over Boolean equalities. --- lib/Integers.v | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/Integers.v b/lib/Integers.v index 369584c3..066e6b04 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -668,6 +668,11 @@ Proof. intros. generalize (eq_spec x y); case (eq x y); intros; congruence. Qed. +Theorem same_if_eq: forall x y, eq x y = true -> x = y. +Proof. + intros. generalize (eq_spec x y); rewrite H; auto. +Qed. + Theorem eq_signed: forall x y, eq x y = if zeq (signed x) (signed y) then true else false. Proof. -- cgit From 659c06eb4fabce59751476ddeb2e065759f19765 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 12 May 2019 19:17:14 +0200 Subject: Values: add functions for zero- and sign-extension of 64-bit integers --- common/Values.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/common/Values.v b/common/Values.v index 2eb778a5..52474f99 100644 --- a/common/Values.v +++ b/common/Values.v @@ -783,6 +783,18 @@ Definition rolml (v: val) (amount: int) (mask: int64): val := | _ => Vundef end. +Definition zero_ext_l (nbits: Z) (v: val) : val := + match v with + | Vlong n => Vlong(Int64.zero_ext nbits n) + | _ => Vundef + end. + +Definition sign_ext_l (nbits: Z) (v: val) : val := + match v with + | Vlong n => Vlong(Int64.sign_ext nbits n) + | _ => Vundef + end. + (** Comparisons *) Section COMPARISONS. -- cgit From b4130798bd428ad3586baa17b0f991018854997a Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 12 May 2019 19:18:22 +0200 Subject: Asmgenproof0: add predicate exec_straight0 This is a variant of exec_straight where it is allowed to take zero steps. In other words, exec_straight0 is the "star" relation, while exec_straight is the "plus" relation. In the end we need "plus" relations in simulation diagrams, to show the absence of stuttering. But the "star" relation exec_straight0 is useful to reason about code fragments that are always preceded or followed by at least one instruction. --- backend/Asmgenproof0.v | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v index 70c4323c..111e435f 100644 --- a/backend/Asmgenproof0.v +++ b/backend/Asmgenproof0.v @@ -897,6 +897,32 @@ Proof. apply code_tail_next_int with i; auto. Qed. +(** A variant that supports zero steps of execution *) + +Inductive exec_straight0: code -> regset -> mem -> + code -> regset -> mem -> Prop := + | exec_straight0_none: + forall c rs m, + exec_straight0 c rs m c rs m + | exec_straight0_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_instr ge fn i rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> + exec_straight0 c rs2 m2 c' rs3 m3 -> + exec_straight0 (i :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_step': + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_instr ge fn i rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> + exec_straight0 c rs2 m2 c' rs3 m3 -> + exec_straight (i :: c) rs1 m1 c' rs3 m3. +Proof. + intros. revert i rs1 m1 H H0. revert H1. induction 1; intros. +- apply exec_straight_one; auto. +- eapply exec_straight_step; eauto. +Qed. + End STRAIGHTLINE. (** * Properties of the Mach call stack *) -- cgit From dd243f5f35200aa9fdcc400300990192ed4bc0b6 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 11 Jun 2019 17:51:12 +0200 Subject: Errors: fixed a loop in tactic MonadInv --- common/Errors.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common/Errors.v b/common/Errors.v index 28933313..6807735a 100644 --- a/common/Errors.v +++ b/common/Errors.v @@ -164,7 +164,7 @@ Ltac monadInv1 H := | (match ?X with left _ => _ | right _ => assertion_failed end = OK _) => destruct X; [try (monadInv1 H) | discriminate] | (match (negb ?X) with true => _ | false => assertion_failed end = OK _) => - destruct X as [] eqn:?; [discriminate | try (monadInv1 H)] + destruct X as [] eqn:?; simpl negb in H; [discriminate | try (monadInv1 H)] | (match ?X with true => _ | false => assertion_failed end = OK _) => destruct X as [] eqn:?; [try (monadInv1 H) | discriminate] | (mmap ?F ?L = OK ?M) => -- cgit From f86e6618b62769b1c3e78175f95f882d3960d54b Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sat, 8 Jun 2019 18:17:13 +0200 Subject: More lemmas about powers of 2 --- lib/Zbits.v | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lib/Zbits.v b/lib/Zbits.v index fb40ccb5..27586aff 100644 --- a/lib/Zbits.v +++ b/lib/Zbits.v @@ -824,6 +824,14 @@ Proof. apply Z.log2_nonneg. - reflexivity. Qed. + +Lemma Z_is_power2_nonneg: + forall x i, Z_is_power2 x = Some i -> 0 <= i. +Proof. + unfold Z_is_power2; intros. destruct x; try discriminate. + destruct (P_is_power2 p) eqn:P; try discriminate. + replace i with (Z.log2 (Z.pos p)) by congruence. apply Z.log2_nonneg. +Qed. Lemma Z_is_power2_sound: forall x i, Z_is_power2 x = Some i -> x = two_p i /\ i = Z.log2 x. @@ -859,6 +867,12 @@ Qed. Definition Z_is_power2m1 (x: Z) : option Z := Z_is_power2 (Z.succ x). +Lemma Z_is_power2m1_nonneg: + forall x i, Z_is_power2m1 x = Some i -> 0 <= i. +Proof. + unfold Z_is_power2m1; intros. eapply Z_is_power2_nonneg; eauto. +Qed. + Lemma Z_is_power2m1_sound: forall x i, Z_is_power2m1 x = Some i -> x = two_p i - 1. Proof. -- cgit From e61e2dffaac5f5ffbffdbd87c3d3466bd9a2e83b Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sat, 15 Jun 2019 10:13:31 +0200 Subject: ndfun: add support for guards on patterns Syntax is "pat ?? bexpr => action". The whole case is selected only when "pat" matches and then "bexpr" evaluates to "true". --- tools/ndfun.ml | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/tools/ndfun.ml b/tools/ndfun.ml index 2b8bcb19..b6a87ede 100644 --- a/tools/ndfun.ml +++ b/tools/ndfun.ml @@ -41,7 +41,9 @@ let trim s = let str_match n re s = if not (Str.string_match re s 0) then [||] else begin let res = Array.make (n+1) "" in - for i = 1 to n do res.(i) <- Str.matched_group i s done; + for i = 1 to n do + res.(i) <- (try Str.matched_group i s with Not_found -> "") + done; for i = 1 to n do res.(i) <- trim res.(i) done; res end @@ -87,6 +89,11 @@ let match_temps args = let parenpats p = "(" ^ Str.global_replace re_comma ") (" p ^ ")" +(* "foo, bar, gee" -> "_ _ _" *) + +let underscores_for s = + Str.global_replace re_arg "_" (remove_commas s) + (* Extract the bound variables in a pattern. Heuristic: any identifier that starts with a lowercase letter and is not "nil". *) @@ -123,7 +130,7 @@ let re_nd = Str.regexp( let re_split_cases = Str.regexp "|" -let re_case = Str.regexp "\\(.*\\)=>\\(.*\\)" +let re_case = Str.regexp "\\([^?]*\\)\\(\\?\\?\\(.*\\)\\)?=>\\(.*\\)" let re_default_pat = Str.regexp "[ _,]*$" @@ -165,16 +172,20 @@ let transl_ndfun filename lineno s = (* Adding each case *) let numcase = ref 0 in let transl_case s = - let res = str_match 2 re_case s in + let res = str_match 4 re_case s in if Array.length res = 0 then error filename lineno ("ill-formed case: " ^ s); - let patlist = res.(1) and rhs = res.(2) in + let patlist = res.(1) and guard = res.(3) and rhs = res.(4) in let bv = boundvarspat patlist in if not (Str.string_match re_default_pat patlist 0) then begin incr numcase; bprintf a " | %s_case%d: forall %s, %s_cases %s\n" name !numcase bv name (parenpats patlist); - bprintf b " | %s => %s_case%d %s\n" patlist name !numcase bv; + if guard = "" then + bprintf b " | %s => %s_case%d %s\n" patlist name !numcase bv + else + bprintf b " | %s => if %s then %s_case%d %s else %s_default %s\n" + patlist guard name !numcase bv name (underscores_for args); bprintf c " | %s_case%d %s => (* %s *) \n" name !numcase bv patlist; bprintf c " %s\n" rhs end else begin -- cgit From b839084a1731b09542eedff0cfac8e1a7b072c69 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sat, 15 Jun 2019 14:00:49 +0200 Subject: Factor out endianness determination between tests --- test/c/aes.c | 10 +--------- test/endian.h | 8 ++++++++ test/regression/floats-basics.c | 14 +++----------- test/regression/floats.c | 12 ++---------- 4 files changed, 14 insertions(+), 30 deletions(-) create mode 100644 test/endian.h diff --git a/test/c/aes.c b/test/c/aes.c index 0aa02595..16f02e47 100644 --- a/test/c/aes.c +++ b/test/c/aes.c @@ -27,6 +27,7 @@ #include #include #include +#include "../endian.h" #define MAXKC (256/32) #define MAXKB (256/8) @@ -36,15 +37,6 @@ typedef unsigned char u8; typedef unsigned short u16; typedef unsigned int u32; -#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__) -#define ARCH_BIG_ENDIAN -#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \ - || defined(__riscv) -#undef ARCH_BIG_ENDIAN -#else -#error "unknown endianness" -#endif - #ifdef ARCH_BIG_ENDIAN #define GETU32(pt) (*(u32 *)(pt)) #define PUTU32(ct,st) (*(u32 *)(ct) = (st)) diff --git a/test/endian.h b/test/endian.h new file mode 100644 index 00000000..8be2850c --- /dev/null +++ b/test/endian.h @@ -0,0 +1,8 @@ +#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__) +#define ARCH_BIG_ENDIAN +#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \ + || defined(__riscv) || defined(__aarch64__) +#undef ARCH_BIG_ENDIAN +#else +#error "unknown endianness" +#endif diff --git a/test/regression/floats-basics.c b/test/regression/floats-basics.c index a7ba3623..876a0d42 100644 --- a/test/regression/floats-basics.c +++ b/test/regression/floats-basics.c @@ -1,18 +1,10 @@ -#include -#include +#include +#include +#include "../endian.h" #define STR_EXPAND(tok) #tok #define STR(tok) STR_EXPAND(tok) -#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__) -#define ARCH_BIG_ENDIAN -#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \ - || defined(__riscv) -#undef ARCH_BIG_ENDIAN -#else -#error "unknown endianness" -#endif - union converter64 { double dbl; struct { diff --git a/test/regression/floats.c b/test/regression/floats.c index 84c4e062..58c202ae 100644 --- a/test/regression/floats.c +++ b/test/regression/floats.c @@ -1,17 +1,9 @@ -#include +#include +#include "../endian.h" #define STR_EXPAND(tok) #tok #define STR(tok) STR_EXPAND(tok) -#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__) -#define ARCH_BIG_ENDIAN -#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \ - || defined(__riscv) -#undef ARCH_BIG_ENDIAN -#else -#error "unknown endianness" -#endif - union converter64 { double dbl; struct { -- cgit From eb85803875c5a4e90be60d870f01fac380ca18b0 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 16 Jun 2019 18:55:17 +0200 Subject: Relax lemma Val.zero_ext_and and add Val.zero_ext_andl --- common/Values.v | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/common/Values.v b/common/Values.v index 52474f99..de317734 100644 --- a/common/Values.v +++ b/common/Values.v @@ -1910,10 +1910,18 @@ Qed. Lemma zero_ext_and: forall n v, - 0 < n < Int.zwordsize -> + 0 <= n -> Val.zero_ext n v = Val.and v (Vint (Int.repr (two_p n - 1))). Proof. - intros. destruct v; simpl; auto. decEq. apply Int.zero_ext_and; auto. omega. + intros. destruct v; simpl; auto. decEq. apply Int.zero_ext_and; auto. +Qed. + +Lemma zero_ext_andl: + forall n v, + 0 <= n -> + Val.zero_ext_l n v = Val.andl v (Vlong (Int64.repr (two_p n - 1))). +Proof. + intros. destruct v; simpl; auto. decEq. apply Int64.zero_ext_and; auto. Qed. Lemma rolm_lt_zero: -- cgit From 7cdd676d002e33015b496f609538a9e86d77c543 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 8 Aug 2019 11:18:38 +0200 Subject: AArch64 port This commit adds a back-end for the AArch64 architecture, namely ARMv8 in 64-bit mode. --- .gitignore | 3 + aarch64/Archi.v | 88 ++ aarch64/Asm.v | 1312 +++++++++++++++++++++ aarch64/AsmToJSON.ml | 24 + aarch64/Asmexpand.ml | 436 +++++++ aarch64/Asmgen.v | 1151 +++++++++++++++++++ aarch64/Asmgenproof.v | 1026 +++++++++++++++++ aarch64/Asmgenproof1.v | 1836 ++++++++++++++++++++++++++++++ aarch64/Builtins1.v | 33 + aarch64/CBuiltins.ml | 72 ++ aarch64/CombineOp.v | 137 +++ aarch64/CombineOpproof.v | 161 +++ aarch64/ConstpropOp.vp | 401 +++++++ aarch64/ConstpropOpproof.v | 838 ++++++++++++++ aarch64/Conventions1.v | 380 +++++++ aarch64/Machregs.v | 210 ++++ aarch64/Machregsaux.ml | 35 + aarch64/NeedOp.v | 253 ++++ aarch64/Op.v | 1778 +++++++++++++++++++++++++++++ aarch64/PrintOp.ml | 247 ++++ aarch64/SelectLong.vp | 478 ++++++++ aarch64/SelectLongproof.v | 764 +++++++++++++ aarch64/SelectOp.vp | 566 +++++++++ aarch64/SelectOpproof.v | 1070 +++++++++++++++++ aarch64/Stacklayout.v | 140 +++ aarch64/TargetPrinter.ml | 592 ++++++++++ aarch64/ValueAOp.v | 319 ++++++ aarch64/extractionMachdep.v | 23 + backend/Asmgenproof0.v | 51 +- backend/Lineartyping.v | 2 +- backend/NeedDomain.v | 24 +- backend/SelectDivproof.v | 20 +- backend/Selectionaux.ml | 2 + backend/Selectionproof.v | 4 +- backend/ValueDomain.v | 31 +- configure | 38 +- cparser/Machine.ml | 5 + cparser/Machine.mli | 1 + driver/Configuration.ml | 2 +- driver/Frontend.ml | 1 + lib/Integers.v | 160 ++- riscV/Asmgenproof1.v | 16 - runtime/Makefile | 2 + runtime/aarch64/sysdeps.h | 45 + runtime/aarch64/vararg.S | 109 ++ test/regression/Results/builtins-aarch64 | 15 + test/regression/builtins-aarch64.c | 47 + test/regression/extasm.c | 13 +- 48 files changed, 14874 insertions(+), 87 deletions(-) create mode 100644 aarch64/Archi.v create mode 100644 aarch64/Asm.v create mode 100644 aarch64/AsmToJSON.ml create mode 100644 aarch64/Asmexpand.ml create mode 100644 aarch64/Asmgen.v create mode 100644 aarch64/Asmgenproof.v create mode 100644 aarch64/Asmgenproof1.v create mode 100644 aarch64/Builtins1.v create mode 100644 aarch64/CBuiltins.ml create mode 100644 aarch64/CombineOp.v create mode 100644 aarch64/CombineOpproof.v create mode 100644 aarch64/ConstpropOp.vp create mode 100644 aarch64/ConstpropOpproof.v create mode 100644 aarch64/Conventions1.v create mode 100644 aarch64/Machregs.v create mode 100644 aarch64/Machregsaux.ml create mode 100644 aarch64/NeedOp.v create mode 100644 aarch64/Op.v create mode 100644 aarch64/PrintOp.ml create mode 100644 aarch64/SelectLong.vp create mode 100644 aarch64/SelectLongproof.v create mode 100644 aarch64/SelectOp.vp create mode 100644 aarch64/SelectOpproof.v create mode 100644 aarch64/Stacklayout.v create mode 100644 aarch64/TargetPrinter.ml create mode 100644 aarch64/ValueAOp.v create mode 100644 aarch64/extractionMachdep.v create mode 100644 runtime/aarch64/sysdeps.h create mode 100644 runtime/aarch64/vararg.S create mode 100644 test/regression/Results/builtins-aarch64 create mode 100644 test/regression/builtins-aarch64.c diff --git a/.gitignore b/.gitignore index f33b2173..4b497387 100644 --- a/.gitignore +++ b/.gitignore @@ -40,6 +40,9 @@ /riscV/ConstpropOp.v /riscV/SelectOp.v /riscV/SelectLong.v +/aarch64/ConstpropOp.v +/aarch64/SelectOp.v +/aarch64/SelectLong.v /backend/SelectDiv.v /backend/SplitLong.v /cparser/Parser.v diff --git a/aarch64/Archi.v b/aarch64/Archi.v new file mode 100644 index 00000000..aef4ab77 --- /dev/null +++ b/aarch64/Archi.v @@ -0,0 +1,88 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Architecture-dependent parameters for AArch64 *) + +Require Import ZArith List. +(*From Flocq*) +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, ptr64; congruence. +Qed. + +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). + +(** Choose the first signaling NaN, if any; + otherwise choose the first NaN; + otherwise use default. *) + +Definition choose_nan (is_signaling: positive -> bool) + (default: bool * positive) + (l0: list (bool * positive)) : bool * positive := + let fix choose_snan (l1: list (bool * positive)) := + match l1 with + | nil => + match l0 with nil => default | n :: _ => n end + | ((s, p) as n) :: l1 => + if is_signaling p then n else choose_snan l1 + end + in choose_snan l0. + +Lemma choose_nan_idem: forall is_signaling default n, + choose_nan is_signaling default (n :: n :: nil) = + choose_nan is_signaling default (n :: nil). +Proof. + intros. destruct n as [s p]; unfold choose_nan; simpl. + destruct (is_signaling p); auto. +Qed. + +Definition choose_nan_64 := + choose_nan (fun p => negb (Pos.testbit p 51)) default_nan_64. + +Definition choose_nan_32 := + choose_nan (fun p => negb (Pos.testbit p 22)) default_nan_32. + +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. intros; apply choose_nan_idem. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. intros; apply choose_nan_idem. Qed. + +Definition fma_order {A: Type} (x y z: A) := (z, x, y). + +Definition fma_invalid_mul_is_nan := true. + +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. diff --git a/aarch64/Asm.v b/aarch64/Asm.v new file mode 100644 index 00000000..47cd3051 --- /dev/null +++ b/aarch64/Asm.v @@ -0,0 +1,1312 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Abstract syntax and semantics for AArch64 assembly language *) + +Require Import Coqlib Zbits Maps. +Require Import AST Integers Floats. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Locations Conventions. +Require Stacklayout. + +(** * Abstract syntax *) + +(** Integer registers, floating-point registers. *) + +(** In assembly files, [Xn] denotes the full 64-bit register + and [Wn] the low 32 bits of [Xn]. *) + +Inductive ireg: Type := + | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 + | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 + | X16 | X17 | X18 | X19 | X20 | X21 | X22 | X23 + | X24 | X25 | X26 | X27 | X28 | X29 | X30. + +Inductive ireg0: Type := + | RR0 (r: ireg) | XZR. + +Inductive iregsp: Type := + | RR1 (r: ireg) | XSP. + +Coercion RR0: ireg >-> ireg0. +Coercion RR1: ireg >-> iregsp. + +Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** In assembly files, [Dn] denotes the low 64-bit of a vector register, + and [Sn] the low 32 bits. *) + +Inductive freg: Type := + | D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 + | D8 | D9 | D10 | D11 | D12 | D13 | D14 | D15 + | D16 | D17 | D18 | D19 | D20 | D21 | D22 | D23 + | D24 | D25 | D26 | D27 | D28 | D29 | D30 | D31. + +Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** Bits in the condition register. *) + +Inductive crbit: Type := + | CN: crbit (**r negative *) + | CZ: crbit (**r zero *) + | CC: crbit (**r carry *) + | CV: crbit. (**r overflow *) + +Lemma crbit_eq: forall (x y: crbit), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** We model the following registers of the ARM architecture. *) + +Inductive preg: Type := + | IR: ireg -> preg (**r 64- or 32-bit integer registers *) + | FR: freg -> preg (**r double- or single-precision float registers *) + | CR: crbit -> preg (**r bits in the condition register *) + | SP: preg (**r register X31 used as stack pointer *) + | PC: preg. (**r program counter *) + +Coercion IR: ireg >-> preg. +Coercion FR: freg >-> preg. +Coercion CR: crbit >-> preg. + +Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. apply freg_eq. apply crbit_eq. Defined. + +Module PregEq. + Definition t := preg. + Definition eq := preg_eq. +End PregEq. + +Module Pregmap := EMap(PregEq). + +Definition preg_of_iregsp (r: iregsp) : preg := + match r with RR1 r => IR r | XSP => SP end. + +Coercion preg_of_iregsp: iregsp >-> preg. + +(** Conventional name for return address ([RA]) *) + +Notation "'RA'" := X30 (only parsing) : asm. + +(** The instruction set. Most instructions correspond exactly to + actual AArch64 instructions. See the ARM reference manuals for more + details. Some instructions, described below, are + pseudo-instructions: they expand to canned instruction sequences + during the printing of the assembly code. *) + +Definition label := positive. + +Inductive isize: Type := + | W (**r 32-bit integer operation *) + | X. (**r 64-bit integer operation *) + +Inductive fsize: Type := + | S (**r 32-bit, single-precision FP operation *) + | D. (**r 64-bit, double-precision FP operation *) + +Inductive testcond : Type := + | TCeq: testcond (**r equal *) + | TCne: testcond (**r not equal *) + | TChs: testcond (**r unsigned higher or same *) + | TClo: testcond (**r unsigned lower *) + | TCmi: testcond (**r negative *) + | TCpl: testcond (**r positive *) + | TChi: testcond (**r unsigned higher *) + | TCls: testcond (**r unsigned lower or same *) + | TCge: testcond (**r signed greater or equal *) + | TClt: testcond (**r signed less than *) + | TCgt: testcond (**r signed greater *) + | TCle: testcond. (**r signed less than or equal *) + +Inductive addressing: Type := + | ADimm (base: iregsp) (n: int64) (**r base plus immediate offset *) + | ADreg (base: iregsp) (r: ireg) (**r base plus reg *) + | ADlsl (base: iregsp) (r: ireg) (n: int) (**r base plus reg LSL n *) + | ADsxt (base: iregsp) (r: ireg) (n: int) (**r base plus SIGN-EXT(reg) LSL n *) + | ADuxt (base: iregsp) (r: ireg) (n: int) (**r base plus ZERO-EXT(reg) LSL n *) + | ADadr (base: iregsp) (id: ident) (ofs: ptrofs) (**r base plus low address of [id + ofs] *) + | ADpostincr (base: iregsp) (n: int64). (**r base plus offset; base is updated after *) + +Inductive shift_op: Type := + | SOnone + | SOlsl (n: int) + | SOlsr (n: int) + | SOasr (n: int) + | SOror (n: int). + +Inductive extend_op: Type := + | EOsxtb (n: int) + | EOsxth (n: int) + | EOsxtw (n: int) + | EOuxtb (n: int) + | EOuxth (n: int) + | EOuxtw (n: int) + | EOuxtx (n: int). + +Inductive instruction: Type := + (** Branches *) + | Pb (lbl: label) (**r branch *) + | Pbc (c: testcond) (lbl: label) (**r conditional branch *) + | Pbl (id: ident) (sg: signature) (**r jump to function and link *) + | Pbs (id: ident) (sg: signature) (**r jump to function *) + | Pblr (r: ireg) (sg: signature) (**r indirect jump and link *) + | Pbr (r: ireg) (sg: signature) (**r indirect jump *) + | Pret (r: ireg) (**r return *) + | Pcbnz (sz: isize) (r: ireg) (lbl: label) (**r branch if not zero *) + | Pcbz (sz: isize) (r: ireg) (lbl: label) (**r branch if zero *) + | Ptbnz (sz: isize) (r: ireg) (n: int) (lbl: label) (**r branch if bit n is not zero *) + | Ptbz (sz: isize) (r: ireg) (n: int) (lbl: label) (**r branch if bit n is zero *) + (** Memory loads and stores *) + | Pldrw (rd: ireg) (a: addressing) (**r load int32 *) + | Pldrw_a (rd: ireg) (a: addressing) (**r load int32 as any32 *) + | Pldrx (rd: ireg) (a: addressing) (**r load int64 *) + | Pldrx_a (rd: ireg) (a: addressing) (**r load int64 as any64 *) + | Pldrb (sz: isize) (rd: ireg) (a: addressing) (**r load int8, zero-extend *) + | Pldrsb (sz: isize) (rd: ireg) (a: addressing) (**r load int8, sign-extend *) + | Pldrh (sz: isize) (rd: ireg) (a: addressing) (**r load int16, zero-extend *) + | Pldrsh (sz: isize) (rd: ireg) (a: addressing) (**r load int16, sign-extend *) + | Pldrzw (rd: ireg) (a: addressing) (**r load int32, zero-extend to int64 *) + | Pldrsw (rd: ireg) (a: addressing) (**r load int32, sign-extend to int64 *) + | Pldp (rd1 rd2: ireg) (a: addressing) (**r load two int64 *) + | Pstrw (rs: ireg) (a: addressing) (**r store int32 *) + | Pstrw_a (rs: ireg) (a: addressing) (**r store int32 as any32 *) + | Pstrx (rs: ireg) (a: addressing) (**r store int64 *) + | Pstrx_a (rs: ireg) (a: addressing) (**r store int64 as any64 *) + | Pstrb (rs: ireg) (a: addressing) (**r store int8 *) + | Pstrh (rs: ireg) (a: addressing) (**r store int16 *) + | Pstp (rs1 rs2: ireg) (a: addressing) (**r store two int64 *) + (** Integer arithmetic, immediate *) + | Paddimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r addition *) + | Psubimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r subtraction *) + | Pcmpimm (sz: isize) (r1: ireg) (n: Z) (**r compare *) + | Pcmnimm (sz: isize) (r1: ireg) (n: Z) (**r compare negative *) + (** Move integer register *) + | Pmov (rd: iregsp) (r1: iregsp) + (** Logical, immediate *) + | Pandimm (sz: isize) (rd: ireg) (r1: ireg0) (n: Z) (**r and *) + | Peorimm (sz: isize) (rd: ireg) (r1: ireg0) (n: Z) (**r xor *) + | Porrimm (sz: isize) (rd: ireg) (r1: ireg0) (n: Z) (**r or *) + | Ptstimm (sz: isize) (r1: ireg) (n: Z) (**r and, then set flags *) + (** Move wide immediate *) + | Pmovz (sz: isize) (rd: ireg) (n: Z) (pos: Z) (**r move [n << pos] to [rd] *) + | Pmovn (sz: isize) (rd: ireg) (n: Z) (pos: Z) (**r move [NOT(n << pos)] to [rd] *) + | Pmovk (sz: isize) (rd: ireg) (n: Z) (pos: Z) (**r insert 16 bits of [n] at [pos] in rd *) + (** PC-relative addressing *) + | Padrp (rd: ireg) (id: ident) (ofs: ptrofs) (**r set [rd] to high address of [id + ofs] *) + | Paddadr (rd: ireg) (r1: ireg) (id: ident) (ofs: ptrofs) (**r add the low address of [id + ofs] *) + (** Bit-field operations *) + | Psbfiz (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r sign extend and shift left *) + | Psbfx (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r shift right and sign extend *) + | Pubfiz (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r zero extend and shift left *) + | Pubfx (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r shift right and zero extend *) + (** Integer arithmetic, shifted register *) + | Padd (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r addition *) + | Psub (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r subtraction *) + | Pcmp (sz: isize) (r1: ireg0) (r2: ireg) (s: shift_op) (**r compare *) + | Pcmn (sz: isize) (r1: ireg0) (r2: ireg) (s: shift_op) (**r compare negative *) + (** Integer arithmetic, extending register *) + | Paddext (rd: iregsp) (r1: iregsp) (r2: ireg) (x: extend_op) (**r int64-int32 add *) + | Psubext (rd: iregsp) (r1: iregsp) (r2: ireg) (x: extend_op) (**r int64-int32 sub *) + | Pcmpext (r1: ireg) (r2: ireg) (x: extend_op) (**r int64-int32 cmp *) + | Pcmnext (r1: ireg) (r2: ireg) (x: extend_op) (**r int64-int32 cmn *) + (** Logical, shifted register *) + | Pand (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r and *) + | Pbic (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r and-not *) + | Peon (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r xor-not *) + | Peor (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r xor *) + | Porr (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r or *) + | Porn (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r or-not *) + | Ptst (sz: isize) (r1: ireg0) (r2: ireg) (s: shift_op) (**r and, then set flags *) + (** Variable shifts *) + | Pasrv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r arithmetic right shift *) + | Plslv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r left shift *) + | Plsrv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r logical right shift *) + | Prorv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r rotate right *) + (** Bit operations *) + | Pcls (sz: isize) (rd r1: ireg) (**r count leading sign bits *) + | Pclz (sz: isize) (rd r1: ireg) (**r count leading zero bits *) + | Prev (sz: isize) (rd r1: ireg) (**r reverse bytes *) + | Prev16 (sz: isize) (rd r1: ireg) (**r reverse bytes in each 16-bit word *) + (** Conditional data processing *) + | Pcsel (rd: ireg) (r1 r2: ireg) (c: testcond) (**r int conditional move *) + | Pcset (rd: ireg) (c: testcond) (**r set to 1/0 if cond is true/false *) +(* + | Pcsetm (rd: ireg) (c: testcond) (**r set to -1/0 if cond is true/false *) +*) + (** Integer multiply/divide *) + | Pmadd (sz: isize) (rd: ireg) (r1 r2: ireg) (r3: ireg0) (**r multiply-add *) + | Pmsub (sz: isize) (rd: ireg) (r1 r2: ireg) (r3: ireg0) (**r multiply-sub *) + | Psmulh (rd: ireg) (r1 r2: ireg) (**r signed multiply high *) + | Pumulh (rd: ireg) (r1 r2: ireg) (**r unsigned multiply high *) + | Psdiv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r signed division *) + | Pudiv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r unsigned division *) + (** Floating-point loads and stores *) + | Pldrs (rd: freg) (a: addressing) (**r load float32 (single precision) *) + | Pldrd (rd: freg) (a: addressing) (**r load float64 (double precision) *) + | Pldrd_a (rd: freg) (a: addressing) (**r load float64 as any64 *) + | Pstrs (rs: freg) (a: addressing) (**r store float32 *) + | Pstrd (rs: freg) (a: addressing) (**r store float64 *) + | Pstrd_a (rs: freg) (a: addressing) (**r store float64 as any64 *) + (** Floating-point move *) + | Pfmov (rd r1: freg) + | Pfmovimms (rd: freg) (f: float32) (**r load float32 constant *) + | Pfmovimmd (rd: freg) (f: float) (**r load float64 constant *) + | Pfmovi (fsz: fsize) (rd: freg) (r1: ireg0) (**r copy int reg to FP reg *) + (** Floating-point conversions *) + | Pfcvtds (rd r1: freg) (**r convert float32 to float64 *) + | Pfcvtsd (rd r1: freg) (**r convert float64 to float32 *) + | Pfcvtzs (isz: isize) (fsz: fsize) (rd: ireg) (r1: freg) (**r convert float to signed int *) + | Pfcvtzu (isz: isize) (fsz: fsize) (rd: ireg) (r1: freg) (**r convert float to unsigned int *) + | Pscvtf (fsz: fsize) (isz: isize) (rd: freg) (r1: ireg) (**r convert signed int to float *) + | Pucvtf (fsz: fsize) (isz: isize) (rd: freg) (r1: ireg) (**r convert unsigned int to float *) + (** Floating-point arithmetic *) + | Pfabs (sz: fsize) (rd r1: freg) (**r absolute value *) + | Pfneg (sz: fsize) (rd r1: freg) (**r negation *) + | Pfsqrt (sz: fsize) (rd r1: freg) (**r square root *) + | Pfadd (sz: fsize) (rd r1 r2: freg) (**r addition *) + | Pfdiv (sz: fsize) (rd r1 r2: freg) (**r division *) + | Pfmul (sz: fsize) (rd r1 r2: freg) (**r multiplication *) + | Pfnmul (sz: fsize) (rd r1 r2: freg) (**r multiply-negate *) + | Pfsub (sz: fsize) (rd r1 r2: freg) (**r subtraction *) + | Pfmadd (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = r3 + r1 * r2] *) + | Pfmsub (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = r3 - r1 * r2] *) + | Pfnmadd (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = - r3 - r1 * r2] *) + | Pfnmsub (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = - r3 + r1 * r2] *) + (** Floating-point comparison *) + | Pfcmp (sz: fsize) (r1 r2: freg) (**r compare [r1] and [r2] *) + | Pfcmp0 (sz: fsize) (r1: freg) (**r compare [r1] and [+0.0] *) + (** Floating-point conditional select *) + | Pfsel (rd r1 r2: freg) (cond: testcond) + (** Pseudo-instructions *) + | Pallocframe (sz: Z) (linkofs: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (linkofs: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Plabel (lbl: label) (**r define a code label *) + | Ploadsymbol (rd: ireg) (id: ident) (**r load the address of [id] *) + | Pcvtsw2x (rd: ireg) (r1: ireg) (**r sign-extend 32-bit int to 64-bit *) + | Pcvtuw2x (rd: ireg) (r1: ireg) (**r zero-extend 32-bit int to 64-bit *) + | Pcvtx2w (rd: ireg) (**r retype a 64-bit int as a 32-bit int *) + | Pbtbl (r1: ireg) (tbl: list label) (**r N-way branch through a jump table *) + | Pbuiltin (ef: external_function) + (args: list (builtin_arg preg)) (res: builtin_res preg) (**r built-in function (pseudo) *) + | Pnop (**r no operation *) + | Pcfi_adjust (ofs: int) (**r .cfi_adjust debug directive *) + | Pcfi_rel_offset (ofs: int) (**r .cfi_rel_offset debug directive *) +. + +Definition code := list instruction. +Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +(** * Operational semantics *) + +(** The semantics operates over a single mapping from registers + (type [preg]) to values. We maintain (but do not enforce) + the convention that integer registers are mapped to values of + type [Tint], float registers to values of type [Tfloat], + and condition bits to either [Vzero] or [Vone]. *) + +Definition regset := Pregmap.t val. +Definition genv := Genv.t fundef unit. + +(** The value of an [ireg0] is either the value of the integer register, + or 0. *) + +Definition ir0w (rs: regset) (r: ireg0) : val := + match r with RR0 r => rs (IR r) | XZR => Vint Int.zero end. +Definition ir0x (rs: regset) (r: ireg0) : val := + match r with RR0 r => rs (IR r) | XZR => Vlong Int64.zero end. + +(** Concise notations for accessing and updating the values of registers. *) + +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. +Notation "a ## b" := (ir0w a b) (at level 1, only parsing) : asm. +Notation "a ### b" := (ir0x a b) (at level 1, only parsing) : 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. + +(** Undefining the condition codes *) + +Definition undef_flags (rs: regset) : regset := + fun r => match r with CR _ => Vundef | _ => rs r 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. + +(** The two functions below axiomatize how the linker processes + symbolic references [symbol + offset]. It computes the + difference between the address and the PC, and splits it into: + - 12 low bits usable as an offset in an addressing mode; + - 21 high bits usable as argument to the ADRP instruction. + + In CompCert's model, we cannot really describe PC-relative addressing, + but we can claim that the address of [symbol + offset] decomposes + as the sum of + - a low part, usable as an offset in an addressing mode; + - a high part, usable as argument to the ADRP instruction. *) + +Parameter symbol_low: genv -> ident -> ptrofs -> val. +Parameter symbol_high: genv -> ident -> ptrofs -> val. + +Axiom symbol_high_low: + forall (ge: genv) (id: ident) (ofs: ptrofs), + Val.addl (symbol_high ge id ofs) (symbol_low ge id ofs) = Genv.symbol_address ge id ofs. + +Section RELSEM. + +Variable ge: genv. + +(** Looking up instructions in a code sequence by position. *) + +Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := + match c with + | nil => None + | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il + end. + +(** Position corresponding to a label *) + +Definition is_label (lbl: label) (instr: instruction) : bool := + match instr with + | Plabel lbl' => if peq lbl lbl' then true else false + | _ => false + end. + +Lemma is_label_correct: + forall lbl instr, + if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. +Proof. + intros. destruct instr; simpl; try discriminate. destruct (peq lbl lbl0); congruence. +Qed. + +Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := + match c with + | nil => None + | instr :: c' => + if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' + end. + +(** The semantics is purely small-step and defined as a function + from the current state (a register set + a memory state) + to either [Next rs' m'] where [rs'] and [m'] are the updated register + set and memory state after execution of the instruction at [rs#PC], + or [Stuck] if the processor is stuck. *) + +Inductive outcome: Type := + | Next: regset -> mem -> outcome + | Stuck: outcome. + +(** Manipulations over the [PC] register: continuing with the next + instruction ([nextinstr]) or branching to a label ([goto_label]). *) + +Definition nextinstr (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). + +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := + match label_pos lbl 0 (fn_code f) with + | None => Stuck + | Some pos => + match rs#PC with + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m + | _ => Stuck + end + end. + +(** Testing a condition *) + +Definition eval_testcond (c: testcond) (rs: regset) : option bool := + match c with + | TCeq => (**r equal *) + match rs#CZ with + | Vint n => Some (Int.eq n Int.one) + | _ => None + end + | TCne => (**r not equal *) + match rs#CZ with + | Vint n => Some (Int.eq n Int.zero) + | _ => None + end + | TClo => (**r unsigned less than *) + match rs#CC with + | Vint n => Some (Int.eq n Int.zero) + | _ => None + end + | TCls => (**r unsigned less or equal *) + match rs#CC, rs#CZ with + | Vint c, Vint z => Some (Int.eq c Int.zero || Int.eq z Int.one) + | _, _ => None + end + | TChs => (**r unsigned greater or equal *) + match rs#CC with + | Vint n => Some (Int.eq n Int.one) + | _ => None + end + | TChi => (**r unsigned greater *) + match rs#CC, rs#CZ with + | Vint c, Vint z => Some (Int.eq c Int.one && Int.eq z Int.zero) + | _, _ => None + end + | TClt => (**r signed less than *) + match rs#CV, rs#CN with + | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.one) + | _, _ => None + end + | TCle => (**r signed less or equal *) + match rs#CV, rs#CN, rs#CZ with + | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.one || Int.eq z Int.one) + | _, _, _ => None + end + | TCge => (**r signed greater or equal *) + match rs#CV, rs#CN with + | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.zero) + | _, _ => None + end + | TCgt => (**r signed greater *) + match rs#CV, rs#CN, rs#CZ with + | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.zero && Int.eq z Int.zero) + | _, _, _ => None + end + | TCpl => (**r positive *) + match rs#CN with + | Vint n => Some (Int.eq n Int.zero) + | _ => None + end + | TCmi => (**r negative *) + match rs#CN with + | Vint n => Some (Int.eq n Int.one) + | _ => None + end + end. + +(** Integer "is zero?" test *) + +Definition eval_testzero (sz: isize) (v: val) (m: mem): option bool := + match sz with + | W => Val.cmpu_bool (Mem.valid_pointer m) Ceq v (Vint Int.zero) + | X => Val.cmplu_bool (Mem.valid_pointer m) Ceq v (Vlong Int64.zero) + end. + +(** Integer "bit is set?" test *) + +Definition eval_testbit (sz: isize) (v: val) (n: int): option bool := + match sz with + | W => Val.cmp_bool Cne (Val.and v (Vint (Int.shl Int.one n))) (Vint Int.zero) + | X => Val.cmpl_bool Cne (Val.andl v (Vlong (Int64.shl' Int64.one n))) (Vlong Int64.zero) + end. + +(** Evaluating an addressing mode *) + +Definition eval_addressing (a: addressing) (rs: regset): val := + match a with + | ADimm base n => Val.addl rs#base (Vlong n) + | ADreg base r => Val.addl rs#base rs#r + | ADlsl base r n => Val.addl rs#base (Val.shll rs#r (Vint n)) + | ADsxt base r n => Val.addl rs#base (Val.shll (Val.longofint rs#r) (Vint n)) + | ADuxt base r n => Val.addl rs#base (Val.shll (Val.longofintu rs#r) (Vint n)) + | ADadr base id ofs => Val.addl rs#base (symbol_low ge id ofs) + | ADpostincr base n => Vundef (* not modeled yet *) + end. + +(** Auxiliaries for memory accesses *) + +Definition exec_load (chunk: memory_chunk) (transf: val -> val) + (a: addressing) (r: preg) (rs: regset) (m: mem) := + match Mem.loadv chunk m (eval_addressing a rs) with + | None => Stuck + | Some v => Next (nextinstr (rs#r <- (transf v))) m + end. + +Definition exec_store (chunk: memory_chunk) + (a: addressing) (v: val) + (rs: regset) (m: mem) := + match Mem.storev chunk m (eval_addressing a rs) v with + | None => Stuck + | Some m' => Next (nextinstr rs) m' + end. + +(** Comparisons *) + +Definition compare_int (rs: regset) (v1 v2: val) (m: mem) := + rs#CN <- (Val.negative (Val.sub v1 v2)) + #CZ <- (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2) + #CC <- (Val.cmpu (Mem.valid_pointer m) Cge v1 v2) + #CV <- (Val.sub_overflow v1 v2). + +Definition compare_long (rs: regset) (v1 v2: val) (m: mem) := + rs#CN <- (Val.negativel (Val.subl v1 v2)) + #CZ <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2)) + #CC <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cge v1 v2)) + #CV <- (Val.subl_overflow v1 v2). + +(** Semantics of [fcmp] instructions: +<< +== N=0 Z=1 C=1 V=0 +< N=1 Z=0 C=0 V=0 +> N=0 Z=0 C=1 V=0 +unord N=0 Z=0 C=1 V=1 +>> +*) + +Definition compare_float (rs: regset) (v1 v2: val) := + match v1, v2 with + | Vfloat f1, Vfloat f2 => + rs#CN <- (Val.of_bool (Float.cmp Clt f1 f2)) + #CZ <- (Val.of_bool (Float.cmp Ceq f1 f2)) + #CC <- (Val.of_bool (negb (Float.cmp Clt f1 f2))) + #CV <- (Val.of_bool (negb (Float.ordered f1 f2))) + | _, _ => + rs#CN <- Vundef + #CZ <- Vundef + #CC <- Vundef + #CV <- Vundef + end. + +Definition compare_single (rs: regset) (v1 v2: val) := + match v1, v2 with + | Vsingle f1, Vsingle f2 => + rs#CN <- (Val.of_bool (Float32.cmp Clt f1 f2)) + #CZ <- (Val.of_bool (Float32.cmp Ceq f1 f2)) + #CC <- (Val.of_bool (negb (Float32.cmp Clt f1 f2))) + #CV <- (Val.of_bool (negb (Float32.ordered f1 f2))) + | _, _ => + rs#CN <- Vundef + #CZ <- Vundef + #CC <- Vundef + #CV <- Vundef + end. + +(** Insertion of bits into an integer *) + +Definition insert_in_int (x: val) (y: Z) (pos: Z) (len: Z) : val := + match x with + | Vint n => Vint (Int.repr (Zinsert (Int.unsigned n) y pos len)) + | _ => Vundef + end. + +Definition insert_in_long (x: val) (y: Z) (pos: Z) (len: Z) : val := + match x with + | Vlong n => Vlong (Int64.repr (Zinsert (Int64.unsigned n) y pos len)) + | _ => Vundef + end. + +(** Evaluation of shifted operands *) + +Definition eval_shift_op_int (v: val) (s: shift_op): val := + match s with + | SOnone => v + | SOlsl n => Val.shl v (Vint n) + | SOlsr n => Val.shru v (Vint n) + | SOasr n => Val.shr v (Vint n) + | SOror n => Val.ror v (Vint n) + end. + +Definition eval_shift_op_long (v: val) (s: shift_op): val := + match s with + | SOnone => v + | SOlsl n => Val.shll v (Vint n) + | SOlsr n => Val.shrlu v (Vint n) + | SOasr n => Val.shrl v (Vint n) + | SOror n => Val.rorl v (Vint n) + end. + +(** Evaluation of sign- or zero- extended operands *) + +Definition eval_extend (v: val) (x: extend_op): val := + match x with + | EOsxtb n => Val.shll (Val.longofint (Val.sign_ext 8 v)) (Vint n) + | EOsxth n => Val.shll (Val.longofint (Val.sign_ext 16 v)) (Vint n) + | EOsxtw n => Val.shll (Val.longofint v) (Vint n) + | EOuxtb n => Val.shll (Val.longofintu (Val.zero_ext 8 v)) (Vint n) + | EOuxth n => Val.shll (Val.longofintu (Val.zero_ext 16 v)) (Vint n) + | EOuxtw n => Val.shll (Val.longofintu v) (Vint n) + | EOuxtx n => Val.shll v (Vint n) + end. + +(** Bit-level conversion from integers to FP numbers *) + +Definition float32_of_bits (v: val): val := + match v with + | Vint n => Vsingle (Float32.of_bits n) + | _ => Vundef + end. + +Definition float64_of_bits (v: val): val := + match v with + | Vlong n => Vfloat (Float.of_bits n) + | _ => Vundef + end. + +(** Execution of a single instruction [i] in initial state + [rs] and [m]. Return updated state. For instructions + that correspond to actual AArch64 instructions, the cases are + straightforward transliterations of the informal descriptions + given in the ARMv8 reference manuals. 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 code we + generate cannot use those registers to hold values that must + survive the execution of the pseudo-instruction. +*) + +Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := + match i with + (** Branches *) + | Pb lbl => + goto_label f lbl rs m + | Pbc cond lbl => + match eval_testcond cond rs with + | Some true => goto_label f lbl rs m + | Some false => Next (nextinstr rs) m + | None => Stuck + end + | Pbl id sg => + Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (Genv.symbol_address ge id Ptrofs.zero)) m + | Pbs id sg => + Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m + | Pblr r sg => + Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (rs#r)) m + | Pbr r sg => + Next (rs#PC <- (rs#r)) m + | Pret r => + Next (rs#PC <- (rs#r)) m + | Pcbnz sz r lbl => + match eval_testzero sz rs#r m with + | Some true => Next (nextinstr rs) m + | Some false => goto_label f lbl rs m + | None => Stuck + end + | Pcbz sz r lbl => + match eval_testzero sz rs#r m with + | Some true => goto_label f lbl rs m + | Some false => Next (nextinstr rs) m + | None => Stuck + end + | Ptbnz sz r n lbl => + match eval_testbit sz rs#r n with + | Some true => goto_label f lbl rs m + | Some false => Next (nextinstr rs) m + | None => Stuck + end + | Ptbz sz r n lbl => + match eval_testbit sz rs#r n with + | Some true => Next (nextinstr rs) m + | Some false => goto_label f lbl rs m + | None => Stuck + end + (** Memory loads and stores *) + | Pldrw rd a => + exec_load Mint32 (fun v => v) a rd rs m + | Pldrw_a rd a => + exec_load Many32 (fun v => v) a rd rs m + | Pldrx rd a => + exec_load Mint64 (fun v => v) a rd rs m + | Pldrx_a rd a => + exec_load Many64 (fun v => v) a rd rs m + | Pldrb W rd a => + exec_load Mint8unsigned (fun v => v) a rd rs m + | Pldrb X rd a => + exec_load Mint8unsigned Val.longofintu a rd rs m + | Pldrsb W rd a => + exec_load Mint8signed (fun v => v) a rd rs m + | Pldrsb X rd a => + exec_load Mint8signed Val.longofint a rd rs m + | Pldrh W rd a => + exec_load Mint16unsigned (fun v => v) a rd rs m + | Pldrh X rd a => + exec_load Mint16unsigned Val.longofintu a rd rs m + | Pldrsh W rd a => + exec_load Mint16signed (fun v => v) a rd rs m + | Pldrsh X rd a => + exec_load Mint16signed Val.longofint a rd rs m + | Pldrzw rd a => + exec_load Mint32 Val.longofintu a rd rs m + | Pldrsw rd a => + exec_load Mint32 Val.longofint a rd rs m + | Pstrw r a => + exec_store Mint32 a rs#r rs m + | Pstrw_a r a => + exec_store Many32 a rs#r rs m + | Pstrx r a => + exec_store Mint64 a rs#r rs m + | Pstrx_a r a => + exec_store Many64 a rs#r rs m + | Pstrb r a => + exec_store Mint8unsigned a rs#r rs m + | Pstrh r a => + exec_store Mint16unsigned a rs#r rs m + (** Integer arithmetic, immediate *) + | Paddimm W rd r1 n => + Next (nextinstr (rs#rd <- (Val.add rs#r1 (Vint (Int.repr n))))) m + | Paddimm X rd r1 n => + Next (nextinstr (rs#rd <- (Val.addl rs#r1 (Vlong (Int64.repr n))))) m + | Psubimm W rd r1 n => + Next (nextinstr (rs#rd <- (Val.sub rs#r1 (Vint (Int.repr n))))) m + | Psubimm X rd r1 n => + Next (nextinstr (rs#rd <- (Val.subl rs#r1 (Vlong (Int64.repr n))))) m + | Pcmpimm W r1 n => + Next (nextinstr (compare_int rs rs#r1 (Vint (Int.repr n)) m)) m + | Pcmpimm X r1 n => + Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.repr n)) m)) m + | Pcmnimm W r1 n => + Next (nextinstr (compare_int rs rs#r1 (Vint (Int.neg (Int.repr n))) m)) m + | Pcmnimm X r1 n => + Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.neg (Int64.repr n))) m)) m + (** Move integer register *) + | Pmov rd r1 => + Next (nextinstr (rs#rd <- (rs#r1))) m + (** Logical, immediate *) + | Pandimm W rd r1 n => + Next (nextinstr (rs#rd <- (Val.and rs##r1 (Vint (Int.repr n))))) m + | Pandimm X rd r1 n => + Next (nextinstr (rs#rd <- (Val.andl rs###r1 (Vlong (Int64.repr n))))) m + | Peorimm W rd r1 n => + Next (nextinstr (rs#rd <- (Val.xor rs##r1 (Vint (Int.repr n))))) m + | Peorimm X rd r1 n => + Next (nextinstr (rs#rd <- (Val.xorl rs###r1 (Vlong (Int64.repr n))))) m + | Porrimm W rd r1 n => + Next (nextinstr (rs#rd <- (Val.or rs##r1 (Vint (Int.repr n))))) m + | Porrimm X rd r1 n => + Next (nextinstr (rs#rd <- (Val.orl rs###r1 (Vlong (Int64.repr n))))) m + | Ptstimm W r1 n => + Next (nextinstr (compare_int rs (Val.and rs#r1 (Vint (Int.repr n))) (Vint Int.zero) m)) m + | Ptstimm X r1 n => + Next (nextinstr (compare_long rs (Val.andl rs#r1 (Vlong (Int64.repr n))) (Vlong Int64.zero) m)) m + (** Move wide immediate *) + | Pmovz W rd n pos => + Next (nextinstr (rs#rd <- (Vint (Int.repr (Z.shiftl n pos))))) m + | Pmovz X rd n pos => + Next (nextinstr (rs#rd <- (Vlong (Int64.repr (Z.shiftl n pos))))) m + | Pmovn W rd n pos => + Next (nextinstr (rs#rd <- (Vint (Int.repr (Z.lnot (Z.shiftl n pos)))))) m + | Pmovn X rd n pos => + Next (nextinstr (rs#rd <- (Vlong (Int64.repr (Z.lnot (Z.shiftl n pos)))))) m + | Pmovk W rd n pos => + Next (nextinstr (rs#rd <- (insert_in_int rs#rd n pos 16))) m + | Pmovk X rd n pos => + Next (nextinstr (rs#rd <- (insert_in_long rs#rd n pos 16))) m + (** PC-relative addressing *) + | Padrp rd id ofs => + Next (nextinstr (rs#rd <- (symbol_high ge id ofs))) m + | Paddadr rd r1 id ofs => + Next (nextinstr (rs#rd <- (Val.addl rs#r1 (symbol_low ge id ofs)))) m + (** Bit-field operations *) + | Psbfiz W rd r1 r s => + Next (nextinstr (rs#rd <- (Val.shl (Val.sign_ext s rs#r1) (Vint r)))) m + | Psbfiz X rd r1 r s => + Next (nextinstr (rs#rd <- (Val.shll (Val.sign_ext_l s rs#r1) (Vint r)))) m + | Psbfx W rd r1 r s => + Next (nextinstr (rs#rd <- (Val.sign_ext s (Val.shr rs#r1 (Vint r))))) m + | Psbfx X rd r1 r s => + Next (nextinstr (rs#rd <- (Val.sign_ext_l s (Val.shrl rs#r1 (Vint r))))) m + | Pubfiz W rd r1 r s => + Next (nextinstr (rs#rd <- (Val.shl (Val.zero_ext s rs#r1) (Vint r)))) m + | Pubfiz X rd r1 r s => + Next (nextinstr (rs#rd <- (Val.shll (Val.zero_ext_l s rs#r1) (Vint r)))) m + | Pubfx W rd r1 r s => + Next (nextinstr (rs#rd <- (Val.zero_ext s (Val.shru rs#r1 (Vint r))))) m + | Pubfx X rd r1 r s => + Next (nextinstr (rs#rd <- (Val.zero_ext_l s (Val.shrlu rs#r1 (Vint r))))) m + (** Integer arithmetic, shifted register *) + | Padd W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.add rs##r1 (eval_shift_op_int rs#r2 s)))) m + | Padd X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.addl rs###r1 (eval_shift_op_long rs#r2 s)))) m + | Psub W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.sub rs##r1 (eval_shift_op_int rs#r2 s)))) m + | Psub X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.subl rs###r1 (eval_shift_op_long rs#r2 s)))) m + | Pcmp W r1 r2 s => + Next (nextinstr (compare_int rs rs##r1 (eval_shift_op_int rs#r2 s) m)) m + | Pcmp X r1 r2 s => + Next (nextinstr (compare_long rs rs###r1 (eval_shift_op_long rs#r2 s) m)) m + | Pcmn W r1 r2 s => + Next (nextinstr (compare_int rs rs##r1 (Val.neg (eval_shift_op_int rs#r2 s)) m)) m + | Pcmn X r1 r2 s => + Next (nextinstr (compare_long rs rs###r1 (Val.negl (eval_shift_op_long rs#r2 s)) m)) m + (** Integer arithmetic, extending register *) + | Paddext rd r1 r2 x => + Next (nextinstr (rs#rd <- (Val.addl rs#r1 (eval_extend rs#r2 x)))) m + | Psubext rd r1 r2 x => + Next (nextinstr (rs#rd <- (Val.subl rs#r1 (eval_extend rs#r2 x)))) m + | Pcmpext r1 r2 x => + Next (nextinstr (compare_long rs rs#r1 (eval_extend rs#r2 x) m)) m + | Pcmnext r1 r2 x => + Next (nextinstr (compare_long rs rs#r1 (Val.negl (eval_extend rs#r2 x)) m)) m + (** Logical, shifted register *) + | Pand W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.and rs##r1 (eval_shift_op_int rs#r2 s)))) m + | Pand X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.andl rs###r1 (eval_shift_op_long rs#r2 s)))) m + | Pbic W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.and rs##r1 (Val.notint (eval_shift_op_int rs#r2 s))))) m + | Pbic X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.andl rs###r1 (Val.notl (eval_shift_op_long rs#r2 s))))) m + | Peon W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.xor rs##r1 (Val.notint (eval_shift_op_int rs#r2 s))))) m + | Peon X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.xorl rs###r1 (Val.notl (eval_shift_op_long rs#r2 s))))) m + | Peor W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.xor rs##r1 (eval_shift_op_int rs#r2 s)))) m + | Peor X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.xorl rs###r1 (eval_shift_op_long rs#r2 s)))) m + | Porr W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.or rs##r1 (eval_shift_op_int rs#r2 s)))) m + | Porr X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.orl rs###r1 (eval_shift_op_long rs#r2 s)))) m + | Porn W rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.or rs##r1 (Val.notint (eval_shift_op_int rs#r2 s))))) m + | Porn X rd r1 r2 s => + Next (nextinstr (rs#rd <- (Val.orl rs###r1 (Val.notl (eval_shift_op_long rs#r2 s))))) m + | Ptst W r1 r2 s => + Next (nextinstr (compare_int rs (Val.and rs##r1 (eval_shift_op_int rs#r2 s)) (Vint Int.zero) m)) m + | Ptst X r1 r2 s => + Next (nextinstr (compare_long rs (Val.andl rs###r1 (eval_shift_op_long rs#r2 s)) (Vlong Int64.zero) m)) m + (** Variable shifts *) + | Pasrv W rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2))) m + | Pasrv X rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.shrl rs#r1 rs#r2))) m + | Plslv W rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m + | Plslv X rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.shll rs#r1 rs#r2))) m + | Plsrv W rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m + | Plsrv X rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.shrlu rs#r1 rs#r2))) m + | Prorv W rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.ror rs#r1 rs#r2))) m + | Prorv X rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.rorl rs#r1 rs#r2))) m + (** Conditional data processing *) + | Pcsel rd r1 r2 cond => + let v := + match eval_testcond cond rs with + | Some true => rs#r1 + | Some false => rs#r2 + | None => Vundef + end in + Next (nextinstr (rs#rd <- v)) m + | Pcset rd cond => + let v := + match eval_testcond cond rs with + | Some true => Vint Int.one + | Some false => Vint Int.zero + | None => Vundef + end in + Next (nextinstr (rs#rd <- v)) m + (** Integer multiply/divide *) + | Pmadd W rd r1 r2 r3 => + Next (nextinstr (rs#rd <- (Val.add rs##r3 (Val.mul rs#r1 rs#r2)))) m + | Pmadd X rd r1 r2 r3 => + Next (nextinstr (rs#rd <- (Val.addl rs###r3 (Val.mull rs#r1 rs#r2)))) m + | Pmsub W rd r1 r2 r3 => + Next (nextinstr (rs#rd <- (Val.sub rs##r3 (Val.mul rs#r1 rs#r2)))) m + | Pmsub X rd r1 r2 r3 => + Next (nextinstr (rs#rd <- (Val.subl rs###r3 (Val.mull rs#r1 rs#r2)))) m + | Psmulh rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.mullhs rs#r1 rs#r2))) m + | Pumulh rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.mullhu rs#r1 rs#r2))) m + | Psdiv W rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.divs rs#r1 rs#r2)))) m + | Psdiv X rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.divls rs#r1 rs#r2)))) m + | Pudiv W rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.divu rs#r1 rs#r2)))) m + | Pudiv X rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.divlu rs#r1 rs#r2)))) m + (** Floating-point loads and stores *) + | Pldrs rd a => + exec_load Mfloat32 (fun v => v) a rd rs m + | Pldrd rd a => + exec_load Mfloat64 (fun v => v) a rd rs m + | Pldrd_a rd a => + exec_load Many64 (fun v => v) a rd rs m + | Pstrs r a => + exec_store Mfloat32 a rs#r rs m + | Pstrd r a => + exec_store Mfloat64 a rs#r rs m + | Pstrd_a r a => + exec_store Many64 a rs#r rs m + (** Floating-point move *) + | Pfmov rd r1 => + Next (nextinstr (rs#rd <- (rs#r1))) m + | Pfmovimms rd f => + Next (nextinstr (rs#rd <- (Vsingle f))) m + | Pfmovimmd rd f => + Next (nextinstr (rs#rd <- (Vfloat f))) m + | Pfmovi S rd r1 => + Next (nextinstr (rs#rd <- (float32_of_bits rs##r1))) m + | Pfmovi D rd r1 => + Next (nextinstr (rs#rd <- (float64_of_bits rs###r1))) m + (** Floating-point conversions *) + | Pfcvtds rd r1 => + Next (nextinstr (rs#rd <- (Val.floatofsingle rs#r1))) m + | Pfcvtsd rd r1 => + Next (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m + | Pfcvtzs W S rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.intofsingle rs#r1)))) m + | Pfcvtzs W D rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m + | Pfcvtzs X S rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.longofsingle rs#r1)))) m + | Pfcvtzs X D rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.longoffloat rs#r1)))) m + | Pfcvtzu W S rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.intuofsingle rs#r1)))) m + | Pfcvtzu W D rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.intuoffloat rs#r1)))) m + | Pfcvtzu X S rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.longuofsingle rs#r1)))) m + | Pfcvtzu X D rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.longuoffloat rs#r1)))) m + | Pscvtf S W rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleofint rs#r1)))) m + | Pscvtf D W rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m + | Pscvtf S X rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleoflong rs#r1)))) m + | Pscvtf D X rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflong rs#r1)))) m + | Pucvtf S W rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleofintu rs#r1)))) m + | Pucvtf D W rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofintu rs#r1)))) m + | Pucvtf S X rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleoflongu rs#r1)))) m + | Pucvtf D X rd r1 => + Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflongu rs#r1)))) m + (** Floating-point arithmetic *) + | Pfabs S rd r1 => + Next (nextinstr (rs#rd <- (Val.absfs rs#r1))) m + | Pfabs D rd r1 => + Next (nextinstr (rs#rd <- (Val.absf rs#r1))) m + | Pfneg S rd r1 => + Next (nextinstr (rs#rd <- (Val.negfs rs#r1))) m + | Pfneg D rd r1 => + Next (nextinstr (rs#rd <- (Val.negf rs#r1))) m + | Pfadd S rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.addfs rs#r1 rs#r2))) m + | Pfadd D rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m + | Pfdiv S rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.divfs rs#r1 rs#r2))) m + | Pfdiv D rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m + | Pfmul S rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.mulfs rs#r1 rs#r2))) m + | Pfmul D rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m + | Pfnmul S rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.negfs (Val.mulfs rs#r1 rs#r2)))) m + | Pfnmul D rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.negf (Val.mulf rs#r1 rs#r2)))) m + | Pfsub S rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.subfs rs#r1 rs#r2))) m + | Pfsub D rd r1 r2 => + Next (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m + (** Floating-point comparison *) + | Pfcmp S r1 r2 => + Next (nextinstr (compare_single rs rs#r1 rs#r2)) m + | Pfcmp D r1 r2 => + Next (nextinstr (compare_float rs rs#r1 rs#r2)) m + | Pfcmp0 S r1 => + Next (nextinstr (compare_single rs rs#r1 (Vsingle Float32.zero))) m + | Pfcmp0 D r1 => + Next (nextinstr (compare_float rs rs#r1 (Vfloat Float.zero))) m + (** Floating-point conditional select *) + | Pfsel rd r1 r2 cond => + let v := + match eval_testcond cond rs with + | Some true => rs#r1 + | Some false => rs#r2 + | None => Vundef + end in + Next (nextinstr (rs#rd <- v)) m + (** Pseudo-instructions *) + | Pallocframe sz pos => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mint64 m1 (Val.offset_ptr sp pos) rs#SP with + | None => Stuck + | Some m2 => Next (nextinstr (rs #X29 <- (rs#SP) #SP <- sp #X16 <- Vundef)) m2 + end + | Pfreeframe sz pos => + match Mem.loadv Mint64 m (Val.offset_ptr rs#SP pos) with + | None => Stuck + | Some v => + match rs#SP with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => Stuck + | Some m' => Next (nextinstr (rs#SP <- v #X16 <- Vundef)) m' + end + | _ => Stuck + end + end + | Plabel lbl => + Next (nextinstr rs) m + | Ploadsymbol rd id => + Next (nextinstr (rs#rd <- (Genv.symbol_address ge id Ptrofs.zero))) m + | Pcvtsw2x rd r1 => + Next (nextinstr (rs#rd <- (Val.longofint rs#r1))) m + | Pcvtuw2x rd r1 => + Next (nextinstr (rs#rd <- (Val.longofintu rs#r1))) m + | Pcvtx2w rd => + Next (nextinstr (rs#rd <- (Val.loword rs#rd))) m + | Pbtbl r tbl => + match (rs#X16 <- Vundef)#r with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => Stuck + | Some lbl => goto_label f lbl (rs#X16 <- Vundef #X17 <- Vundef) m + end + | _ => Stuck + end + | Pbuiltin ef args res => Stuck (**r treated specially below *) + (** The following instructions and directives are not generated directly + by Asmgen, so we do not model them. *) + | Pldp _ _ _ + | Pstp _ _ _ + | Pcls _ _ _ + | Pclz _ _ _ + | Prev _ _ _ + | Prev16 _ _ _ + | Pfsqrt _ _ _ + | Pfmadd _ _ _ _ _ + | Pfmsub _ _ _ _ _ + | Pfnmadd _ _ _ _ _ + | Pfnmsub _ _ _ _ _ + | Pnop + | Pcfi_adjust _ + | Pcfi_rel_offset _ => + Stuck + end. + +(** Translation of the LTL/Linear/Mach view of machine registers + to the AArch64 view. Note that no LTL register maps to [X16], + [X18], nor [X30]. + [X18] is reserved as the platform register and never used by the + code generated by CompCert. + [X30] is used for the return address, and can also be used as temporary. + [X16] can be used as temporary. *) + +Definition preg_of (r: mreg) : preg := + match r with + | R0 => X0 | R1 => X1 | R2 => X2 | R3 => X3 + | R4 => X4 | R5 => X5 | R6 => X6 | R7 => X7 + | R8 => X8 | R9 => X9 | R10 => X10 | R11 => X11 + | R12 => X12 | R13 => X13 | R14 => X14 | R15 => X15 + | R17 => X17 | R19 => X19 + | R20 => X20 | R21 => X21 | R22 => X22 | R23 => X23 + | R24 => X24 | R25 => X25 | R26 => X26 | R27 => X27 + | R28 => X28 | R29 => X29 + | F0 => D0 | F1 => D1 | F2 => D2 | F3 => D3 + | F4 => D4 | F5 => D5 | F6 => D6 | F7 => D7 + | F8 => D8 | F9 => D9 | F10 => D10 | F11 => D11 + | F12 => D12 | F13 => D13 | F14 => D14 | F15 => D15 + | F16 => D16 | F17 => D17 | F18 => D18 | F19 => D19 + | F20 => D20 | F21 => D21 | F22 => D22 | F23 => D23 + | F24 => D24 | F25 => D25 | F26 => D26 | F27 => D27 + | F28 => D28 | F29 => D29 | F30 => D30 | F31 => D31 + end. + +(** Undefine all registers except SP and callee-save registers *) + +Definition undef_caller_save_regs (rs: regset) : regset := + fun r => + if preg_eq r SP + || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) + then rs r + else Vundef. + +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use AArch64 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 (Locations.S Outgoing ofs ty) v. + +Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := + | extcall_arg_one: forall l v, + extcall_arg rs m l v -> + extcall_arg_pair rs m (One l) v + | extcall_arg_twolong: forall hi lo vhi vlo, + extcall_arg rs m hi vhi -> + extcall_arg rs m lo vlo -> + extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. + +Definition loc_external_result (sg: signature) : rpair preg := + map_rpair preg_of (loc_result sg). + +(** Execution of the instruction at [rs#PC]. *) + +Inductive state: Type := + | State: regset -> mem -> state. + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f i rs m rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some i -> + exec_instr f i rs m = Next rs' m' -> + step (State rs m) E0 (State rs' m') + | exec_step_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> + eval_builtin_args ge rs rs#SP m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextinstr + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> + step (State rs m) t (State rs' m') + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) #PC <- (rs RA) -> + step (State rs m) t (State rs' m'). + +End RELSEM. + +(** Execution of whole programs. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall m0, + Genv.init_mem p = Some m0 -> + let ge := Genv.globalenv p in + let rs0 := + (Pregmap.init Vundef) + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # RA <- Vnullptr + # SP <- Vnullptr in + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs#PC = Vnullptr -> + rs#X0 = Vint r -> + final_state (State rs m) r. + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +(** Determinacy of the [Asm] semantics. *) + +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + split. constructor. auto. + discriminate. + discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + inv H. red; intros; red; intros. inv H; rewrite H0 in *; discriminate. +- (* final states *) + inv H; inv H0. congruence. +Qed. + +(** Classification functions for processor registers (used in Asmgenproof). *) + +Definition data_preg (r: preg) : bool := + match r with + | IR X16 => false + | IR X30 => false + | IR _ => true + | FR _ => true + | CR _ => false + | SP => true + | PC => false + end. diff --git a/aarch64/AsmToJSON.ml b/aarch64/AsmToJSON.ml new file mode 100644 index 00000000..b7cfc152 --- /dev/null +++ b/aarch64/AsmToJSON.ml @@ -0,0 +1,24 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Functions to serialize AArch64 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/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml new file mode 100644 index 00000000..71bd0042 --- /dev/null +++ b/aarch64/Asmexpand.ml @@ -0,0 +1,436 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Expanding built-ins and some pseudo-instructions by rewriting + of the AArch64 assembly code. *) + +open Asm +open Asmexpandaux +open AST +open Camlcoq +module Ptrofs = Integers.Ptrofs + +exception Error of string + +(* Useful constants *) + +let _0 = Z.zero +let _1 = Z.one +let _2 = Z.of_sint 2 +let _4 = Z.of_sint 4 +let _8 = Z.of_sint 8 +let _16 = Z.of_sint 16 +let _m1 = Z.of_sint (-1) + +(* Emit instruction sequences that set or offset a register by a constant. *) + +let expand_loadimm32 (dst: ireg) n = + List.iter emit (Asmgen.loadimm32 dst n []) + +let expand_addimm64 (dst: iregsp) (src: iregsp) n = + List.iter emit (Asmgen.addimm64 dst src n []) + +let expand_storeptr (src: ireg) (base: iregsp) ofs = + List.iter emit (Asmgen.storeptr src base ofs []) + +(* Handling of varargs *) + +(* Determine the number of int registers, FP registers, and stack locations + used to pass the fixed parameters. *) + +let rec next_arg_locations ir fr stk = function + | [] -> + (ir, fr, stk) + | (Tint | Tlong | Tany32 | Tany64) :: l -> + if ir < 8 + then next_arg_locations (ir + 1) fr stk l + else next_arg_locations ir fr (stk + 8) l + | (Tfloat | Tsingle) :: l -> + if fr < 8 + then next_arg_locations ir (fr + 1) stk l + else next_arg_locations ir fr (stk + 8) l + +(* Allocate memory on the stack and use it to save the registers + used for parameter passing. As an optimization, do not save + the registers used to pass the fixed parameters. *) + +let int_param_regs = [| X0; X1; X2; X3; X4; X5; X6; X7 |] +let float_param_regs = [| D0; D1; D2; D3; D4; D5; D6; D7 |] +let size_save_register_area = 8*8 + 8*16 + +let save_parameter_registers ir fr = + emit (Psubimm(X, XSP, XSP, Z.of_uint size_save_register_area)); + let i = ref ir in + while !i < 8 do + let pos = 8*16 + !i*8 in + if !i land 1 = 0 then begin + emit (Pstp(int_param_regs.(!i), int_param_regs.(!i + 1), + ADimm(XSP, Z.of_uint pos))); + i := !i + 2 + end else begin + emit (Pstrx(int_param_regs.(!i), ADimm(XSP, Z.of_uint pos))); + i := !i + 1 + end + done; + for i = fr to 7 do + let pos = i*16 in + emit (Pstrd(float_param_regs.(i), ADimm(XSP, Z.of_uint pos))) + done + +(* Initialize a va_list as per va_start. + Register r points to the following struct: + + typedef struct __va_list { + void *__stack; // next stack parameter + void *__gr_top; // top of the save area for int regs + void *__vr_top; // top of the save area for float regs + int__gr_offs; // offset from gr_top to next int reg + int__vr_offs; // offset from gr_top to next FP reg + } +*) + +let current_function_stacksize = ref 0L + +let expand_builtin_va_start r = + if not (is_current_function_variadic ()) then + invalid_arg "Fatal error: va_start used in non-vararg function"; + let (ir, fr, stk) = + next_arg_locations 0 0 0 (get_current_function_args ()) in + let stack_ofs = Int64.(add !current_function_stacksize (of_int stk)) + and gr_top_ofs = !current_function_stacksize + and vr_top_ofs = Int64.(sub !current_function_stacksize 64L) + and gr_offs = - ((8 - ir) * 8) + and vr_offs = - ((8 - fr) * 16) in + (* va->__stack = sp + stack_ofs *) + expand_addimm64 (RR1 X16) XSP (coqint_of_camlint64 stack_ofs); + emit (Pstrx(X16, ADimm(RR1 r, coqint_of_camlint64 0L))); + (* va->__gr_top = sp + gr_top_ofs *) + if gr_top_ofs <> stack_ofs then + expand_addimm64 (RR1 X16) XSP (coqint_of_camlint64 gr_top_ofs); + emit (Pstrx(X16, ADimm(RR1 r, coqint_of_camlint64 8L))); + (* va->__vr_top = sp + vr_top_ofs *) + expand_addimm64 (RR1 X16) XSP (coqint_of_camlint64 vr_top_ofs); + emit (Pstrx(X16, ADimm(RR1 r, coqint_of_camlint64 16L))); + (* va->__gr_offs = gr_offs *) + expand_loadimm32 X16 (coqint_of_camlint (Int32.of_int gr_offs)); + emit (Pstrw(X16, ADimm(RR1 r, coqint_of_camlint64 24L))); + (* va->__vr_offs = vr_offs *) + expand_loadimm32 X16 (coqint_of_camlint (Int32.of_int vr_offs)); + emit (Pstrw(X16, ADimm(RR1 r, coqint_of_camlint64 28L))) + +(* Handling of annotations *) + +let expand_annot_val kind txt targ args res = + emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); + match args, res with + | [BA(IR src)], BR(IR dst) -> + if dst <> src then emit (Pmov (RR1 dst, RR1 src)) + | [BA(FR src)], BR(FR dst) -> + if dst <> src then emit (Pfmov (dst, src)) + | _, _ -> + raise (Error "ill-formed __builtin_annot_val") + +(* Handling of memcpy *) + +(* We assume unaligned memory accesses are efficient. Hence we use + memory accesses as wide as we can, up to 16 bytes. + Temporary registers used: x15 x16 x17 x29 x30. *) + +let offset_in_range ofs = + let ofs = Z.to_int64 ofs in 0L <= ofs && ofs < 0x1000L + +let memcpy_small_arg sz arg tmp = + match arg with + | BA (IR r) -> + (RR1 r, _0) + | BA_addrstack ofs -> + if offset_in_range ofs + && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz))) + then (XSP, ofs) + else begin expand_addimm64 (RR1 tmp) XSP ofs; (RR1 tmp, _0) end + | _ -> + assert false + +let expand_builtin_memcpy_small sz al src dst = + let (tsrc, tdst) = + if dst <> BA (IR X17) then (X17, X29) else (X29, X17) in + let (rsrc, osrc) = memcpy_small_arg sz src tsrc in + let (rdst, odst) = memcpy_small_arg sz dst tdst in + let rec copy osrc odst sz = + if sz >= 16 then begin + emit (Pldp(X16, X30, ADimm(rsrc, osrc))); + emit (Pstp(X16, X30, ADimm(rdst, odst))); + copy (Ptrofs.add osrc _16) (Ptrofs.add odst _16) (sz - 16) + end + else if sz >= 8 then begin + emit (Pldrx(X16, ADimm(rsrc, osrc))); + emit (Pstrx(X16, ADimm(rdst, odst))); + copy (Ptrofs.add osrc _8) (Ptrofs.add odst _8) (sz - 8) + end + else if sz >= 4 then begin + emit (Pldrw(X16, ADimm(rsrc, osrc))); + emit (Pstrw(X16, ADimm(rdst, odst))); + copy (Ptrofs.add osrc _4) (Ptrofs.add odst _4) (sz - 4) + end + else if sz >= 2 then begin + emit (Pldrh(W, X16, ADimm(rsrc, osrc))); + emit (Pstrh(X16, ADimm(rdst, odst))); + copy (Ptrofs.add osrc _2) (Ptrofs.add odst _2) (sz - 2) + end + else if sz >= 1 then begin + emit (Pldrb(W, X16, ADimm(rsrc, osrc))); + emit (Pstrb(X16, ADimm(rdst, odst))); + copy (Ptrofs.add osrc _1) (Ptrofs.add odst _1) (sz - 1) + end + in copy osrc odst sz + +let memcpy_big_arg arg tmp = + match arg with + | BA (IR r) -> emit (Pmov(RR1 tmp, RR1 r)) + | BA_addrstack ofs -> expand_addimm64 (RR1 tmp) XSP ofs + | _ -> assert false + +let expand_builtin_memcpy_big sz al src dst = + assert (sz >= 16); + memcpy_big_arg src X30; + memcpy_big_arg dst X29; + let lbl = new_label () in + expand_loadimm32 X15 (Z.of_uint (sz / 16)); + emit (Plabel lbl); + emit (Pldp(X16, X17, ADpostincr(RR1 X30, _16))); + emit (Pstp(X16, X17, ADpostincr(RR1 X29, _16))); + emit (Psubimm(W, RR1 X15, RR1 X15, _1)); + emit (Pcbnz(W, X15, lbl)); + if sz mod 16 >= 8 then begin + emit (Pldrx(X16, ADpostincr(RR1 X30, _8))); + emit (Pstrx(X16, ADpostincr(RR1 X29, _8))) + end; + if sz mod 8 >= 4 then begin + emit (Pldrw(X16, ADpostincr(RR1 X30, _4))); + emit (Pstrw(X16, ADpostincr(RR1 X29, _4))) + end; + if sz mod 4 >= 2 then begin + emit (Pldrh(W, X16, ADpostincr(RR1 X30, _2))); + emit (Pstrh(X16, ADpostincr(RR1 X29, _2))) + end; + if sz mod 2 >= 1 then begin + emit (Pldrb(W, X16, ADpostincr(RR1 X30, _1))); + emit (Pstrb(X16, ADpostincr(RR1 X29, _1))) + end + +let expand_builtin_memcpy sz al args = + let (dst, src) = + match args with [d; s] -> (d, s) | _ -> assert false in + if sz < 64 + then expand_builtin_memcpy_small sz al src dst + else expand_builtin_memcpy_big sz al src dst + +(* Handling of volatile reads and writes *) + +let expand_builtin_vload_common chunk base ofs res = + let addr = ADimm(base, ofs) in + match chunk, res with + | Mint8unsigned, BR(IR res) -> + emit (Pldrb(W, res, addr)) + | Mint8signed, BR(IR res) -> + emit (Pldrsb(W, res, addr)) + | Mint16unsigned, BR(IR res) -> + emit (Pldrh(W, res, addr)) + | Mint16signed, BR(IR res) -> + emit (Pldrsh(W, res, addr)) + | Mint32, BR(IR res) -> + emit (Pldrw(res, addr)) + | Mint64, BR(IR res) -> + emit (Pldrx(res, addr)) + | Mfloat32, BR(FR res) -> + emit (Pldrs(res, addr)) + | Mfloat64, BR(FR res) -> + emit (Pldrd(res, addr)) + | _ -> + assert false + +let expand_builtin_vload chunk args res = + match args with + | [BA(IR addr)] -> + expand_builtin_vload_common chunk (RR1 addr) _0 res + | [BA_addrstack ofs] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vload_common chunk XSP ofs res + else begin + expand_addimm64 (RR1 X16) XSP ofs; (* X16 <- SP + ofs *) + expand_builtin_vload_common chunk (RR1 X16) _0 res + end + | [BA_addptr(BA(IR addr), BA_long ofs)] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vload_common chunk (RR1 addr) ofs res + else begin + expand_addimm64 (RR1 X16) (RR1 addr) ofs; (* X16 <- addr + ofs *) + expand_builtin_vload_common chunk (RR1 X16) _0 res + end + | _ -> + assert false + +let expand_builtin_vstore_common chunk base ofs src = + let addr = ADimm(base, ofs) in + match chunk, src with + | (Mint8signed | Mint8unsigned), BA(IR src) -> + emit (Pstrb(src, addr)) + | (Mint16signed | Mint16unsigned), BA(IR src) -> + emit (Pstrh(src, addr)) + | Mint32, BA(IR src) -> + emit (Pstrw(src, addr)) + | Mint64, BA(IR src) -> + emit (Pstrx(src, addr)) + | Mfloat32, BA(FR src) -> + emit (Pstrs(src, addr)) + | Mfloat64, BA(FR src) -> + emit (Pstrd(src, addr)) + | _ -> + assert false + +let expand_builtin_vstore chunk args = + match args with + | [BA(IR addr); src] -> + expand_builtin_vstore_common chunk (RR1 addr) _0 src + | [BA_addrstack ofs; src] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vstore_common chunk XSP ofs src + else begin + expand_addimm64 (RR1 X16) XSP ofs; (* X16 <- SP + ofs *) + expand_builtin_vstore_common chunk (RR1 X16) _0 src + end + | [BA_addptr(BA(IR addr), BA_long ofs); src] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vstore_common chunk (RR1 addr) ofs src + else begin + expand_addimm64 (RR1 X16) (RR1 addr) ofs; (* X16 <- addr + ofs *) + expand_builtin_vstore_common chunk (RR1 X16) _0 src + end + | _ -> + assert false + +(* Handling of compiler-inlined builtins *) + +let expand_builtin_inline name args res = + match name, args, res with + (* Synchronization *) + | "__builtin_membar", [], _ -> + () + | "__builtin_nop", [], _ -> + emit Pnop + (* Byte swap *) + | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> + emit (Prev(W, res, a1)) + | "__builtin_bswap64", [BA(IR a1)], BR(IR res) -> + emit (Prev(X, res, a1)) + | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + emit (Prev16(W, res, a1)); + emit (Pandimm(W, res, RR0 res, Z.of_uint 0xFFFF)) + (* Count leading zeros and leading sign bits *) + | "__builtin_clz", [BA(IR a1)], BR(IR res) -> + emit (Pclz(W, res, a1)) + | ("__builtin_clzl" | "__builtin_clzll"), [BA(IR a1)], BR(IR res) -> + emit (Pclz(X, res, a1)) + | "__builtin_cls", [BA(IR a1)], BR(IR res) -> + emit (Pcls(W, res, a1)) + | ("__builtin_clsl" | "__builtin_clsll"), [BA(IR a1)], BR(IR res) -> + emit (Pcls(X, res, a1)) + (* Float arithmetic *) + | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> + emit (Pfabs(D, res, a1)) + | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> + emit (Pfsqrt(D, res, a1)) + | "__builtin_fmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfmadd(D, res, a1, a2, a3)) + | "__builtin_fmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfmsub(D, res, a1, a2, a3)) + | "__builtin_fnmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfnmadd(D, res, a1, a2, a3)) + | "__builtin_fnmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfnmsub(D, res, a1, a2, a3)) + (* Vararg *) + | "__builtin_va_start", [BA(IR a)], _ -> + expand_builtin_va_start a + (* Catch-all *) + | _ -> + raise (Error ("unrecognized builtin " ^ name)) + +(* Expansion of instructions *) + +let expand_instruction instr = + match instr with + | Pallocframe (sz, ofs) -> + emit (Pmov (RR1 X29, XSP)); + if is_current_function_variadic() then begin + let (ir, fr, _) = + next_arg_locations 0 0 0 (get_current_function_args ()) in + save_parameter_registers ir fr; + current_function_stacksize := + Int64.(add (Z.to_int64 sz) (of_int size_save_register_area)) + end else begin + current_function_stacksize := Z.to_int64 sz + end; + expand_addimm64 XSP XSP (Ptrofs.repr (Z.neg sz)); + expand_storeptr X29 XSP ofs + | Pfreeframe (sz, ofs) -> + expand_addimm64 XSP XSP (coqint_of_camlint64 !current_function_stacksize) + | Pcvtx2w rd -> + (* no code generated, the upper 32 bits of rd will be ignored *) + () + | Pbuiltin (ef,args,res) -> + begin match ef with + | EF_builtin (name,sg) -> + expand_builtin_inline (camlstring_of_coqstring name) args res + | EF_vload chunk -> + expand_builtin_vload chunk args res + | EF_vstore chunk -> + expand_builtin_vstore chunk args + | EF_annot_val (kind,txt,targ) -> + expand_annot_val kind txt targ args res + | EF_memcpy(sz, al) -> + expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args + | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + emit instr + | _ -> + assert false + end + | _ -> + emit instr + +let int_reg_to_dwarf r = 0 (* TODO *) + +let float_reg_to_dwarf r = 0 (* TODO *) + +let preg_to_dwarf = function + | IR r -> int_reg_to_dwarf r + | FR r -> float_reg_to_dwarf r + | _ -> assert false + +let expand_function id fn = + try + set_current_function fn; + 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/aarch64/Asmgen.v b/aarch64/Asmgen.v new file mode 100644 index 00000000..1c0e41a1 --- /dev/null +++ b/aarch64/Asmgen.v @@ -0,0 +1,1151 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Translation from Mach to AArch64. *) + +Require Import Recdef Coqlib Zwf Zbits. +Require Import Errors AST Integers Floats Op. +Require Import Locations Mach Asm. + +Local Open Scope string_scope. +Local Open Scope list_scope. +Local Open Scope error_monad_scope. + +(** Extracting integer or float registers. *) + +Definition ireg_of (r: mreg) : res ireg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. + +Definition freg_of (r: mreg) : res freg := + match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end. + +(** Recognition of immediate arguments for logical integer operations.*) + +(** Valid immediate arguments are repetitions of a bit pattern [B] + of length [e] = 2, 4, 8, 16, 32 or 64. + The bit pattern [B] must be of the form [0*1*0*] or [1*0*1*] + but must not be all zeros or all ones. *) + +(** The following automaton recognizes [0*1*0*|1*0*1*]. +<< + 0 1 0 + / \ / \ / \ + \ / \ / \ / + -0--> [B] --1--> [D] --0--> [F] + / + [A] + \ + -1--> [C] --0--> [E] --1--> [G] + / \ / \ / \ + \ / \ / \ / + 1 0 1 +>> +*) + +Module Automaton. + +Inductive state : Type := SA | SB | SC | SD | SE | SF | SG | Sbad. + +Definition start := SA. + +Definition next (s: state) (b: bool) := + match s, b with + | SA,false => SB | SA,true => SC + | SB,false => SB | SB,true => SD + | SC,false => SE | SC,true => SC + | SD,false => SF | SD,true => SD + | SE,false => SE | SE,true => SG + | SF,false => SF | SF,true => Sbad + | SG,false => Sbad | SG,true => SG + | Sbad,_ => Sbad + end. + +Definition accepting (s: state) := + match s with + | SA | SB | SC | SD | SE | SF | SG => true + | Sbad => false + end. + +Fixpoint run (len: nat) (s: state) (x: Z) : bool := + match len with + | Datatypes.O => accepting s + | Datatypes.S len => run len (next s (Z.odd x)) (Z.div2 x) + end. + +End Automaton. + +(** The following function determines the candidate length [e], + ensuring that [x] is a repetition [BB...B] + of a bit pattern [B] of length [e]. *) + +Definition logical_imm_length (x: Z) (sixtyfour: bool) : nat := + (** [test n] checks that the low [2n] bits of [x] are of the + form [BB], that is, two occurrences of the same [n] bits *) + let test (n: Z) : bool := + Z.eqb (Zzero_ext n x) (Zzero_ext n (Z.shiftr x n)) in + (** If [test n] fails, we know that the candidate length [e] is + at least [2n]. Hence we test with decreasing values of [n]: + 32, 16, 8, 4, 2. *) + if sixtyfour && negb (test 32) then 64%nat + else if negb (test 16) then 32%nat + else if negb (test 8) then 16%nat + else if negb (test 4) then 8%nat + else if negb (test 2) then 4%nat + else 2%nat. + +(** A valid logical immediate is +- neither [0] nor [-1]; +- composed of a repetition [BBBBB] of a bit-pattern [B] of length [e] +- the low [e] bits of the number, that is, [B], match [0*1*0*] or [1*0*1*]. +*) + +Definition is_logical_imm32 (x: int) : bool := + negb (Int.eq x Int.zero) && negb (Int.eq x Int.mone) && + Automaton.run (logical_imm_length (Int.unsigned x) false) + Automaton.start (Int.unsigned x). + +Definition is_logical_imm64 (x: int64) : bool := + negb (Int64.eq x Int64.zero) && negb (Int64.eq x Int64.mone) && + Automaton.run (logical_imm_length (Int64.unsigned x) true) + Automaton.start (Int64.unsigned x). + +(** Arithmetic immediates are 12-bit unsigned numbers, possibly shifted left 12 bits *) + +Definition is_arith_imm32 (x: int) : bool := + Int.eq x (Int.zero_ext 12 x) + || Int.eq x (Int.shl (Int.zero_ext 12 (Int.shru x (Int.repr 12))) (Int.repr 12)). + +Definition is_arith_imm64 (x: int64) : bool := + Int64.eq x (Int64.zero_ext 12 x) + || Int64.eq x (Int64.shl (Int64.zero_ext 12 (Int64.shru x (Int64.repr 12))) (Int64.repr 12)). + +(** Decompose integer literals into 16-bit fragments *) + +Fixpoint decompose_int (N: nat) (n p: Z) {struct N} : list (Z * Z) := + match N with + | Datatypes.O => nil + | Datatypes.S N => + let frag := Zzero_ext 16 (Z.shiftr n p) in + if Z.eqb frag 0 then + decompose_int N n (p + 16) + else + (frag, p) :: decompose_int N (Z.ldiff n (Z.shiftl 65535 p)) (p + 16) + end. + +Definition negate_decomposition (l: list (Z * Z)) := + List.map (fun np => (Z.lxor (fst np) 65535, snd np)) l. + +Definition loadimm_k (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code := + List.fold_right (fun np k => Pmovk sz rd (fst np) (snd np) :: k) k l. + +Definition loadimm_z (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code := + match l with + | nil => Pmovz sz rd 0 0 :: k + | (n1, p1) :: l => Pmovz sz rd n1 p1 :: loadimm_k sz rd l k + end. + +Definition loadimm_n (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code := + match l with + | nil => Pmovn sz rd 0 0 :: k + | (n1, p1) :: l => Pmovn sz rd n1 p1 :: loadimm_k sz rd (negate_decomposition l) k + end. + +Definition loadimm (sz: isize) (rd: ireg) (n: Z) (k: code) : code := + let N := match sz with W => 2%nat | X => 4%nat end in + let dz := decompose_int N n 0 in + let dn := decompose_int N (Z.lnot n) 0 in + if Nat.leb (List.length dz) (List.length dn) + then loadimm_z sz rd dz k + else loadimm_n sz rd dn k. + +Definition loadimm32 (rd: ireg) (n: int) (k: code) : code := + if is_logical_imm32 n + then Porrimm W rd XZR (Int.unsigned n) :: k + else loadimm W rd (Int.unsigned n) k. + +Definition loadimm64 (rd: ireg) (n: int64) (k: code) : code := + if is_logical_imm64 n + then Porrimm X rd XZR (Int64.unsigned n) :: k + else loadimm X rd (Int64.unsigned n) k. + +(** Add immediate *) + +Definition addimm_aux (insn: iregsp -> iregsp -> Z -> instruction) + (rd r1: iregsp) (n: Z) (k: code) := + let nlo := Zzero_ext 12 n in + let nhi := n - nlo in + if Z.eqb nhi 0 then + insn rd r1 nlo :: k + else if Z.eqb nlo 0 then + insn rd r1 nhi :: k + else + insn rd r1 nhi :: insn rd rd nlo :: k. + +Definition addimm32 (rd r1: ireg) (n: int) (k: code) : code := + let m := Int.neg n in + if Int.eq n (Int.zero_ext 24 n) then + addimm_aux (Paddimm W) rd r1 (Int.unsigned n) k + else if Int.eq m (Int.zero_ext 24 m) then + addimm_aux (Psubimm W) rd r1 (Int.unsigned m) k + else if Int.lt n Int.zero then + loadimm32 X16 m (Psub W rd r1 X16 SOnone :: k) + else + loadimm32 X16 n (Padd W rd r1 X16 SOnone :: k). + +Definition addimm64 (rd r1: iregsp) (n: int64) (k: code) : code := + let m := Int64.neg n in + if Int64.eq n (Int64.zero_ext 24 n) then + addimm_aux (Paddimm X) rd r1 (Int64.unsigned n) k + else if Int64.eq m (Int64.zero_ext 24 m) then + addimm_aux (Psubimm X) rd r1 (Int64.unsigned m) k + else if Int64.lt n Int64.zero then + loadimm64 X16 m (Psubext rd r1 X16 (EOuxtx Int.zero) :: k) + else + loadimm64 X16 n (Paddext rd r1 X16 (EOuxtx Int.zero) :: k). + +(** Logical immediate *) + +Definition logicalimm32 + (insn1: ireg -> ireg0 -> Z -> instruction) + (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) + (rd r1: ireg) (n: int) (k: code) : code := + if is_logical_imm32 n + then insn1 rd r1 (Int.unsigned n) :: k + else loadimm32 X16 n (insn2 rd r1 X16 SOnone :: k). + +Definition logicalimm64 + (insn1: ireg -> ireg0 -> Z -> instruction) + (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) + (rd r1: ireg) (n: int64) (k: code) : code := + if is_logical_imm64 n + then insn1 rd r1 (Int64.unsigned n) :: k + else loadimm64 X16 n (insn2 rd r1 X16 SOnone :: k). + +(** Sign- or zero-extended arithmetic *) + +Definition transl_extension (ex: extension) (a: int) : extend_op := + match ex with Xsgn32 => EOsxtw a | Xuns32 => EOuxtw a end. + +Definition move_extended_base + (rd: ireg) (r1: ireg) (ex: extension) (k: code) : code := + match ex with + | Xsgn32 => Pcvtsw2x rd r1 :: k + | Xuns32 => Pcvtuw2x rd r1 :: k + end. + +Definition move_extended + (rd: ireg) (r1: ireg) (ex: extension) (a: int) (k: code) : code := + if Int.eq a Int.zero then + move_extended_base rd r1 ex k + else + move_extended_base rd r1 ex (Padd X rd XZR rd (SOlsl a) :: k). + +Definition arith_extended + (insnX: iregsp -> iregsp -> ireg -> extend_op -> instruction) + (insnS: ireg -> ireg0 -> ireg -> shift_op -> instruction) + (rd r1 r2: ireg) (ex: extension) (a: int) (k: code) : code := + if Int.ltu a (Int.repr 5) then + insnX rd r1 r2 (transl_extension ex a) :: k + else + move_extended_base X16 r2 ex (insnS rd r1 X16 (SOlsl a) :: k). + +(** Extended right shift *) + +Definition shrx32 (rd r1: ireg) (n: int) (k: code) : code := + if Int.eq n Int.zero then + Pmov rd r1 :: k + else + Porr W X16 XZR r1 (SOasr (Int.repr 31)) :: + Padd W X16 r1 X16 (SOlsr (Int.sub Int.iwordsize n)) :: + Porr W rd XZR X16 (SOasr n) :: k. + +Definition shrx64 (rd r1: ireg) (n: int) (k: code) : code := + if Int.eq n Int.zero then + Pmov rd r1 :: k + else + Porr X X16 XZR r1 (SOasr (Int.repr 63)) :: + Padd X X16 r1 X16 (SOlsr (Int.sub Int64.iwordsize' n)) :: + Porr X rd XZR X16 (SOasr n) :: k. + +(** Load the address [id + ofs] in [rd] *) + +Definition loadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (k: code) : code := + if Archi.pic_code tt then + if Ptrofs.eq ofs Ptrofs.zero then + Ploadsymbol rd id :: k + else + Ploadsymbol rd id :: addimm64 rd rd (Ptrofs.to_int64 ofs) k + else + Padrp rd id ofs :: Paddadr rd rd id ofs :: k. + +(** Translate a shifted operand *) + +Definition transl_shift (s: Op.shift) (a: int): Asm.shift_op := + match s with + | Slsl => SOlsl a + | Slsr => SOlsr a + | Sasr => SOasr a + | Sror => SOror a + end. + +(** Translation of a condition. Prepends to [k] the instructions + that evaluate the condition and leave its boolean result in one of + the bits of the condition register. The bit in question is + determined by the [crbit_for_cond] function. *) + +Definition transl_cond + (cond: condition) (args: list mreg) (k: code) := + match cond, args with + | (Ccomp c | Ccompu c), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp W r1 r2 SOnone :: k) + | (Ccompshift c s a | Ccompushift c s a), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp W r1 r2 (transl_shift s a) :: k) + | (Ccompimm c n | Ccompuimm c n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_arith_imm32 n then + Pcmpimm W r1 (Int.unsigned n) :: k + else if is_arith_imm32 (Int.neg n) then + Pcmnimm W r1 (Int.unsigned (Int.neg n)) :: k + else + loadimm32 X16 n (Pcmp W r1 X16 SOnone :: k)) + | (Cmaskzero n | Cmasknotzero n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_logical_imm32 n then + Ptstimm W r1 (Int.unsigned n) :: k + else + loadimm32 X16 n (Ptst W r1 X16 SOnone :: k)) + | (Ccompl c | Ccomplu c), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp X r1 r2 SOnone :: k) + | (Ccomplshift c s a | Ccomplushift c s a), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp X r1 r2 (transl_shift s a) :: k) + | (Ccomplimm c n | Ccompluimm c n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_arith_imm64 n then + Pcmpimm X r1 (Int64.unsigned n) :: k + else if is_arith_imm64 (Int64.neg n) then + Pcmnimm X r1 (Int64.unsigned (Int64.neg n)) :: k + else + loadimm64 X16 n (Pcmp X r1 X16 SOnone :: k)) + | (Cmasklzero n | Cmasklnotzero n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_logical_imm64 n then + Ptstimm X r1 (Int64.unsigned n) :: k + else + loadimm64 X16 n (Ptst X r1 X16 SOnone :: k)) + | Ccompf cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp D r1 r2 :: k) + | Cnotcompf cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp D r1 r2 :: k) + | Ccompfzero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 D r1 :: k) + | Cnotcompfzero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 D r1 :: k) + | Ccompfs cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp S r1 r2 :: k) + | Cnotcompfs cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp S r1 r2 :: k) + | Ccompfszero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 S r1 :: k) + | Cnotcompfszero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 S r1 :: k) + | _, _ => + Error(msg "Asmgen.transl_cond") + end. + +Definition cond_for_signed_cmp (cmp: comparison) := + match cmp with + | Ceq => TCeq + | Cne => TCne + | Clt => TClt + | Cle => TCle + | Cgt => TCgt + | Cge => TCge + end. + +Definition cond_for_unsigned_cmp (cmp: comparison) := + match cmp with + | Ceq => TCeq + | Cne => TCne + | Clt => TClo + | Cle => TCls + | Cgt => TChi + | Cge => TChs + end. + +Definition cond_for_float_cmp (cmp: comparison) := + match cmp with + | Ceq => TCeq + | Cne => TCne + | Clt => TCmi + | Cle => TCls + | Cgt => TCgt + | Cge => TCge + end. + +Definition cond_for_float_not_cmp (cmp: comparison) := + match cmp with + | Ceq => TCne + | Cne => TCeq + | Clt => TCpl + | Cle => TChi + | Cgt => TCle + | Cge => TClt + end. + +Definition cond_for_cond (cond: condition) := + match cond with + | Ccomp cmp => cond_for_signed_cmp cmp + | Ccompu cmp => cond_for_unsigned_cmp cmp + | Ccompshift cmp s a => cond_for_signed_cmp cmp + | Ccompushift cmp s a => cond_for_unsigned_cmp cmp + | Ccompimm cmp n => cond_for_signed_cmp cmp + | Ccompuimm cmp n => cond_for_unsigned_cmp cmp + | Cmaskzero n => TCeq + | Cmasknotzero n => TCne + | Ccompl cmp => cond_for_signed_cmp cmp + | Ccomplu cmp => cond_for_unsigned_cmp cmp + | Ccomplshift cmp s a => cond_for_signed_cmp cmp + | Ccomplushift cmp s a => cond_for_unsigned_cmp cmp + | Ccomplimm cmp n => cond_for_signed_cmp cmp + | Ccompluimm cmp n => cond_for_unsigned_cmp cmp + | Cmasklzero n => TCeq + | Cmasklnotzero n => TCne + | Ccompf cmp => cond_for_float_cmp cmp + | Cnotcompf cmp => cond_for_float_not_cmp cmp + | Ccompfzero cmp => cond_for_float_cmp cmp + | Cnotcompfzero cmp => cond_for_float_not_cmp cmp + | Ccompfs cmp => cond_for_float_cmp cmp + | Cnotcompfs cmp => cond_for_float_not_cmp cmp + | Ccompfszero cmp => cond_for_float_cmp cmp + | Cnotcompfszero cmp => cond_for_float_not_cmp cmp + end. + +(** Translation of a conditional branch. Prepends to [k] the instructions + that evaluate the condition and ranch to [lbl] if it holds. + We recognize some conditional branches that can be implemented + without setting then testing condition flags. *) + +Definition transl_cond_branch_default + (c: condition) (args: list mreg) (lbl: label) (k: code) := + transl_cond c args (Pbc (cond_for_cond c) lbl :: k). + +Definition transl_cond_branch + (c: condition) (args: list mreg) (lbl: label) (k: code) := + match args, c with + | a1 :: nil, (Ccompimm Cne n | Ccompuimm Cne n) => + if Int.eq n Int.zero + then (do r1 <- ireg_of a1; OK (Pcbnz W r1 lbl :: k)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, (Ccompimm Ceq n | Ccompuimm Ceq n) => + if Int.eq n Int.zero + then (do r1 <- ireg_of a1; OK (Pcbz W r1 lbl :: k)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, (Ccomplimm Cne n | Ccompluimm Cne n) => + if Int64.eq n Int64.zero + then (do r1 <- ireg_of a1; OK (Pcbnz X r1 lbl :: k)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, (Ccomplimm Ceq n | Ccompluimm Ceq n) => + if Int64.eq n Int64.zero + then (do r1 <- ireg_of a1; OK (Pcbz X r1 lbl :: k)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, Cmaskzero n => + match Int.is_power2 n with + | Some bit => do r1 <- ireg_of a1; OK (Ptbz W r1 bit lbl :: k) + | None => transl_cond_branch_default c args lbl k + end + | a1 :: nil, Cmasknotzero n => + match Int.is_power2 n with + | Some bit => do r1 <- ireg_of a1; OK (Ptbnz W r1 bit lbl :: k) + | None => transl_cond_branch_default c args lbl k + end + | a1 :: nil, Cmasklzero n => + match Int64.is_power2' n with + | Some bit => do r1 <- ireg_of a1; OK (Ptbz X r1 bit lbl :: k) + | None => transl_cond_branch_default c args lbl k + end + | a1 :: nil, Cmasklnotzero n => + match Int64.is_power2' n with + | Some bit => do r1 <- ireg_of a1; OK (Ptbnz X r1 bit lbl :: k) + | None => transl_cond_branch_default c args lbl k + end + | _, _ => + transl_cond_branch_default c args lbl k + end. + +(** Translation of the arithmetic operation [res <- op(args)]. + The corresponding instructions are prepended to [k]. *) + +Definition transl_op + (op: operation) (args: list mreg) (res: mreg) (k: code) := + match op, args with + | Omove, a1 :: nil => + match preg_of res, preg_of a1 with + | IR r, IR a => OK (Pmov r a :: k) + | FR r, FR a => OK (Pfmov r a :: k) + | _ , _ => Error(msg "Asmgen.Omove") + end + | Ointconst n, nil => + do rd <- ireg_of res; + OK (loadimm32 rd n k) + | Olongconst n, nil => + do rd <- ireg_of res; + OK (loadimm64 rd n k) + | Ofloatconst f, nil => + do rd <- freg_of res; + OK (if Float.eq_dec f Float.zero + then Pfmovi D rd XZR :: k + else Pfmovimmd rd f :: k) + | Osingleconst f, nil => + do rd <- freg_of res; + OK (if Float32.eq_dec f Float32.zero + then Pfmovi S rd XZR :: k + else Pfmovimms rd f :: k) + | Oaddrsymbol id ofs, nil => + do rd <- ireg_of res; + OK (loadsymbol rd id ofs k) + | Oaddrstack ofs, nil => + do rd <- ireg_of res; + OK (addimm64 rd XSP (Ptrofs.to_int64 ofs) k) +(** 32-bit integer arithmetic *) + | Oshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porr W rd XZR r1 (transl_shift s a) :: k) + | Oadd, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd W rd r1 r2 SOnone :: k) + | Oaddshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd W rd r1 r2 (transl_shift s a) :: k) + | Oaddimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (addimm32 rd r1 n k) + | Oneg, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub W rd XZR r1 SOnone :: k) + | Onegshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub W rd XZR r1 (transl_shift s a) :: k) + | Osub, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub W rd r1 r2 SOnone :: k) + | Osubshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub W rd r1 r2 (transl_shift s a) :: k) + | Omul, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pmadd W rd r1 r2 XZR :: k) + | Omuladd, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmadd W rd r2 r3 r1 :: k) + | Omulsub, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmsub W rd r2 r3 r1 :: k) + | Odiv, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psdiv W rd r1 r2 :: k) + | Odivu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pudiv W rd r1 r2 :: k) + | Oand, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand W rd r1 r2 SOnone :: k) + | Oandshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand W rd r1 r2 (transl_shift s a) :: k) + | Oandimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm32 (Pandimm W) (Pand W) rd r1 n k) + | Oor, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr W rd r1 r2 SOnone :: k) + | Oorshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr W rd r1 r2 (transl_shift s a) :: k) + | Oorimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm32 (Porrimm W) (Porr W) rd r1 n k) + | Oxor, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor W rd r1 r2 SOnone :: k) + | Oxorshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor W rd r1 r2 (transl_shift s a) :: k) + | Oxorimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm32 (Peorimm W) (Peor W) rd r1 n k) + | Onot, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn W rd XZR r1 SOnone :: k) + | Onotshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn W rd XZR r1 (transl_shift s a) :: k) + | Obic, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic W rd r1 r2 SOnone :: k) + | Obicshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic W rd r1 r2 (transl_shift s a) :: k) + | Oorn, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn W rd r1 r2 SOnone :: k) + | Oornshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn W rd r1 r2 (transl_shift s a) :: k) + | Oeqv, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon W rd r1 r2 SOnone :: k) + | Oeqvshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon W rd r1 r2 (transl_shift s a) :: k) + | Oshl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plslv W rd r1 r2 :: k) + | Oshr, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pasrv W rd r1 r2 :: k) + | Oshru, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plsrv W rd r1 r2 :: k) + | Oshrximm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (shrx32 rd r1 n k) + | Ozext s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz W rd r1 Int.zero s :: k) + | Osext s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz W rd r1 Int.zero s :: k) + | Oshlzext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) + | Oshlsext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) + | Ozextshr a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) + | Osextshr a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) +(** 64-bit integer arithmetic *) + | Oshiftl s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porr X rd XZR r1 (transl_shift s a) :: k) + | Oextend x a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (move_extended rd r1 x a k) + (* [Omakelong] and [Ohighlong] should not occur *) + | Olowlong, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + assertion (ireg_eq rd r1); + OK (Pcvtx2w rd :: k) + | Oaddl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd X rd r1 r2 SOnone :: k) + | Oaddlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd X rd r1 r2 (transl_shift s a) :: k) + | Oaddlext x a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (arith_extended Paddext (Padd X) rd r1 r2 x a k) + | Oaddlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (addimm64 rd r1 n k) + | Onegl, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub X rd XZR r1 SOnone :: k) + | Oneglshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub X rd XZR r1 (transl_shift s a) :: k) + | Osubl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub X rd r1 r2 SOnone :: k) + | Osublshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub X rd r1 r2 (transl_shift s a) :: k) + | Osublext x a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (arith_extended Psubext (Psub X) rd r1 r2 x a k) + | Omull, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pmadd X rd r1 r2 XZR :: k) + | Omulladd, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmadd X rd r2 r3 r1 :: k) + | Omullsub, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmsub X rd r2 r3 r1 :: k) + | Omullhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psmulh rd r1 r2 :: k) + | Omullhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pumulh rd r1 r2 :: k) + | Odivl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psdiv X rd r1 r2 :: k) + | Odivlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pudiv X rd r1 r2 :: k) + | Oandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand X rd r1 r2 SOnone :: k) + | Oandlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand X rd r1 r2 (transl_shift s a) :: k) + | Oandlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm64 (Pandimm X) (Pand X) rd r1 n k) + | Oorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr X rd r1 r2 SOnone :: k) + | Oorlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr X rd r1 r2 (transl_shift s a) :: k) + | Oorlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm64 (Porrimm X) (Porr X) rd r1 n k) + | Oxorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor X rd r1 r2 SOnone :: k) + | Oxorlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor X rd r1 r2 (transl_shift s a) :: k) + | Oxorlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm64 (Peorimm X) (Peor X) rd r1 n k) + | Onotl, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn X rd XZR r1 SOnone :: k) + | Onotlshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn X rd XZR r1 (transl_shift s a) :: k) + | Obicl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic X rd r1 r2 SOnone :: k) + | Obiclshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic X rd r1 r2 (transl_shift s a) :: k) + | Oornl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn X rd r1 r2 SOnone :: k) + | Oornlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn X rd r1 r2 (transl_shift s a) :: k) + | Oeqvl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon X rd r1 r2 SOnone :: k) + | Oeqvlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon X rd r1 r2 (transl_shift s a) :: k) + | Oshll, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plslv X rd r1 r2 :: k) + | Oshrl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pasrv X rd r1 r2 :: k) + | Oshrlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plsrv X rd r1 r2 :: k) + | Oshrlximm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (shrx64 rd r1 n k) + | Ozextl s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz X rd r1 Int.zero s :: k) + | Osextl s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz X rd r1 Int.zero s :: k) + | Oshllzext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) + | Oshllsext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) + | Ozextshrl a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) + | Osextshrl a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) +(** 64-bit floating-point arithmetic *) + | Onegf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfneg D rd rs :: k) + | Oabsf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabs D rd rs :: k) + | Oaddf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfadd D rd rs1 rs2 :: k) + | Osubf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsub D rd rs1 rs2 :: k) + | Omulf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmul D rd rs1 rs2 :: k) + | Odivf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdiv D rd rs1 rs2 :: k) +(** 32-bit floating-point arithmetic *) + | Onegfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfneg S rd rs :: k) + | Oabsfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabs S rd rs :: k) + | Oaddfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfadd S rd rs1 rs2 :: k) + | Osubfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsub S rd rs1 rs2 :: k) + | Omulfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmul S rd rs1 rs2 :: k) + | Odivfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdiv S rd rs1 rs2 :: k) + | Osingleoffloat, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtsd rd rs :: k) + | Ofloatofsingle, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtds rd rs :: k) +(** Conversions between int and float *) + | Ointoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs W D rd rs :: k) + | Ointuoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu W D rd rs :: k) + | Ofloatofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf D W rd rs :: k) + | Ofloatofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf D W rd rs :: k) + | Ointofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs W S rd rs :: k) + | Ointuofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu W S rd rs :: k) + | Osingleofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf S W rd rs :: k) + | Osingleofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf S W rd rs :: k) + | Olongoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs X D rd rs :: k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu X D rd rs :: k) + | Ofloatoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf D X rd rs :: k) + | Ofloatoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf D X rd rs :: k) + | Olongofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs X S rd rs :: k) + | Olonguofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu X S rd rs :: k) + | Osingleoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf S X rd rs :: k) + | Osingleoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf S X rd rs :: k) +(** Boolean tests *) + | Ocmp c, _ => + do rd <- ireg_of res; + transl_cond c args (Pcset rd (cond_for_cond c) :: k) +(** Conditional move *) + | Osel cmp ty, a1 :: a2 :: args => + match preg_of res with + | IR r => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + transl_cond cmp args (Pcsel r r1 r2 (cond_for_cond cmp) :: k) + | FR r => + do r1 <- freg_of a1; do r2 <- freg_of a2; + transl_cond cmp args (Pfsel r r1 r2 (cond_for_cond cmp) :: k) + | _ => + Error(msg "Asmgen.Osel") + end + | _, _ => + Error(msg "Asmgen.transl_op") + end. + +(** Translation of addressing modes *) + +Definition offset_representable (sz: Z) (ofs: int64) : bool := + let isz := Int64.repr sz in + (** either unscaled 9-bit signed *) + Int64.eq ofs (Int64.sign_ext 9 ofs) || + (** or scaled 12-bit unsigned *) + (Int64.eq (Int64.modu ofs isz) Int64.zero + && Int64.ltu ofs (Int64.shl isz (Int64.repr 12))). + +Definition transl_addressing (sz: Z) (addr: Op.addressing) (args: list mreg) + (insn: Asm.addressing -> instruction) (k: code) : res code := + match addr, args with + | Aindexed ofs, a1 :: nil => + do r1 <- ireg_of a1; + if offset_representable sz ofs then + OK (insn (ADimm r1 ofs) :: k) + else + OK (loadimm64 X16 ofs (insn (ADreg r1 X16) :: k)) + | Aindexed2, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (insn (ADreg r1 r2) :: k) + | Aindexed2shift a, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + if Int.eq a Int.zero then + OK (insn (ADreg r1 r2) :: k) + else if Int.eq (Int.shl Int.one a) (Int.repr sz) then + OK (insn (ADlsl r1 r2 a) :: k) + else + OK (Padd X X16 r1 r2 (SOlsl a) :: insn (ADimm X16 Int64.zero) :: k) + | Aindexed2ext x a, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + if Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz) then + OK (insn (match x with Xsgn32 => ADsxt r1 r2 a + | Xuns32 => ADuxt r1 r2 a end) :: k) + else + OK (arith_extended Paddext (Padd X) X16 r1 r2 x a + (insn (ADimm X16 Int64.zero) :: k)) + | Aglobal id ofs, nil => + assertion (negb (Archi.pic_code tt)); + if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero + then OK (Padrp X16 id ofs :: insn (ADadr X16 id ofs) :: k) + else OK (loadsymbol X16 id ofs (insn (ADimm X16 Int64.zero) :: k)) + | Ainstack ofs, nil => + let ofs := Ptrofs.to_int64 ofs in + if offset_representable sz ofs then + OK (insn (ADimm XSP ofs) :: k) + else + OK (loadimm64 X16 ofs (insn (ADreg XSP X16) :: k)) + | _, _ => + Error(msg "Asmgen.transl_addressing") + end. + +(** Translation of loads and stores *) + +Definition transl_load (chunk: memory_chunk) (addr: Op.addressing) + (args: list mreg) (dst: mreg) (k: code) : res code := + match chunk with + | Mint8unsigned => + do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrb W rd) k + | Mint8signed => + do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrsb W rd) k + | Mint16unsigned => + do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrh W rd) k + | Mint16signed => + do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrsh W rd) k + | Mint32 => + do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw rd) k + | Mint64 => + do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx rd) k + | Mfloat32 => + do rd <- freg_of dst; transl_addressing 4 addr args (Pldrs rd) k + | Mfloat64 => + do rd <- freg_of dst; transl_addressing 8 addr args (Pldrd rd) k + | Many32 => + do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw_a rd) k + | Many64 => + do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx_a rd) k + end. + +Definition transl_store (chunk: memory_chunk) (addr: Op.addressing) + (args: list mreg) (src: mreg) (k: code) : res code := + match chunk with + | Mint8unsigned | Mint8signed => + do r1 <- ireg_of src; transl_addressing 1 addr args (Pstrb r1) k + | Mint16unsigned | Mint16signed => + do r1 <- ireg_of src; transl_addressing 2 addr args (Pstrh r1) k + | Mint32 => + do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw r1) k + | Mint64 => + do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx r1) k + | Mfloat32 => + do r1 <- freg_of src; transl_addressing 4 addr args (Pstrs r1) k + | Mfloat64 => + do r1 <- freg_of src; transl_addressing 8 addr args (Pstrd r1) k + | Many32 => + do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw_a r1) k + | Many64 => + do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx_a r1) k + end. + +(** Register-indexed loads and stores *) + +Definition indexed_memory_access (insn: Asm.addressing -> instruction) + (sz: Z) (base: iregsp) (ofs: ptrofs) (k: code) := + let ofs := Ptrofs.to_int64 ofs in + if offset_representable sz ofs + then insn (ADimm base ofs) :: k + else loadimm64 X16 ofs (insn (ADreg base X16) :: k). + +Definition loadind (base: iregsp) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := + match ty, preg_of dst with + | Tint, IR rd => OK (indexed_memory_access (Pldrw rd) 4 base ofs k) + | Tlong, IR rd => OK (indexed_memory_access (Pldrx rd) 8 base ofs k) + | Tsingle, FR rd => OK (indexed_memory_access (Pldrs rd) 4 base ofs k) + | Tfloat, FR rd => OK (indexed_memory_access (Pldrd rd) 8 base ofs k) + | Tany32, IR rd => OK (indexed_memory_access (Pldrw_a rd) 4 base ofs k) + | Tany64, IR rd => OK (indexed_memory_access (Pldrx_a rd) 8 base ofs k) + | Tany64, FR rd => OK (indexed_memory_access (Pldrd_a rd) 8 base ofs k) + | _, _ => Error (msg "Asmgen.loadind") + end. + +Definition storeind (src: mreg) (base: iregsp) (ofs: ptrofs) (ty: typ) (k: code) := + match ty, preg_of src with + | Tint, IR rd => OK (indexed_memory_access (Pstrw rd) 4 base ofs k) + | Tlong, IR rd => OK (indexed_memory_access (Pstrx rd) 8 base ofs k) + | Tsingle, FR rd => OK (indexed_memory_access (Pstrs rd) 4 base ofs k) + | Tfloat, FR rd => OK (indexed_memory_access (Pstrd rd) 8 base ofs k) + | Tany32, IR rd => OK (indexed_memory_access (Pstrw_a rd) 4 base ofs k) + | Tany64, IR rd => OK (indexed_memory_access (Pstrx_a rd) 8 base ofs k) + | Tany64, FR rd => OK (indexed_memory_access (Pstrd_a rd) 8 base ofs k) + | _, _ => Error (msg "Asmgen.storeind") + end. + +Definition loadptr (base: iregsp) (ofs: ptrofs) (dst: ireg) (k: code) := + indexed_memory_access (Pldrx dst) 8 base ofs k. + +Definition storeptr (src: ireg) (base: iregsp) (ofs: ptrofs) (k: code) := + indexed_memory_access (Pstrx src) 8 base ofs k. + +(** Function epilogue *) + +Definition make_epilogue (f: Mach.function) (k: code) := + loadptr XSP f.(fn_retaddr_ofs) RA + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). + +(** Translation of a Mach instruction. *) + +Definition transl_instr (f: Mach.function) (i: Mach.instruction) + (r29_is_parent: bool) (k: code) : res code := + match i with + | Mgetstack ofs ty dst => + loadind XSP ofs ty dst k + | Msetstack src ofs ty => + storeind src XSP ofs ty k + | Mgetparam ofs ty dst => + (* load via the frame pointer if it is valid *) + do c <- loadind X29 ofs ty dst k; + OK (if r29_is_parent then c else loadptr XSP f.(fn_link_ofs) X29 c) + | Mop op args res => + transl_op op args res k + | Mload chunk addr args dst => + transl_load chunk addr args dst k + | Mstore chunk addr args src => + transl_store chunk addr args src k + | Mcall sig (inl r) => + do r1 <- ireg_of r; OK (Pblr r1 sig :: k) + | Mcall sig (inr symb) => + OK (Pbl symb sig :: k) + | Mtailcall sig (inl r) => + do r1 <- ireg_of r; + OK (make_epilogue f (Pbr r1 sig :: k)) + | Mtailcall sig (inr symb) => + OK (make_epilogue f (Pbs symb sig :: k)) + | Mbuiltin ef args res => + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) + | Mlabel lbl => + OK (Plabel lbl :: k) + | Mgoto lbl => + OK (Pb lbl :: k) + | Mcond cond args lbl => + transl_cond_branch cond args lbl k + | Mjumptable arg tbl => + do r <- ireg_of arg; + OK (Pbtbl r tbl :: k) + | Mreturn => + OK (make_epilogue f (Pret RA :: k)) + end. + +(** Translation of a code sequence *) + +Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := + match i with + | Msetstack src ofs ty => before + | Mgetparam ofs ty dst => negb (mreg_eq dst R29) + | Mop op args res => before && negb (mreg_eq res R29) + | _ => false + end. + +(** This is the naive definition that we no longer use because it + is not tail-recursive. It is kept as specification. *) + +Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := + match il with + | nil => OK nil + | i1 :: il' => + do k <- transl_code f il' (it1_is_parent it1p i1); + transl_instr f i1 it1p k + end. + +(** This is an equivalent definition in continuation-passing style + that runs in constant stack space. *) + +Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction) + (it1p: bool) (k: code -> res code) := + match il with + | nil => k nil + | i1 :: il' => + transl_code_rec f il' (it1_is_parent it1p i1) + (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2) + end. + +Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := + transl_code_rec f il it1p (fun c => OK c). + +(** Translation of a whole function. Note that we must check + that the generated code contains less than [2^32] instructions, + otherwise the offset part of the [PC] code pointer could wrap + around, leading to incorrect executions. *) + +Definition transl_function (f: Mach.function) := + do c <- transl_code' f f.(Mach.fn_code) true; + OK (mkfunction f.(Mach.fn_sig) + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: + storeptr RA XSP f.(fn_retaddr_ofs) c)). + +Definition transf_function (f: Mach.function) : res Asm.function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Mach.program) : res Asm.program := + transform_partial_program transf_fundef p. diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v new file mode 100644 index 00000000..eeff1956 --- /dev/null +++ b/aarch64/Asmgenproof.v @@ -0,0 +1,1026 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for AArch64 code generation. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Mach Conventions Asm. +Require Import Asmgen Asmgenproof0 Asmgenproof1. + +Definition match_prog (p: Mach.program) (tp: Asm.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: Asm.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +(** * Properties of control flow *) + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + omega. +Qed. + +Lemma exec_straight_exec: + forall fb f c ep tf tc c' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + exec_straight tge tf tc rs m c' rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + intros. inv H. + eapply exec_straight_steps_1; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. +Qed. + +Lemma exec_straight_at: + forall fb f c ep tf tc c' ep' tc' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + transl_code f c' ep' = OK tc' -> + exec_straight tge tf tc rs m tc' rs' m' -> + transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. +Proof. + intros. inv H. + exploit exec_straight_steps_2; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs' [PC' CT']]. + rewrite PC'. constructor; auto. +Qed. + +(** The following lemmas show that the translation from Mach to Asm + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ Asm instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- Asm instr seq tail + translation +>> + The proof demands many boring lemmas showing that Asm constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +Remark loadimm_z_label: forall sz rd l k, tail_nolabel k (loadimm_z sz rd l k). +Proof. + intros; destruct l as [ | [n1 p1] l]; simpl; TailNoLabel. + induction l as [ | [n p] l]; simpl; TailNoLabel. +Qed. + +Remark loadimm_n_label: forall sz rd l k, tail_nolabel k (loadimm_n sz rd l k). +Proof. + intros; destruct l as [ | [n1 p1] l]; simpl; TailNoLabel. + induction l as [ | [n p] l]; simpl; TailNoLabel. +Qed. + +Remark loadimm_label: forall sz rd n k, tail_nolabel k (loadimm sz rd n k). +Proof. + unfold loadimm; intros. destruct Nat.leb; [apply loadimm_z_label|apply loadimm_n_label]. +Qed. +Hint Resolve loadimm_label: labels. + +Remark loadimm32_label: forall r n k, tail_nolabel k (loadimm32 r n k). +Proof. + unfold loadimm32; intros. destruct (is_logical_imm32 n); TailNoLabel. +Qed. +Hint Resolve loadimm32_label: labels. + +Remark loadimm64_label: forall r n k, tail_nolabel k (loadimm64 r n k). +Proof. + unfold loadimm64; intros. destruct (is_logical_imm64 n); TailNoLabel. +Qed. +Hint Resolve loadimm64_label: labels. + +Remark addimm_aux: forall insn rd r1 n k, + (forall rd r1 n, nolabel (insn rd r1 n)) -> + tail_nolabel k (addimm_aux insn rd r1 n k). +Proof. + unfold addimm_aux; intros. + destruct Z.eqb. TailNoLabel. destruct Z.eqb; TailNoLabel. +Qed. + +Remark addimm32_label: forall rd r1 n k, tail_nolabel k (addimm32 rd r1 n k). +Proof. + unfold addimm32; intros. + destruct Int.eq. apply addimm_aux; intros; red; auto. + destruct Int.eq. apply addimm_aux; intros; red; auto. + destruct Int.lt; eapply tail_nolabel_trans; TailNoLabel. +Qed. +Hint Resolve addimm32_label: labels. + +Remark addimm64_label: forall rd r1 n k, tail_nolabel k (addimm64 rd r1 n k). +Proof. + unfold addimm64; intros. + destruct Int64.eq. apply addimm_aux; intros; red; auto. + destruct Int64.eq. apply addimm_aux; intros; red; auto. + destruct Int64.lt; eapply tail_nolabel_trans; TailNoLabel. +Qed. +Hint Resolve addimm64_label: labels. + +Remark logicalimm32_label: forall insn1 insn2 rd r1 n k, + (forall rd r1 n, nolabel (insn1 rd r1 n)) -> + (forall rd r1 r2 s, nolabel (insn2 rd r1 r2 s)) -> + tail_nolabel k (logicalimm32 insn1 insn2 rd r1 n k). +Proof. + unfold logicalimm32; intros. + destruct (is_logical_imm32 n). TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +Qed. + +Remark logicalimm64_label: forall insn1 insn2 rd r1 n k, + (forall rd r1 n, nolabel (insn1 rd r1 n)) -> + (forall rd r1 r2 s, nolabel (insn2 rd r1 r2 s)) -> + tail_nolabel k (logicalimm64 insn1 insn2 rd r1 n k). +Proof. + unfold logicalimm64; intros. + destruct (is_logical_imm64 n). TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +Qed. + +Remark move_extended_label: forall rd r1 ex a k, tail_nolabel k (move_extended rd r1 ex a k). +Proof. + unfold move_extended, move_extended_base; intros. destruct Int.eq, ex; TailNoLabel. +Qed. +Hint Resolve move_extended_label: labels. + +Remark arith_extended_label: forall insnX insnS rd r1 r2 ex a k, + (forall rd r1 r2 x, nolabel (insnX rd r1 r2 x)) -> + (forall rd r1 r2 s, nolabel (insnS rd r1 r2 s)) -> + tail_nolabel k (arith_extended insnX insnS rd r1 r2 ex a k). +Proof. + unfold arith_extended; intros. destruct Int.ltu. + TailNoLabel. + destruct ex; simpl; TailNoLabel. +Qed. + +Remark loadsymbol_label: forall r id ofs k, tail_nolabel k (loadsymbol r id ofs k). +Proof. + intros; unfold loadsymbol. + destruct (Archi.pic_code tt); TailNoLabel. destruct Ptrofs.eq; TailNoLabel. +Qed. +Hint Resolve loadsymbol_label: labels. + +Remark transl_cond_label: forall cond args k c, + transl_cond cond args k = OK c -> tail_nolabel k c. +Proof. + unfold transl_cond; intros; destruct cond; TailNoLabel. +- destruct is_arith_imm32; TailNoLabel. destruct is_arith_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +- destruct is_arith_imm32; TailNoLabel. destruct is_arith_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +- destruct is_logical_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +- destruct is_logical_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +- destruct is_arith_imm64; TailNoLabel. destruct is_arith_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +- destruct is_arith_imm64; TailNoLabel. destruct is_arith_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +- destruct is_logical_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +- destruct is_logical_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. +Qed. + +Remark transl_cond_branch_default_label: forall cond args lbl k c, + transl_cond_branch_default cond args lbl k = OK c -> tail_nolabel k c. +Proof. + unfold transl_cond_branch_default; intros. + eapply tail_nolabel_trans; [eapply transl_cond_label;eauto|TailNoLabel]. +Qed. +Hint Resolve transl_cond_branch_default_label: labels. + +Remark transl_cond_branch_label: forall cond args lbl k c, + transl_cond_branch cond args lbl k = OK c -> tail_nolabel k c. +Proof. + unfold transl_cond_branch; intros; destruct args; TailNoLabel; destruct cond; TailNoLabel. +- destruct c0; TailNoLabel. +- destruct c0; TailNoLabel. +- destruct (Int.is_power2 n); TailNoLabel. +- destruct (Int.is_power2 n); TailNoLabel. +- destruct c0; TailNoLabel. +- destruct c0; TailNoLabel. +- destruct (Int64.is_power2' n); TailNoLabel. +- destruct (Int64.is_power2' n); TailNoLabel. +Qed. + +Remark transl_op_label: + forall op args r k c, + transl_op op args r k = OK c -> tail_nolabel k c. +Proof. + unfold transl_op; intros; destruct op; TailNoLabel. +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +- destruct (Float.eq_dec n Float.zero); TailNoLabel. +- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. +- apply logicalimm32_label; unfold nolabel; auto. +- apply logicalimm32_label; unfold nolabel; auto. +- apply logicalimm32_label; unfold nolabel; auto. +- unfold shrx32. destruct Int.eq; TailNoLabel. +- apply arith_extended_label; unfold nolabel; auto. +- apply arith_extended_label; unfold nolabel; auto. +- apply logicalimm64_label; unfold nolabel; auto. +- apply logicalimm64_label; unfold nolabel; auto. +- apply logicalimm64_label; unfold nolabel; auto. +- unfold shrx64. destruct Int.eq; TailNoLabel. +- eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel. +- destruct (preg_of r); try discriminate; TailNoLabel; + (eapply tail_nolabel_trans; [eapply transl_cond_label; eauto | TailNoLabel]). +Qed. + +Remark transl_addressing_label: + forall sz addr args insn k c, + transl_addressing sz addr args insn k = OK c -> + (forall ad, nolabel (insn ad)) -> + tail_nolabel k c. +Proof. + unfold transl_addressing; intros; destruct addr; TailNoLabel; + eapply tail_nolabel_trans; TailNoLabel. + eapply tail_nolabel_trans. apply arith_extended_label; unfold nolabel; auto. TailNoLabel. +Qed. + +Remark transl_load_label: + forall chunk addr args dst k c, + transl_load chunk addr args dst k = OK c -> tail_nolabel k c. +Proof. + unfold transl_load; intros; destruct chunk; TailNoLabel; eapply transl_addressing_label; eauto; unfold nolabel; auto. +Qed. + +Remark transl_store_label: + forall chunk addr args src k c, + transl_store chunk addr args src k = OK c -> tail_nolabel k c. +Proof. + unfold transl_store; intros; destruct chunk; TailNoLabel; eapply transl_addressing_label; eauto; unfold nolabel; auto. +Qed. + +Remark indexed_memory_access_label: + forall insn sz base ofs k, + (forall ad, nolabel (insn ad)) -> + tail_nolabel k (indexed_memory_access insn sz base ofs k). +Proof. + unfold indexed_memory_access; intros. destruct offset_representable. + TailNoLabel. + eapply tail_nolabel_trans; TailNoLabel. +Qed. + +Remark loadind_label: + forall base ofs ty dst k c, + loadind base ofs ty dst k = OK c -> tail_nolabel k c. +Proof. + unfold loadind; intros. + destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark storeind_label: + forall src base ofs ty k c, + storeind src base ofs ty k = OK c -> tail_nolabel k c. +Proof. + unfold storeind; intros. + destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark loadptr_label: + forall base ofs dst k, tail_nolabel k (loadptr base ofs dst k). +Proof. + intros. apply indexed_memory_access_label. unfold nolabel; auto. +Qed. + +Remark storeptr_label: + forall src base ofs k, tail_nolabel k (storeptr src base ofs k). +Proof. + intros. apply indexed_memory_access_label. unfold nolabel; auto. +Qed. + +Remark make_epilogue_label: + forall f k, tail_nolabel k (make_epilogue f k). +Proof. + unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadptr_label. TailNoLabel. +Qed. + +Lemma transl_instr_label: + forall f i ep k c, + transl_instr f i ep k = OK c -> + match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. +Proof. + unfold transl_instr; intros; destruct i; TailNoLabel. +- eapply loadind_label; eauto. +- eapply storeind_label; eauto. +- destruct ep. eapply loadind_label; eauto. + eapply tail_nolabel_trans. apply loadptr_label. eapply loadind_label; eauto. +- eapply transl_op_label; eauto. +- eapply transl_load_label; eauto. +- eapply transl_store_label; eauto. +- destruct s0; monadInv H; TailNoLabel. +- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). +- eapply transl_cond_branch_label; eauto. +- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. +Qed. + +Lemma transl_instr_label': + forall lbl f i ep k c, + transl_instr f i ep k = OK c -> + find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. +Proof. + intros. exploit transl_instr_label; eauto. + destruct i; try (intros [A B]; apply B). + intros. subst c. simpl. auto. +Qed. + +Lemma transl_code_label: + forall lbl f c ep tc, + transl_code f c ep = OK tc -> + match Mach.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). + generalize (Mach.is_label_correct lbl a). + destruct (Mach.is_label lbl a); intros. + subst a. simpl in EQ. exists x; auto. + eapply IHc; eauto. +Qed. + +Lemma transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match Mach.find_label lbl f.(Mach.fn_code) with + | None => find_label lbl tf.(fn_code) = None + | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. + simpl. destruct (storeptr_label X30 XSP (fn_retaddr_ofs f) x) as [A B]; rewrite B. + eapply transl_code_label; eauto. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Mach code translates to a valid ``go to'' + transition in the generated Asm code. *) + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros [tc [A B]]. + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmgenproof0.return_address_exists; eauto. +- intros. exploit transl_instr_label; eauto. + destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. + rewrite transl_code'_transl_code in EQ0. + exists x; exists true; split; auto. unfold fn_code. + constructor. apply (storeptr_label X30 XSP (fn_retaddr_ofs f0) x). +- exact transf_function_no_overflow. +Qed. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using simulation diagrams + of the following form. +<< + st1 --------------- st2 + | | + t| *|t + | | + v v + st1'--------------- st2' +>> + The invariant is the [match_states] predicate below, which includes: +- The Asm code pointed by the PC register is the translation of + the current Mach code sequence. +- Mach register values and Asm register values agree. +*) + +Inductive match_states: Mach.state -> Asm.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#X29 = parent_sp s), + match_states (Mach.State s fb sp c ms m) + (Asm.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Mach.Callstate s fb ms m) + (Asm.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Mach.Returnstate s ms m) + (Asm.State rs m'). + +Lemma exec_straight_steps: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists rs2, + exec_straight tge tf c rs1 m1' k rs2 m2' + /\ agree ms2 sp rs2 + /\ (it1_is_parent ep i = true -> rs2#X29 = parent_sp s)) -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c ms2 m2) st'. +Proof. + intros. inversion H2. subst. monadInv H7. + exploit H3; eauto. intros [rs2 [A [B C]]]. + exists (State rs2 m2'); split. + eapply exec_straight_exec; eauto. + econstructor; eauto. eapply exec_straight_at; eauto. +Qed. + +Lemma exec_straight_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. + +Lemma exec_straight_opt_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + inv A. +- exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +- exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the Asm side. Actually, all Mach transitions + correspond to at least one Asm transition, except the + transition from [Machsem.Returnstate] to [Machsem.State]. + So, the following integer measure will suffice to rule out + the unwanted behaviour. *) + +Definition measure (s: Mach.state) : nat := + match s with + | Mach.State _ _ _ _ _ _ => 0%nat + | Mach.Callstate _ _ _ _ => 0%nat + | Mach.Returnstate _ _ _ => 1%nat + end. + +Remark preg_of_not_X29: forall r, negb (mreg_eq r R29) = true -> IR X29 <> preg_of r. +Proof. + intros. change (IR X29) with (preg_of R29). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +Lemma sp_val': forall ms sp rs, agree ms sp rs -> sp = rs XSP. +Proof. + intros. eapply sp_val; eauto. +Qed. + +(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) + +Theorem step_simulation: + forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros; inv MS. + +- (* Mlabel *) + left; eapply exec_straight_steps; eauto; intros. + monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. apply agree_nextinstr; auto. simpl; congruence. + +- (* Mgetstack *) + unfold load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. + exists rs'; split. eauto. + split. eapply agree_set_mreg; eauto with asmgen. congruence. + simpl; congruence. + +- (* Msetstack *) + unfold store_stack in H. + assert (Val.lessdef (rs src) (rs0 (preg_of src))) by (eapply preg_val; eauto). + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + left; eapply exec_straight_steps; eauto. + rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. + exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. + exists rs'; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. + +- (* Mgetparam *) + assert (f0 = f) by congruence; subst f0. + unfold load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val' _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. +Opaque loadind. + left; eapply exec_straight_steps; eauto; intros. monadInv TR. + destruct ep. +(* X30 contains parent *) + exploit loadind_correct. eexact EQ. + instantiate (2 := rs0). simpl; rewrite DXP; eauto. simpl; congruence. + intros [rs1 [P [Q R]]]. + exists rs1; split. eauto. + split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_X29; auto. +(* X30 does not contain parent *) + exploit loadptr_correct. eexact A. simpl; congruence. intros [rs1 [P [Q R]]]. + exploit loadind_correct. eexact EQ. instantiate (2 := rs1). simpl; rewrite Q. eauto. simpl; congruence. + intros [rs2 [S [T U]]]. + exists rs2; split. eapply exec_straight_trans; eauto. + split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs1#X29 <- (rs2#X29)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' X29). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_X29; auto. + +- (* Mop *) + assert (eval_operation tge sp op (map rs args) m = Some v). + { rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. } + exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. split. + apply agree_set_undef_mreg with rs0; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. InvBooleans. + rewrite R; auto. apply preg_of_not_X29; auto. +Local Transparent destroyed_by_op. + destruct op; try exact I; simpl; congruence. + +- (* Mload *) + assert (Op.eval_addressing tge sp addr (map rs args) = Some a). + { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. } + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. + split. eapply agree_set_undef_mreg; eauto. congruence. + simpl; congruence. + +- (* Mstore *) + assert (Op.eval_addressing tge sp addr (map rs args) = Some a). + { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. } + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (rs src) (rs0 (preg_of src))) by (eapply preg_val; eauto). + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + left; eapply exec_straight_steps; eauto. + intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + exists rs2; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; congruence. + +- (* Mcall *) + assert (f0 = f) by congruence. subst f0. + inv AT. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + { eapply transf_function_no_overflow; eauto. } + destruct ros as [rf|fid]; simpl in H; monadInv H5. ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + { destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs0 x0 = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + { econstructor; eauto. } + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. ++ (* Direct call *) + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + +- (* Mtailcall *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + { eapply transf_function_no_overflow; eauto. } + exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. + destruct ros as [rf|fid]; simpl in H; monadInv H7. ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + { destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs0 x0 = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. } + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. ++ (* Direct call *) + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. + +- (* Mbuiltin *) + inv AT. monadInv H4. + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H3); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + left. econstructor; split. apply plus_one. + eapply exec_step_builtin. eauto. eauto. + eapply find_instr_tail; eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x). + unfold nextinstr. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. + rewrite <- H1. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextinstr. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + congruence. + +- (* Mgoto *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H4. + exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. + left; exists (State rs' m'); split. + apply plus_one. econstructor; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + econstructor; eauto. + eapply agree_exten; eauto with asmgen. + congruence. + +- (* Mcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_opt_steps_goto; eauto. + intros. simpl in TR. + exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C). + exists jmp; exists k; exists rs'. + split. eexact A. + split. apply agree_exten with rs0; auto with asmgen. + exact B. + +- (* Mcond false *) + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. eexact B. auto. + split. apply agree_exten with rs0; auto. intros. Simpl. + simpl; congruence. + +- (* Mjumptable *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H6. + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H5); intro NOOV. + exploit find_label_goto_label. eauto. eauto. + instantiate (2 := rs0#X16 <- Vundef #X17 <- Vundef). + Simpl. eauto. + eauto. + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H. intros LD; inv LD. + left; econstructor; split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail; eauto. + simpl. Simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. + econstructor; eauto. + eapply agree_undef_regs; eauto. + simpl. intros. rewrite C; auto with asmgen. Simpl. + congruence. + +- (* Mreturn *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. simpl in H6; monadInv H6. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + +- (* internal function *) + + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. + unfold store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + change (chunk_of_type Tptr) with Mint64 in *. + (* Execution of function prologue *) + monadInv EQ0. rewrite transl_code'_transl_code in EQ1. + set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) :: + storeptr RA XSP (fn_retaddr_ofs f) x0) in *. + set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. + set (rs2 := nextinstr (rs0#X29 <- (parent_sp s) #SP <- sp #X16 <- Vundef)). + exploit (storeptr_correct tge tf XSP (fn_retaddr_ofs f) RA x0 m2' m3' rs2). + simpl preg_of_iregsp. change (rs2 X30) with (rs0 X30). rewrite ATLR. + change (rs2 X2) with sp. eexact P. + simpl; congruence. congruence. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: + exec_straight tge tf + tf.(fn_code) rs0 m' + x0 rs3 m3'). + { change (fn_code tf) with tfbody; unfold tfbody. + apply exec_straight_step with rs2 m2'. + unfold exec_instr. rewrite C. fold sp. + rewrite <- (sp_val _ _ _ AG). rewrite F. reflexivity. + reflexivity. + eexact U. } + exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3 m3'); split. + eapply exec_straight_steps_1; eauto. omega. constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_nextinstr. apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. simpl. + simpl; intros; Simpl. + unfold sp; congruence. + intros. rewrite V by auto with asmgen. reflexivity. + +- (* external function *) + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. apply agree_set_other; auto. apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, Mach.initial_state prog st1 -> + exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Theorem transf_program_correct: + forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). +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/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v new file mode 100644 index 00000000..d60ad2bc --- /dev/null +++ b/aarch64/Asmgenproof1.v @@ -0,0 +1,1836 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for AArch64 code generation: auxiliary results. *) + +Require Import Recdef Coqlib Zwf Zbits. +Require Import Maps Errors AST Integers Floats Values Memory Globalenvs. +Require Import Op Locations Mach Asm Conventions. +Require Import Asmgen. +Require Import Asmgenproof0. + +Local Transparent Archi.ptr64. + +(** Properties of registers *) + +Lemma preg_of_iregsp_not_PC: forall r, preg_of_iregsp r <> PC. +Proof. + destruct r; simpl; congruence. +Qed. +Hint Resolve preg_of_iregsp_not_PC: asmgen. + +Lemma preg_of_not_X16: forall r, preg_of r <> X16. +Proof. + destruct r; simpl; congruence. +Qed. + +Lemma ireg_of_not_X16: forall r x, ireg_of r = OK x -> x <> X16. +Proof. + unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H. + red; intros; subst x. elim (preg_of_not_X16 r); auto. +Qed. + +Lemma ireg_of_not_X16': forall r x, ireg_of r = OK x -> IR x <> IR X16. +Proof. + intros. apply ireg_of_not_X16 in H. congruence. +Qed. + +Hint Resolve preg_of_not_X16 ireg_of_not_X16 ireg_of_not_X16': asmgen. + +(** Useful simplification tactic *) + + +Ltac Simplif := + ((rewrite nextinstr_inv by eauto with asmgen) + || (rewrite nextinstr_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextinstr_pc) + || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +(** * Correctness of ARM constructor functions *) + +Section CONSTRUCTORS. + +Variable ge: genv. +Variable fn: function. + +(** Decomposition of integer literals *) + +Inductive wf_decomposition: list (Z * Z) -> Prop := + | wf_decomp_nil: + wf_decomposition nil + | wf_decomp_cons: forall m n p l, + n = Zzero_ext 16 m -> 0 <= p -> wf_decomposition l -> + wf_decomposition ((n, p) :: l). + +Lemma decompose_int_wf: + forall N n p, 0 <= p -> wf_decomposition (decompose_int N n p). +Proof. +Local Opaque Zzero_ext. + induction N as [ | N]; simpl; intros. +- constructor. +- set (frag := Zzero_ext 16 (Z.shiftr n p)) in *. destruct (Z.eqb frag 0). ++ apply IHN. omega. ++ econstructor. reflexivity. omega. apply IHN; omega. +Qed. + +Fixpoint recompose_int (accu: Z) (l: list (Z * Z)) : Z := + match l with + | nil => accu + | (n, p) :: l => recompose_int (Zinsert accu n p 16) l + end. + +Lemma decompose_int_correct: + forall N n p accu, + 0 <= p -> + (forall i, p <= i -> Z.testbit accu i = false) -> + (forall i, 0 <= i < p + Z.of_nat N * 16 -> + Z.testbit (recompose_int accu (decompose_int N n p)) i = + if zlt i p then Z.testbit accu i else Z.testbit n i). +Proof. + induction N as [ | N]; intros until accu; intros PPOS ABOVE i RANGE. +- simpl. rewrite zlt_true; auto. xomega. +- rewrite inj_S in RANGE. simpl. + set (frag := Zzero_ext 16 (Z.shiftr n p)). + assert (FRAG: forall i, p <= i < p + 16 -> Z.testbit n i = Z.testbit frag (i - p)). + { unfold frag; intros. rewrite Zzero_ext_spec by omega. rewrite zlt_true by omega. + rewrite Z.shiftr_spec by omega. f_equal; omega. } + destruct (Z.eqb_spec frag 0). ++ rewrite IHN. +* destruct (zlt i p). rewrite zlt_true by omega. auto. + destruct (zlt i (p + 16)); auto. + rewrite ABOVE by omega. rewrite FRAG by omega. rewrite e, Z.testbit_0_l. auto. +* omega. +* intros; apply ABOVE; omega. +* xomega. ++ simpl. rewrite IHN. +* destruct (zlt i (p + 16)). +** rewrite Zinsert_spec by omega. unfold proj_sumbool. + rewrite zlt_true by omega. + destruct (zlt i p). + rewrite zle_false by omega. auto. + rewrite zle_true by omega. simpl. symmetry; apply FRAG; omega. +** rewrite Z.ldiff_spec, Z.shiftl_spec by omega. + change 65535 with (two_p 16 - 1). rewrite Ztestbit_two_p_m1 by omega. + rewrite zlt_false by omega. rewrite zlt_false by omega. apply andb_true_r. +* omega. +* intros. rewrite Zinsert_spec by omega. unfold proj_sumbool. + rewrite zle_true by omega. rewrite zlt_false by omega. simpl. + apply ABOVE. omega. +* xomega. +Qed. + +Corollary decompose_int_eqmod: forall N n, + eqmod (two_power_nat (N * 16)%nat) (recompose_int 0 (decompose_int N n 0)) n. +Proof. + intros; apply eqmod_same_bits; intros. + rewrite decompose_int_correct. apply zlt_false; omega. + omega. intros; apply Z.testbit_0_l. xomega. +Qed. + +Corollary decompose_notint_eqmod: forall N n, + eqmod (two_power_nat (N * 16)%nat) + (Z.lnot (recompose_int 0 (decompose_int N (Z.lnot n) 0))) n. +Proof. + intros; apply eqmod_same_bits; intros. + rewrite Z.lnot_spec, decompose_int_correct. + rewrite zlt_false by omega. rewrite Z.lnot_spec by omega. apply negb_involutive. + omega. intros; apply Z.testbit_0_l. xomega. omega. +Qed. + +Lemma negate_decomposition_wf: + forall l, wf_decomposition l -> wf_decomposition (negate_decomposition l). +Proof. + induction 1; simpl; econstructor; auto. + instantiate (1 := (Z.lnot m)). + apply equal_same_bits; intros. + rewrite H. change 65535 with (two_p 16 - 1). + rewrite Z.lxor_spec, !Zzero_ext_spec, Z.lnot_spec, Ztestbit_two_p_m1 by omega. + destruct (zlt i 16). + apply xorb_true_r. + auto. +Qed. + +Lemma Zinsert_eqmod: + forall n x1 x2 y p l, 0 <= p -> 0 <= l -> + eqmod (two_power_nat n) x1 x2 -> + eqmod (two_power_nat n) (Zinsert x1 y p l) (Zinsert x2 y p l). +Proof. + intros. apply eqmod_same_bits; intros. rewrite ! Zinsert_spec by omega. + destruct (zle p i && zlt i (p + l)); auto. + apply same_bits_eqmod with n; auto. +Qed. + +Lemma Zinsert_0_l: + forall y p l, + 0 <= p -> 0 <= l -> + Z.shiftl (Zzero_ext l y) p = Zinsert 0 (Zzero_ext l y) p l. +Proof. + intros. apply equal_same_bits; intros. + rewrite Zinsert_spec by omega. unfold proj_sumbool. + destruct (zlt i p); [rewrite zle_false by omega|rewrite zle_true by omega]; simpl. +- rewrite Z.testbit_0_l, Z.shiftl_spec_low by auto. auto. +- rewrite Z.shiftl_spec by omega. + destruct (zlt i (p + l)); auto. + rewrite Zzero_ext_spec, zlt_false, Z.testbit_0_l by omega. auto. +Qed. + +Lemma recompose_int_negated: + forall l, wf_decomposition l -> + forall accu, recompose_int (Z.lnot accu) (negate_decomposition l) = Z.lnot (recompose_int accu l). +Proof. + induction 1; intros accu; simpl. +- auto. +- rewrite <- IHwf_decomposition. f_equal. apply equal_same_bits; intros. + rewrite Z.lnot_spec, ! Zinsert_spec, Z.lxor_spec, Z.lnot_spec by omega. + unfold proj_sumbool. + destruct (zle p i); simpl; auto. + destruct (zlt i (p + 16)); simpl; auto. + change 65535 with (two_p 16 - 1). + rewrite Ztestbit_two_p_m1 by omega. rewrite zlt_true by omega. + apply xorb_true_r. +Qed. + +Lemma exec_loadimm_k_w: + forall (rd: ireg) k m l, + wf_decomposition l -> + forall (rs: regset) accu, + rs#rd = Vint (Int.repr accu) -> + exists rs', + exec_straight_opt ge fn (loadimm_k W rd l k) rs m k rs' m + /\ rs'#rd = Vint (Int.repr (recompose_int accu l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + induction 1; intros rs accu ACCU; simpl. +- exists rs; split. apply exec_straight_opt_refl. auto. +- destruct (IHwf_decomposition + (nextinstr (rs#rd <- (insert_in_int rs#rd n p 16))) + (Zinsert accu n p 16)) + as (rs' & P & Q & R). + Simpl. rewrite ACCU. simpl. f_equal. apply Int.eqm_samerepr. + apply Zinsert_eqmod. auto. omega. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + exists rs'; split. + eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P. + split. exact Q. intros; Simpl. rewrite R by auto. Simpl. +Qed. + +Lemma exec_loadimm_z_w: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge fn (loadimm_z W rd l k) rs m k rs' m + /\ rs'#rd = Vint (Int.repr (recompose_int 0 l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_z; destruct 1. +- econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +- set (accu0 := Zinsert 0 n p 16). + set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))). + destruct (exec_loadimm_k_w rd k m l H1 rs1 accu0) as (rs2 & P & Q & R); auto. + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega. + reflexivity. + split. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm_n_w: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge fn (loadimm_n W rd l k) rs m k rs' m + /\ rs'#rd = Vint (Int.repr (Z.lnot (recompose_int 0 l))) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_n; destruct 1. +- econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +- set (accu0 := Z.lnot (Zinsert 0 n p 16)). + set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))). + destruct (exec_loadimm_k_w rd k m (negate_decomposition l) + (negate_decomposition_wf l H1) + rs1 accu0) as (rs2 & P & Q & R). + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. + unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega. + reflexivity. + split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm32: + forall rd n k rs m, + exists rs', + exec_straight ge fn (loadimm32 rd n k) rs m k rs' m + /\ rs'#rd = Vint n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm32, loadimm; intros. + destruct (is_logical_imm32 n). +- econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite Int.repr_unsigned, Int.or_zero_l; auto. + intros; Simpl. +- set (dz := decompose_int 2%nat (Int.unsigned n) 0). + set (dn := decompose_int 2%nat (Z.lnot (Int.unsigned n)) 0). + assert (A: Int.repr (recompose_int 0 dz) = n). + { transitivity (Int.repr (Int.unsigned n)). + apply Int.eqm_samerepr. apply decompose_int_eqmod. + apply Int.repr_unsigned. } + assert (B: Int.repr (Z.lnot (recompose_int 0 dn)) = n). + { transitivity (Int.repr (Int.unsigned n)). + apply Int.eqm_samerepr. apply decompose_notint_eqmod. + apply Int.repr_unsigned. } + destruct Nat.leb. ++ rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; omega. ++ rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; omega. +Qed. + +Lemma exec_loadimm_k_x: + forall (rd: ireg) k m l, + wf_decomposition l -> + forall (rs: regset) accu, + rs#rd = Vlong (Int64.repr accu) -> + exists rs', + exec_straight_opt ge fn (loadimm_k X rd l k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.repr (recompose_int accu l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + induction 1; intros rs accu ACCU; simpl. +- exists rs; split. apply exec_straight_opt_refl. auto. +- destruct (IHwf_decomposition + (nextinstr (rs#rd <- (insert_in_long rs#rd n p 16))) + (Zinsert accu n p 16)) + as (rs' & P & Q & R). + Simpl. rewrite ACCU. simpl. f_equal. apply Int64.eqm_samerepr. + apply Zinsert_eqmod. auto. omega. apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr. + exists rs'; split. + eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P. + split. exact Q. intros; Simpl. rewrite R by auto. Simpl. +Qed. + +Lemma exec_loadimm_z_x: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge fn (loadimm_z X rd l k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.repr (recompose_int 0 l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_z; destruct 1. +- econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +- set (accu0 := Zinsert 0 n p 16). + set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))). + destruct (exec_loadimm_k_x rd k m l H1 rs1 accu0) as (rs2 & P & Q & R); auto. + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega. + reflexivity. + split. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm_n_x: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge fn (loadimm_n X rd l k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.repr (Z.lnot (recompose_int 0 l))) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_n; destruct 1. +- econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +- set (accu0 := Z.lnot (Zinsert 0 n p 16)). + set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))). + destruct (exec_loadimm_k_x rd k m (negate_decomposition l) + (negate_decomposition_wf l H1) + rs1 accu0) as (rs2 & P & Q & R). + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. + unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega. + reflexivity. + split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm64: + forall rd n k rs m, + exists rs', + exec_straight ge fn (loadimm64 rd n k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm64, loadimm; intros. + destruct (is_logical_imm64 n). +- econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite Int64.repr_unsigned, Int64.or_zero_l; auto. + intros; Simpl. +- set (dz := decompose_int 4%nat (Int64.unsigned n) 0). + set (dn := decompose_int 4%nat (Z.lnot (Int64.unsigned n)) 0). + assert (A: Int64.repr (recompose_int 0 dz) = n). + { transitivity (Int64.repr (Int64.unsigned n)). + apply Int64.eqm_samerepr. apply decompose_int_eqmod. + apply Int64.repr_unsigned. } + assert (B: Int64.repr (Z.lnot (recompose_int 0 dn)) = n). + { transitivity (Int64.repr (Int64.unsigned n)). + apply Int64.eqm_samerepr. apply decompose_notint_eqmod. + apply Int64.repr_unsigned. } + destruct Nat.leb. ++ rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; omega. ++ rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; omega. +Qed. + +(** Add immediate *) + +Lemma exec_addimm_aux_32: + forall (insn: iregsp -> iregsp -> Z -> instruction) (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_instr ge fn (insn rd r1 n) rs m = + Next (nextinstr (rs#rd <- (sem rs#r1 (Vint (Int.repr n))))) m) -> + (forall v n1 n2, sem (sem v (Vint n1)) (Vint n2) = sem v (Vint (Int.add n1 n2))) -> + forall rd r1 n k rs m, + exists rs', + exec_straight ge fn (addimm_aux insn rd r1 (Int.unsigned n) k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vint n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros insn sem SEM ASSOC; intros. unfold addimm_aux. + set (nlo := Zzero_ext 12 (Int.unsigned n)). set (nhi := Int.unsigned n - nlo). + assert (E: Int.unsigned n = nhi + nlo) by (unfold nlo, nhi; omega). + rewrite <- (Int.repr_unsigned n). + destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. +- econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; omega. + intros; Simpl. +- econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; omega. + intros; Simpl. +- econstructor; split. eapply exec_straight_two. + apply SEM. apply SEM. Simpl. Simpl. + split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int.eqm_samerepr. + rewrite E. auto with ints. + intros; Simpl. +Qed. + +Lemma exec_addimm32: + forall rd r1 n k rs m, + r1 <> X16 -> + exists rs', + exec_straight ge fn (addimm32 rd r1 n k) rs m k rs' m + /\ rs'#rd = Val.add rs#r1 (Vint n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros. unfold addimm32. set (nn := Int.neg n). + destruct (Int.eq n (Int.zero_ext 24 n)); [| destruct (Int.eq nn (Int.zero_ext 24 nn))]. +- apply exec_addimm_aux_32 with (sem := Val.add). auto. intros; apply Val.add_assoc. +- rewrite <- Val.sub_opp_add. + apply exec_addimm_aux_32 with (sem := Val.sub). auto. + intros. rewrite ! Val.sub_add_opp, Val.add_assoc. rewrite Int.neg_add_distr. auto. +- destruct (Int.lt n Int.zero). ++ rewrite <- Val.sub_opp_add; fold nn. + edestruct (exec_loadimm32 X16 nn) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite B, C; eauto with asmgen. + intros; Simpl. ++ edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite B, C; eauto with asmgen. + intros; Simpl. +Qed. + +Lemma exec_addimm_aux_64: + forall (insn: iregsp -> iregsp -> Z -> instruction) (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_instr ge fn (insn rd r1 n) rs m = + Next (nextinstr (rs#rd <- (sem rs#r1 (Vlong (Int64.repr n))))) m) -> + (forall v n1 n2, sem (sem v (Vlong n1)) (Vlong n2) = sem v (Vlong (Int64.add n1 n2))) -> + forall rd r1 n k rs m, + exists rs', + exec_straight ge fn (addimm_aux insn rd r1 (Int64.unsigned n) k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vlong n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros insn sem SEM ASSOC; intros. unfold addimm_aux. + set (nlo := Zzero_ext 12 (Int64.unsigned n)). set (nhi := Int64.unsigned n - nlo). + assert (E: Int64.unsigned n = nhi + nlo) by (unfold nlo, nhi; omega). + rewrite <- (Int64.repr_unsigned n). + destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. +- econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; omega. + intros; Simpl. +- econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; omega. + intros; Simpl. +- econstructor; split. eapply exec_straight_two. + apply SEM. apply SEM. Simpl. Simpl. + split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int64.eqm_samerepr. + rewrite E. auto with ints. + intros; Simpl. +Qed. + +Lemma exec_addimm64: + forall rd r1 n k rs m, + preg_of_iregsp r1 <> X16 -> + exists rs', + exec_straight ge fn (addimm64 rd r1 n k) rs m k rs' m + /\ rs'#rd = Val.addl rs#r1 (Vlong n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros. + unfold addimm64. set (nn := Int64.neg n). + destruct (Int64.eq n (Int64.zero_ext 24 n)); [| destruct (Int64.eq nn (Int64.zero_ext 24 nn))]. +- apply exec_addimm_aux_64 with (sem := Val.addl). auto. intros; apply Val.addl_assoc. +- rewrite <- Val.subl_opp_addl. + apply exec_addimm_aux_64 with (sem := Val.subl). auto. + intros. rewrite ! Val.subl_addl_opp, Val.addl_assoc. rewrite Int64.neg_add_distr. auto. +- destruct (Int64.lt n Int64.zero). ++ rewrite <- Val.subl_opp_addl; fold nn. + edestruct (exec_loadimm64 X16 nn) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. + split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. + intros; Simpl. ++ edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. + split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. + intros; Simpl. +Qed. + +(** Logical immediate *) + +Lemma exec_logicalimm32: + forall (insn1: ireg -> ireg0 -> Z -> instruction) + (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) + (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_instr ge fn (insn1 rd r1 n) rs m = + Next (nextinstr (rs#rd <- (sem rs##r1 (Vint (Int.repr n))))) m) -> + (forall rd r1 r2 s rs m, + exec_instr ge fn (insn2 rd r1 r2 s) rs m = + Next (nextinstr (rs#rd <- (sem rs##r1 (eval_shift_op_int rs#r2 s)))) m) -> + forall rd r1 n k rs m, + r1 <> X16 -> + exists rs', + exec_straight ge fn (logicalimm32 insn1 insn2 rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vint n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros until sem; intros SEM1 SEM2; intros. unfold logicalimm32. + destruct (is_logical_imm32 n). +- econstructor; split. + apply exec_straight_one. apply SEM1. reflexivity. + split. Simpl. rewrite Int.repr_unsigned; auto. intros; Simpl. +- edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. apply SEM2. reflexivity. + split. Simpl. f_equal; auto. apply C; auto with asmgen. + intros; Simpl. +Qed. + +Lemma exec_logicalimm64: + forall (insn1: ireg -> ireg0 -> Z -> instruction) + (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) + (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_instr ge fn (insn1 rd r1 n) rs m = + Next (nextinstr (rs#rd <- (sem rs###r1 (Vlong (Int64.repr n))))) m) -> + (forall rd r1 r2 s rs m, + exec_instr ge fn (insn2 rd r1 r2 s) rs m = + Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) -> + forall rd r1 n k rs m, + r1 <> X16 -> + exists rs', + exec_straight ge fn (logicalimm64 insn1 insn2 rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vlong n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros until sem; intros SEM1 SEM2; intros. unfold logicalimm64. + destruct (is_logical_imm64 n). +- econstructor; split. + apply exec_straight_one. apply SEM1. reflexivity. + split. Simpl. rewrite Int64.repr_unsigned. auto. intros; Simpl. +- edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. apply SEM2. reflexivity. + split. Simpl. f_equal; auto. apply C; auto with asmgen. + intros; Simpl. +Qed. + +(** Load address of symbol *) + +Lemma exec_loadsymbol: forall rd s ofs k rs m, + rd <> X16 \/ Archi.pic_code tt = false -> + exists rs', + exec_straight ge fn (loadsymbol rd s ofs k) rs m k rs' m + /\ rs'#rd = Genv.symbol_address ge s ofs + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadsymbol; intros. destruct (Archi.pic_code tt). +- predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero. ++ subst ofs. econstructor; split. + apply exec_straight_one; [simpl; eauto | reflexivity]. + split. Simpl. intros; Simpl. ++ exploit exec_addimm64. instantiate (1 := rd). simpl. destruct H; congruence. + intros (rs1 & A & B & C). + econstructor; split. + econstructor. simpl; eauto. auto. eexact A. + split. simpl in B; rewrite B. Simpl. + rewrite <- Genv.shift_symbol_address_64 by auto. + rewrite Ptrofs.add_zero_l, Ptrofs.of_int64_to_int64 by auto. auto. + intros. rewrite C by auto. Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split. Simpl. rewrite symbol_high_low; auto. + intros; Simpl. +Qed. + +(** Shifted operands *) + +Remark transl_shift_not_none: + forall s a, transl_shift s a <> SOnone. +Proof. + destruct s; intros; simpl; congruence. +Qed. + +Remark or_zero_eval_shift_op_int: + forall v s, s <> SOnone -> Val.or (Vint Int.zero) (eval_shift_op_int v s) = eval_shift_op_int v s. +Proof. + intros; destruct s; try congruence; destruct v; auto; simpl; + destruct (Int.ltu n Int.iwordsize); auto; rewrite Int.or_zero_l; auto. +Qed. + +Remark or_zero_eval_shift_op_long: + forall v s, s <> SOnone -> Val.orl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s. +Proof. + intros; destruct s; try congruence; destruct v; auto; simpl; + destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.or_zero_l; auto. +Qed. + +Remark add_zero_eval_shift_op_long: + forall v s, s <> SOnone -> Val.addl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s. +Proof. + intros; destruct s; try congruence; destruct v; auto; simpl; + destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.add_zero_l; auto. +Qed. + +Lemma transl_eval_shift: forall s v (a: amount32), + eval_shift_op_int v (transl_shift s a) = eval_shift s v a. +Proof. + intros. destruct s; simpl; auto. +Qed. + +Lemma transl_eval_shift': forall s v (a: amount32), + Val.or (Vint Int.zero) (eval_shift_op_int v (transl_shift s a)) = eval_shift s v a. +Proof. + intros. rewrite or_zero_eval_shift_op_int by (apply transl_shift_not_none). + apply transl_eval_shift. +Qed. + +Lemma transl_eval_shiftl: forall s v (a: amount64), + eval_shift_op_long v (transl_shift s a) = eval_shiftl s v a. +Proof. + intros. destruct s; simpl; auto. +Qed. + +Lemma transl_eval_shiftl': forall s v (a: amount64), + Val.orl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a. +Proof. + intros. rewrite or_zero_eval_shift_op_long by (apply transl_shift_not_none). + apply transl_eval_shiftl. +Qed. + +Lemma transl_eval_shiftl'': forall s v (a: amount64), + Val.addl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a. +Proof. + intros. rewrite add_zero_eval_shift_op_long by (apply transl_shift_not_none). + apply transl_eval_shiftl. +Qed. + +(** Zero- and Sign- extensions *) + +Lemma exec_move_extended_base: forall rd r1 ex k rs m, + exists rs', + exec_straight ge fn (move_extended_base rd r1 ex k) rs m k rs' m + /\ rs' rd = match ex with Xsgn32 => Val.longofint rs#r1 | Xuns32 => Val.longofintu rs#r1 end + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold move_extended_base; destruct ex; econstructor; + (split; [apply exec_straight_one; [simpl;eauto|auto] | split; [Simpl|intros;Simpl]]). +Qed. + +Lemma exec_move_extended: forall rd r1 ex (a: amount64) k rs m, + exists rs', + exec_straight ge fn (move_extended rd r1 ex a k) rs m k rs' m + /\ rs' rd = Op.eval_extend ex rs#r1 a + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold move_extended; intros. predSpec Int.eq Int.eq_spec a Int.zero. +- exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C). + exists rs'; split. eexact A. split. unfold Op.eval_extend. rewrite H. rewrite B. + destruct ex, (rs r1); simpl; auto; rewrite Int64.shl'_zero; auto. + auto. +- Local Opaque Val.addl. + exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + unfold exec_instr. change (SOlsl a) with (transl_shift Slsl a). rewrite transl_eval_shiftl''. eauto. auto. + split. Simpl. rewrite B. auto. + intros; Simpl. +Qed. + +Lemma exec_arith_extended: + forall (sem: val -> val -> val) + (insnX: iregsp -> iregsp -> ireg -> extend_op -> instruction) + (insnS: ireg -> ireg0 -> ireg -> shift_op -> instruction), + (forall rd r1 r2 x rs m, + exec_instr ge fn (insnX rd r1 r2 x) rs m = + Next (nextinstr (rs#rd <- (sem rs#r1 (eval_extend rs#r2 x)))) m) -> + (forall rd r1 r2 s rs m, + exec_instr ge fn (insnS rd r1 r2 s) rs m = + Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) -> + forall (rd r1 r2: ireg) (ex: extension) (a: amount64) (k: code) rs m, + r1 <> X16 -> + exists rs', + exec_straight ge fn (arith_extended insnX insnS rd r1 r2 ex a k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Op.eval_extend ex rs#r2 a) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros sem insnX insnS EX ES; intros. unfold arith_extended. destruct (Int.ltu a (Int.repr 5)). +- econstructor; split. + apply exec_straight_one. rewrite EX; eauto. auto. + split. Simpl. f_equal. destruct ex; auto. + intros; Simpl. +- exploit (exec_move_extended_base X16 r2 ex). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + rewrite ES. eauto. auto. + split. Simpl. unfold ir0x. rewrite C by eauto with asmgen. f_equal. + rewrite B. destruct ex; auto. + intros; Simpl. +Qed. + +(** Extended right shift *) + +Lemma exec_shrx32: forall (rd r1: ireg) (n: int) k v (rs: regset) m, + Val.shrx rs#r1 (Vint n) = Some v -> + r1 <> X16 -> + exists rs', + exec_straight ge fn (shrx32 rd r1 n k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + unfold shrx32; intros. apply Val.shrx_shr_2 in H. + destruct (Int.eq n Int.zero) eqn:E. +- econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. + split. Simpl. subst v; auto. intros; Simpl. +- econstructor; split. eapply exec_straight_three. + unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. + simpl; eauto. + unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. + auto. auto. auto. + split. subst v; Simpl. intros; Simpl. +Qed. + +Lemma exec_shrx64: forall (rd r1: ireg) (n: int) k v (rs: regset) m, + Val.shrxl rs#r1 (Vint n) = Some v -> + r1 <> X16 -> + exists rs', + exec_straight ge fn (shrx64 rd r1 n k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + unfold shrx64; intros. apply Val.shrxl_shrl_2 in H. + destruct (Int.eq n Int.zero) eqn:E. +- econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. + split. Simpl. subst v; auto. intros; Simpl. +- econstructor; split. eapply exec_straight_three. + unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. + simpl; eauto. + unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. + auto. auto. auto. + split. subst v; Simpl. intros; Simpl. +Qed. + +(** Condition bits *) + +Lemma compare_int_spec: forall rs v1 v2 m, + let rs' := compare_int rs v1 v2 m in + rs'#CN = (Val.negative (Val.sub v1 v2)) + /\ rs'#CZ = (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2) + /\ rs'#CC = (Val.cmpu (Mem.valid_pointer m) Cge v1 v2) + /\ rs'#CV = (Val.sub_overflow v1 v2). +Proof. + intros; unfold rs'; auto. +Qed. + +Lemma eval_testcond_compare_sint: forall c v1 v2 b rs m, + Val.cmp_bool c v1 v2 = Some b -> + eval_testcond (cond_for_signed_cmp c) (compare_int rs v1 v2 m) = Some b. +Proof. + intros. generalize (compare_int_spec rs v1 v2 m). + set (rs' := compare_int rs v1 v2 m). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. + destruct v1; try discriminate; destruct v2; try discriminate. + simpl in H; inv H. + unfold Val.cmpu; simpl. destruct c; simpl. +- destruct (Int.eq i i0); auto. +- destruct (Int.eq i i0); auto. +- rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto. +- rewrite Int.lt_sub_overflow, Int.not_lt. + destruct (Int.eq i i0), (Int.lt i i0); auto. +- rewrite Int.lt_sub_overflow, (Int.lt_not i). + destruct (Int.eq i i0), (Int.lt i i0); auto. +- rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto. +Qed. + +Lemma eval_testcond_compare_uint: forall c v1 v2 b rs m, + Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> + eval_testcond (cond_for_unsigned_cmp c) (compare_int rs v1 v2 m) = Some b. +Proof. + intros. generalize (compare_int_spec rs v1 v2 m). + set (rs' := compare_int rs v1 v2 m). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. + destruct v1; try discriminate; destruct v2; try discriminate. + simpl in H; inv H. + unfold Val.cmpu; simpl. destruct c; simpl. +- destruct (Int.eq i i0); auto. +- destruct (Int.eq i i0); auto. +- destruct (Int.ltu i i0); auto. +- rewrite (Int.not_ltu i). destruct (Int.eq i i0), (Int.ltu i i0); auto. +- rewrite (Int.ltu_not i). destruct (Int.eq i i0), (Int.ltu i i0); auto. +- destruct (Int.ltu i i0); auto. +Qed. + +Lemma compare_long_spec: forall rs v1 v2 m, + let rs' := compare_long rs v1 v2 m in + rs'#CN = (Val.negativel (Val.subl v1 v2)) + /\ rs'#CZ = (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2)) + /\ rs'#CC = (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cge v1 v2)) + /\ rs'#CV = (Val.subl_overflow v1 v2). +Proof. + intros; unfold rs'; auto. +Qed. + +Remark int64_sub_overflow: + forall x y, + Int.xor (Int.repr (Int64.unsigned (Int64.sub_overflow x y Int64.zero))) + (Int.repr (Int64.unsigned (Int64.negative (Int64.sub x y)))) = + (if Int64.lt x y then Int.one else Int.zero). +Proof. + intros. + transitivity (Int.repr (Int64.unsigned (if Int64.lt x y then Int64.one else Int64.zero))). + rewrite <- (Int64.lt_sub_overflow x y). + unfold Int64.sub_overflow, Int64.negative. + set (s := Int64.signed x - Int64.signed y - Int64.signed Int64.zero). + destruct (zle Int64.min_signed s && zle s Int64.max_signed); + destruct (Int64.lt (Int64.sub x y) Int64.zero); + auto. + destruct (Int64.lt x y); auto. +Qed. + +Lemma eval_testcond_compare_slong: forall c v1 v2 b rs m, + Val.cmpl_bool c v1 v2 = Some b -> + eval_testcond (cond_for_signed_cmp c) (compare_long rs v1 v2 m) = Some b. +Proof. + intros. generalize (compare_long_spec rs v1 v2 m). + set (rs' := compare_long rs v1 v2 m). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. + destruct v1; try discriminate; destruct v2; try discriminate. + simpl in H; inv H. + unfold Val.cmplu; simpl. destruct c; simpl. +- destruct (Int64.eq i i0); auto. +- destruct (Int64.eq i i0); auto. +- rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto. +- rewrite int64_sub_overflow, Int64.not_lt. + destruct (Int64.eq i i0), (Int64.lt i i0); auto. +- rewrite int64_sub_overflow, (Int64.lt_not i). + destruct (Int64.eq i i0), (Int64.lt i i0); auto. +- rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto. +Qed. + +Lemma eval_testcond_compare_ulong: forall c v1 v2 b rs m, + Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> + eval_testcond (cond_for_unsigned_cmp c) (compare_long rs v1 v2 m) = Some b. +Proof. + intros. generalize (compare_long_spec rs v1 v2 m). + set (rs' := compare_long rs v1 v2 m). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E; unfold Val.cmplu. + destruct v1; try discriminate; destruct v2; try discriminate; simpl in H. +- (* int-int *) + inv H. destruct c; simpl. ++ destruct (Int64.eq i i0); auto. ++ destruct (Int64.eq i i0); auto. ++ destruct (Int64.ltu i i0); auto. ++ rewrite (Int64.not_ltu i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto. ++ rewrite (Int64.ltu_not i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto. ++ destruct (Int64.ltu i i0); auto. +- (* int-ptr *) + simpl. + destruct (Int64.eq i Int64.zero && + (Mem.valid_pointer m b0 (Ptrofs.unsigned i0) + || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))); try discriminate. + destruct c; simpl in H; inv H; reflexivity. +- (* ptr-int *) + simpl. + destruct (Int64.eq i0 Int64.zero && + (Mem.valid_pointer m b0 (Ptrofs.unsigned i) + || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))); try discriminate. + destruct c; simpl in H; inv H; reflexivity. +- (* ptr-ptr *) + simpl. + destruct (eq_block b0 b1). ++ destruct ((Mem.valid_pointer m b0 (Ptrofs.unsigned i) + || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1)) && + (Mem.valid_pointer m b1 (Ptrofs.unsigned i0) + || Mem.valid_pointer m b1 (Ptrofs.unsigned i0 - 1))); + inv H. + destruct c; simpl. +* destruct (Ptrofs.eq i i0); auto. +* destruct (Ptrofs.eq i i0); auto. +* destruct (Ptrofs.ltu i i0); auto. +* rewrite (Ptrofs.not_ltu i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto. +* rewrite (Ptrofs.ltu_not i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto. +* destruct (Ptrofs.ltu i i0); auto. ++ destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) && + Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate. + destruct c; simpl in H; inv H; reflexivity. +Qed. + +Lemma compare_float_spec: forall rs f1 f2, + let rs' := compare_float rs (Vfloat f1) (Vfloat f2) in + rs'#CN = (Val.of_bool (Float.cmp Clt f1 f2)) + /\ rs'#CZ = (Val.of_bool (Float.cmp Ceq f1 f2)) + /\ rs'#CC = (Val.of_bool (negb (Float.cmp Clt f1 f2))) + /\ rs'#CV = (Val.of_bool (negb (Float.ordered f1 f2))). +Proof. + intros; auto. +Qed. + +Lemma eval_testcond_compare_float: forall c v1 v2 b rs, + Val.cmpf_bool c v1 v2 = Some b -> + eval_testcond (cond_for_float_cmp c) (compare_float rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_float_spec rs f f0). + set (rs' := compare_float rs (Vfloat f) (Vfloat f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float.cmp Float.ordered. + unfold Float.cmp, Float.ordered; + destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity. +Qed. + +Lemma eval_testcond_compare_not_float: forall c v1 v2 b rs, + option_map negb (Val.cmpf_bool c v1 v2) = Some b -> + eval_testcond (cond_for_float_not_cmp c) (compare_float rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_float_spec rs f f0). + set (rs' := compare_float rs (Vfloat f) (Vfloat f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float.cmp Float.ordered. + unfold Float.cmp, Float.ordered; + destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity. +Qed. + +Lemma compare_single_spec: forall rs f1 f2, + let rs' := compare_single rs (Vsingle f1) (Vsingle f2) in + rs'#CN = (Val.of_bool (Float32.cmp Clt f1 f2)) + /\ rs'#CZ = (Val.of_bool (Float32.cmp Ceq f1 f2)) + /\ rs'#CC = (Val.of_bool (negb (Float32.cmp Clt f1 f2))) + /\ rs'#CV = (Val.of_bool (negb (Float32.ordered f1 f2))). +Proof. + intros; auto. +Qed. + +Lemma eval_testcond_compare_single: forall c v1 v2 b rs, + Val.cmpfs_bool c v1 v2 = Some b -> + eval_testcond (cond_for_float_cmp c) (compare_single rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_single_spec rs f f0). + set (rs' := compare_single rs (Vsingle f) (Vsingle f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float32.cmp Float32.ordered. + unfold Float32.cmp, Float32.ordered; + destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity. +Qed. + +Lemma eval_testcond_compare_not_single: forall c v1 v2 b rs, + option_map negb (Val.cmpfs_bool c v1 v2) = Some b -> + eval_testcond (cond_for_float_not_cmp c) (compare_single rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_single_spec rs f f0). + set (rs' := compare_single rs (Vsingle f) (Vsingle f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float32.cmp Float32.ordered. + unfold Float32.cmp, Float32.ordered; + destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity. +Qed. + +Remark compare_float_inv: forall rs v1 v2 r, + match r with CR _ => False | _ => True end -> + (nextinstr (compare_float rs v1 v2))#r = (nextinstr rs)#r. +Proof. + intros; unfold compare_float. + destruct r; try contradiction; destruct v1; auto; destruct v2; auto. +Qed. + +Remark compare_single_inv: forall rs v1 v2 r, + match r with CR _ => False | _ => True end -> + (nextinstr (compare_single rs v1 v2))#r = (nextinstr rs)#r. +Proof. + intros; unfold compare_single. + destruct r; try contradiction; destruct v1; auto; destruct v2; auto. +Qed. + +(** Translation of conditionals *) + +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). + +Lemma transl_cond_correct: + forall cond args k c rs m, + transl_cond cond args k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ (forall b, + eval_condition cond (map rs (map preg_of args)) m = Some b -> + eval_testcond (cond_for_cond cond) rs' = Some b) + /\ forall r, data_preg r = true -> rs'#r = rs#r. +Proof. + intros until m; intros TR. destruct cond; simpl in TR; ArgsInv. +- (* Ccomp *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. +- (* Ccompu *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. +- (* Ccompimm *) + destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. ++ econstructor; split. + apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. + split; intros. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply eval_testcond_compare_sint; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Ccompuimm *) + destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. ++ econstructor; split. + apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. + split; intros. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply eval_testcond_compare_uint; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Ccompshift *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. +- (* Ccompushift *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. +- (* Cmaskzero *) + destruct (is_logical_imm32 n). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Ceq); auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply (eval_testcond_compare_sint Ceq); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Cmasknotzero *) + destruct (is_logical_imm32 n). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Cne); auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply (eval_testcond_compare_sint Cne); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Ccompl *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. +- (* Ccomplu *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. apply eval_testcond_compare_ulong; auto. + destruct r; reflexivity || discriminate. +- (* Ccomplimm *) + destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. ++ econstructor; split. + apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto. + split; intros. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply eval_testcond_compare_slong; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Ccompluimm *) + destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_ulong; auto. + destruct r; reflexivity || discriminate. ++ econstructor; split. + apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto. + split; intros. apply eval_testcond_compare_ulong; auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply eval_testcond_compare_ulong; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Ccomplshift *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. +- (* Ccomplushift *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_ulong; auto. + destruct r; reflexivity || discriminate. +- (* Cmasklzero *) + destruct (is_logical_imm64 n). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Ceq); auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply (eval_testcond_compare_slong Ceq); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Cmasknotzero *) + destruct (is_logical_imm64 n). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Cne); auto. + destruct r; reflexivity || discriminate. ++ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply (eval_testcond_compare_slong Cne); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. +- (* Ccompf *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_float_inv; auto. + split; intros. apply eval_testcond_compare_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. +- (* Cnotcompf *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_float_inv; auto. + split; intros. apply eval_testcond_compare_not_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. +- (* Ccompfzero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_float_inv; auto. + split; intros. apply eval_testcond_compare_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. +- (* Cnotcompfzero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_float_inv; auto. + split; intros. apply eval_testcond_compare_not_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. +- (* Ccompfs *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_single_inv; auto. + split; intros. apply eval_testcond_compare_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. +- (* Cnotcompfs *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_single_inv; auto. + split; intros. apply eval_testcond_compare_not_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. +- (* Ccompfszero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_single_inv; auto. + split; intros. apply eval_testcond_compare_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. +- (* Cnotcompfszero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + rewrite compare_single_inv; auto. + split; intros. apply eval_testcond_compare_not_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. +Qed. + +(** Translation of conditional branches *) + +Lemma transl_cond_branch_correct: + forall cond args lbl k c rs m b, + transl_cond_branch cond args lbl k = OK c -> + eval_condition cond (map rs (map preg_of args)) m = Some b -> + exists rs' insn, + exec_straight_opt ge fn c rs m (insn :: k) rs' m + /\ exec_instr ge fn insn rs' m = + (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m) + /\ forall r, data_preg r = true -> rs'#r = rs#r. +Proof. + intros until b; intros TR EV. + assert (DFL: + transl_cond_branch_default cond args lbl k = OK c -> + exists rs' insn, + exec_straight_opt ge fn c rs m (insn :: k) rs' m + /\ exec_instr ge fn insn rs' m = + (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m) + /\ forall r, data_preg r = true -> rs'#r = rs#r). + { + unfold transl_cond_branch_default; intros. + exploit transl_cond_correct; eauto. intros (rs' & A & B & C). + exists rs', (Pbc (cond_for_cond cond) lbl); split. + apply exec_straight_opt_intro. eexact A. + split; auto. simpl. rewrite (B b) by auto. auto. + } +Local Opaque transl_cond transl_cond_branch_default. + destruct args as [ | a1 args]; simpl in TR; auto. + destruct args as [ | a2 args]; simpl in TR; auto. + destruct cond; simpl in TR; auto. +- (* Ccompimm *) + destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto; + apply Int.same_if_eq in N0; subst n; ArgsInv. ++ (* Ccompimm Cne 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. auto. ++ (* Ccompimm Ceq 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. destruct (Int.eq i Int.zero); auto. +- (* Ccompuimm *) + destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto; + apply Int.same_if_eq in N0; subst n; ArgsInv. ++ (* Ccompuimm Cne 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. rewrite EV. auto. ++ (* Ccompuimm Ceq 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cne), EV. destruct b; auto. +- (* Cmaskzero *) + destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv. + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. + erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto. + rewrite (Val.negate_cmp_bool Ceq), EV. destruct b; auto. +- (* Cmasknotzero *) + destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv. + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. + erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto. + rewrite EV. auto. +- (* Ccomplimm *) + destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto; + apply Int64.same_if_eq in N0; subst n; ArgsInv. ++ (* Ccomplimm Cne 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. auto. ++ (* Ccomplimm Ceq 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. destruct (Int64.eq i Int64.zero); auto. +- (* Ccompluimm *) + destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto; + apply Int64.same_if_eq in N0; subst n; ArgsInv. ++ (* Ccompluimm Cne 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. rewrite EV. auto. ++ (* Ccompluimm Ceq 0 *) + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cne), EV. destruct b; auto. +- (* Cmasklzero *) + destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv. + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. + erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto. + rewrite (Val.negate_cmpl_bool Ceq), EV. destruct b; auto. +- (* Cmasklnotzero *) + destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv. + do 2 econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. + erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto. + rewrite EV. auto. +Qed. + +(** Translation of arithmetic operations *) + +Ltac SimplEval H := + match type of H with + | Some _ = None _ => discriminate + | Some _ = Some _ => inv H + | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) +end. + +Ltac TranslOpSimpl := + econstructor; split; + [ apply exec_straight_one; [simpl; eauto | reflexivity] + | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; + apply Val.lessdef_same; Simpl; fail + | intros; Simpl; fail ] ]. + +Ltac TranslOpBase := + econstructor; split; + [ apply exec_straight_one; [simpl; eauto | reflexivity] + | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; Simpl + | intros; Simpl; fail ] ]. + +Lemma transl_op_correct: + forall op args res k (rs: regset) m v c, + transl_op op args res k = OK c -> + eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. +Proof. +Local Opaque Int.eq Int64.eq Val.add Val.addl Int.zwordsize Int64.zwordsize. + intros until c; intros TR EV. + unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. +- (* move *) + destruct (preg_of res) eqn:RR; try discriminate; destruct (preg_of m0) eqn:R1; inv TR. ++ TranslOpSimpl. ++ TranslOpSimpl. +- (* intconst *) + exploit exec_loadimm32. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. intros; auto with asmgen. +- (* longconst *) + exploit exec_loadimm64. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. intros; auto with asmgen. +- (* floatconst *) + destruct (Float.eq_dec n Float.zero). ++ subst n. TranslOpSimpl. ++ TranslOpSimpl. +- (* singleconst *) + destruct (Float32.eq_dec n Float32.zero). ++ subst n. TranslOpSimpl. ++ TranslOpSimpl. +- (* loadsymbol *) + exploit (exec_loadsymbol x id ofs). eauto with asmgen. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* addrstack *) + exploit (exec_addimm64 x XSP (Ptrofs.to_int64 ofs)). simpl; eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. simpl in B; rewrite B. +Local Transparent Val.addl. + destruct (rs SP); simpl; auto. rewrite Ptrofs.of_int64_to_int64 by auto. auto. + auto. +- (* shift *) + rewrite <- transl_eval_shift'. TranslOpSimpl. +- (* addimm *) + exploit (exec_addimm32 x x0 n). eauto with asmgen. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* mul *) + TranslOpBase. +Local Transparent Val.add. + destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int.add_zero_l; auto. +- (* andimm *) + exploit (exec_logicalimm32 (Pandimm W) (Pand W)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* orimm *) + exploit (exec_logicalimm32 (Porrimm W) (Porr W)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* xorimm *) + exploit (exec_logicalimm32 (Peorimm W) (Peor W)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* not *) + TranslOpBase. + destruct (rs x0); auto. simpl. rewrite Int.or_zero_l; auto. +- (* notshift *) + TranslOpBase. + destruct (eval_shift s (rs x0) a); auto. simpl. rewrite Int.or_zero_l; auto. +- (* shrx *) + exploit (exec_shrx32 x x0 n); eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. +- (* zero-ext *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto. +- (* sign-ext *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto. +- (* shlzext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int.shl_zero_ext_min; auto using a32_range. +- (* shlsext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int.shl_sign_ext_min; auto using a32_range. +- (* zextshr *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.zero_ext_shru_min; auto using a32_range. +- (* sextshr *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.sign_ext_shr_min; auto using a32_range. +- (* shiftl *) + rewrite <- transl_eval_shiftl'. TranslOpSimpl. +- (* extend *) + exploit (exec_move_extended x0 x1 x a k). intros (rs' & A & B & C). + econstructor; split. eexact A. + split. rewrite B; auto. eauto with asmgen. +- (* addext *) + exploit (exec_arith_extended Val.addl Paddext (Padd X)). + auto. auto. instantiate (1 := x1). eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. +- (* addlimm *) + exploit (exec_addimm64 x x0 n). simpl. generalize (ireg_of_not_X16 _ _ EQ1). congruence. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. simpl in B; rewrite B; auto. auto. +- (* subext *) + exploit (exec_arith_extended Val.subl Psubext (Psub X)). + auto. auto. instantiate (1 := x1). eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. +- (* mull *) + TranslOpBase. + destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int64.add_zero_l; auto. +- (* andlimm *) + exploit (exec_logicalimm64 (Pandimm X) (Pand X)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* orlimm *) + exploit (exec_logicalimm64 (Porrimm X) (Porr X)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* xorlimm *) + exploit (exec_logicalimm64 (Peorimm X) (Peor X)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. +- (* notl *) + TranslOpBase. + destruct (rs x0); auto. simpl. rewrite Int64.or_zero_l; auto. +- (* notlshift *) + TranslOpBase. + destruct (eval_shiftl s (rs x0) a); auto. simpl. rewrite Int64.or_zero_l; auto. +- (* shrx *) + exploit (exec_shrx64 x x0 n); eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. +- (* zero-ext-l *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto. +- (* sign-ext-l *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto. +- (* shllzext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_zero_ext_min; auto using a64_range. +- (* shllsext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_sign_ext_min; auto using a64_range. +- (* zextshrl *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.zero_ext_shru'_min; auto using a64_range. +- (* sextshrl *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.sign_ext_shr'_min; auto using a64_range. +- (* condition *) + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. + rewrite (B b) by auto. auto. + auto. + intros; Simpl. +- (* select *) + destruct (preg_of res) eqn:RES; monadInv TR. + + (* integer *) + generalize (ireg_of_eq _ _ EQ) (ireg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. + rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. + rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. + auto. + intros; Simpl. + + (* FP *) + generalize (freg_of_eq _ _ EQ) (freg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. + rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. + rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. + auto. + intros; Simpl. +Qed. + +(** Translation of addressing modes, loads, stores *) + +Lemma transl_addressing_correct: + forall sz addr args (insn: Asm.addressing -> instruction) k (rs: regset) m c b o, + transl_addressing sz addr args insn k = OK c -> + Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some (Vptr b o) -> + exists ad rs', + exec_straight_opt ge fn c rs m (insn ad :: k) rs' m + /\ Asm.eval_addressing ge ad rs' = Vptr b o + /\ forall r, data_preg r = true -> rs' r = rs r. +Proof. + intros until o; intros TR EV. + unfold transl_addressing in TR; destruct addr; ArgsInv; SimplEval EV. +- (* Aindexed *) + destruct (offset_representable sz ofs); inv EQ0. ++ econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. ++ exploit (exec_loadimm64 X16 ofs). intros (rs' & A & B & C). + econstructor; exists rs'; split. apply exec_straight_opt_intro; eexact A. + split. simpl. rewrite B, C by eauto with asmgen. auto. + eauto with asmgen. +- (* Aindexed2 *) + econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. +- (* Aindexed2shift *) + destruct (Int.eq a Int.zero) eqn:E; [|destruct (Int.eq (Int.shl Int.one a) (Int.repr sz))]; inv EQ2. ++ apply Int.same_if_eq in E. rewrite E. + econstructor; econstructor; split. apply exec_straight_opt_refl. + split; auto. simpl. + rewrite Val.addl_commut in H0. destruct (rs x0); try discriminate. + unfold Val.shll. rewrite Int64.shl'_zero. auto. ++ econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. ++ econstructor; econstructor; split. + apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. + split. simpl. Simpl. rewrite H0. simpl. rewrite Ptrofs.add_zero. auto. + intros; Simpl. +- (* Aindexed2ext *) + destruct (Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz)); inv EQ2. ++ econstructor; econstructor; split. apply exec_straight_opt_refl. + split; auto. destruct x; auto. ++ exploit (exec_arith_extended Val.addl Paddext (Padd X)); auto. + instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + econstructor; exists rs'; split. + apply exec_straight_opt_intro. eexact A. + split. simpl. rewrite B. rewrite Val.addl_assoc. f_equal. + unfold Op.eval_extend; destruct x, (rs x1); simpl; auto; rewrite ! a64_range; + simpl; rewrite Int64.add_zero; auto. + intros. apply C; eauto with asmgen. +- (* Aglobal *) + destruct (Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero); inv TR. ++ econstructor; econstructor; split. + apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. + split. simpl. Simpl. rewrite symbol_high_low. simpl in EV. congruence. + intros; Simpl. ++ exploit (exec_loadsymbol X16 id ofs). auto. intros (rs' & A & B & C). + econstructor; exists rs'; split. + apply exec_straight_opt_intro. eexact A. + split. simpl. + rewrite B. rewrite <- Genv.shift_symbol_address_64, Ptrofs.add_zero by auto. + simpl in EV. congruence. + auto with asmgen. +- (* Ainstrack *) + assert (E: Val.addl (rs SP) (Vlong (Ptrofs.to_int64 ofs)) = Vptr b o). + { simpl in EV. inv EV. destruct (rs SP); simpl in H1; inv H1. simpl. + rewrite Ptrofs.of_int64_to_int64 by auto. auto. } + destruct (offset_representable sz (Ptrofs.to_int64 ofs)); inv TR. ++ econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. ++ exploit (exec_loadimm64 X16 (Ptrofs.to_int64 ofs)). intros (rs' & A & B & C). + econstructor; exists rs'; split. + apply exec_straight_opt_intro. eexact A. + split. simpl. rewrite B, C by eauto with asmgen. auto. + auto with asmgen. +Qed. + +Lemma transl_load_correct: + forall chunk addr args dst k c (rs: regset) m vaddr v, + transl_load chunk addr args dst k = OK c -> + Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr -> + Mem.loadv chunk m vaddr = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r. +Proof. + intros. destruct vaddr; try discriminate. + assert (A: exists sz insn, + transl_addressing sz addr args insn k = OK c + /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = + exec_load ge chunk (fun v => v) ad (preg_of dst) rs' m)). + { + destruct chunk; monadInv H; + try rewrite (ireg_of_eq _ _ EQ); try rewrite (freg_of_eq _ _ EQ); + do 2 econstructor; (split; [eassumption|auto]). + } + destruct A as (sz & insn & B & C). + exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R). + assert (X: exec_load ge chunk (fun v => v) ad (preg_of dst) rs' m = + Next (nextinstr (rs'#(preg_of dst) <- v)) m). + { unfold exec_load. rewrite Q, H1. auto. } + econstructor; split. + eapply exec_straight_opt_right. eexact P. + apply exec_straight_one. rewrite C, X; eauto. Simpl. + split. Simpl. intros; Simpl. +Qed. + +Lemma transl_store_correct: + forall chunk addr args src k c (rs: regset) m vaddr m', + transl_store chunk addr args src k = OK c -> + Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr -> + Mem.storev chunk m vaddr rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, data_preg r = true -> rs' r = rs r. +Proof. + intros. destruct vaddr; try discriminate. + set (chunk' := match chunk with Mint8signed => Mint8unsigned + | Mint16signed => Mint16unsigned + | _ => chunk end). + assert (A: exists sz insn, + transl_addressing sz addr args insn k = OK c + /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = + exec_store ge chunk' ad rs'#(preg_of src) rs' m)). + { + unfold chunk'; destruct chunk; monadInv H; + try rewrite (ireg_of_eq _ _ EQ); try rewrite (freg_of_eq _ _ EQ); + do 2 econstructor; (split; [eassumption|auto]). + } + destruct A as (sz & insn & B & C). + exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R). + assert (X: Mem.storev chunk' m (Vptr b i) rs#(preg_of src) = Some m'). + { rewrite <- H1. unfold chunk'. destruct chunk; auto; simpl; symmetry. + apply Mem.store_signed_unsigned_8. + apply Mem.store_signed_unsigned_16. } + assert (Y: exec_store ge chunk' ad rs'#(preg_of src) rs' m = + Next (nextinstr rs') m'). + { unfold exec_store. rewrite Q, R, X by auto with asmgen. auto. } + econstructor; split. + eapply exec_straight_opt_right. eexact P. + apply exec_straight_one. rewrite C, Y; eauto. Simpl. + intros; Simpl. +Qed. + +(** Translation of indexed memory accesses *) + +Lemma indexed_memory_access_correct: forall insn sz (base: iregsp) ofs k (rs: regset) m b i, + preg_of_iregsp base <> IR X16 -> + Val.offset_ptr rs#base ofs = Vptr b i -> + exists ad rs', + exec_straight_opt ge fn (indexed_memory_access insn sz base ofs k) rs m (insn ad :: k) rs' m + /\ Asm.eval_addressing ge ad rs' = Vptr b i + /\ forall r, r <> PC -> r <> X16 -> rs' r = rs r. +Proof. + unfold indexed_memory_access; intros. + assert (Val.addl rs#base (Vlong (Ptrofs.to_int64 ofs)) = Vptr b i). + { destruct (rs base); try discriminate. simpl in *. rewrite Ptrofs.of_int64_to_int64 by auto. auto. } + destruct offset_representable. +- econstructor; econstructor; split. apply exec_straight_opt_refl. auto. +- exploit (exec_loadimm64 X16); eauto. intros (rs' & A & B & C). + econstructor; econstructor; split. apply exec_straight_opt_intro; eexact A. + split. simpl. rewrite B, C by eauto with asmgen. auto. auto. +Qed. + +Lemma loadptr_correct: forall (base: iregsp) ofs dst k m v (rs: regset), + Mem.loadv Mint64 m (Val.offset_ptr rs#base ofs) = Some v -> + preg_of_iregsp base <> IR X16 -> + exists rs', + exec_straight ge fn (loadptr base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> X16 -> r <> dst -> rs' r = rs r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. simpl. unfold exec_load. rewrite B, H. eauto. auto. + split. Simpl. intros; Simpl. +Qed. + +Lemma storeptr_correct: forall (base: iregsp) ofs (src: ireg) k m m' (rs: regset), + Mem.storev Mint64 m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> + preg_of_iregsp base <> IR X16 -> + src <> X16 -> + exists rs', + exec_straight ge fn (storeptr src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> X16 -> rs' r = rs r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. simpl. unfold exec_store. rewrite B, C, H by eauto with asmgen. eauto. auto. + intros; Simpl. +Qed. + +Lemma loadind_correct: forall (base: iregsp) 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 -> + preg_of_iregsp base <> IR X16 -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + assert (X: exists sz insn, + c = indexed_memory_access insn sz base ofs k + /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = + exec_load ge (chunk_of_type ty) (fun v => v) ad (preg_of dst) rs' m)). + { + unfold loadind in H; destruct ty; destruct (preg_of dst); inv H; do 2 econstructor; eauto. + } + destruct X as (sz & insn & EQ & SEM). subst c. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. rewrite SEM. unfold exec_load. rewrite B, H0. eauto. Simpl. + split. Simpl. intros; Simpl. +Qed. + +Lemma storeind_correct: forall (base: iregsp) 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' -> + preg_of_iregsp base <> IR X16 -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, data_preg r = true -> rs' r = rs r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + assert (X: exists sz insn, + c = indexed_memory_access insn sz base ofs k + /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = + exec_store ge (chunk_of_type ty) ad rs'#(preg_of src) rs' m)). + { + unfold storeind in H; destruct ty; destruct (preg_of src); inv H; do 2 econstructor; eauto. + } + destruct X as (sz & insn & EQ & SEM). subst c. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. rewrite SEM. + unfold exec_store. rewrite B, C, H0 by eauto with asmgen. eauto. + Simpl. + intros; Simpl. +Qed. + +Lemma make_epilogue_correct: + forall ge0 f m stk soff cs m' ms rs k tm, + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + agree ms (Vptr stk soff) rs -> + Mem.extends m tm -> + match_stack ge0 cs -> + exists rs', exists tm', + exec_straight ge fn (make_epilogue f k) rs tm k rs' tm' + /\ agree ms (parent_sp cs) rs' + /\ Mem.extends m' tm' + /\ rs'#RA = parent_ra cs + /\ rs'#SP = parent_sp cs + /\ (forall r, r <> PC -> r <> SP -> r <> X30 -> r <> X16 -> 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. + exploit (loadptr_correct XSP (fn_retaddr_ofs f)). + instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence. + intros (rs1 & A1 & B1 & C1). + econstructor; econstructor; split. + eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl. + simpl; rewrite (C1 SP) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. + rewrite FREE'. eauto. auto. + split. apply agree_nextinstr. apply agree_set_other; auto. + apply agree_change_sp with (Vptr stk soff). + apply agree_exten with rs; auto. intros; apply C1; auto with asmgen. + eapply parent_sp_def; eauto. + split. auto. + split. Simpl. + split. Simpl. + intros. Simpl. +Qed. + +End CONSTRUCTORS. diff --git a/aarch64/Builtins1.v b/aarch64/Builtins1.v new file mode 100644 index 00000000..f6e643d2 --- /dev/null +++ b/aarch64/Builtins1.v @@ -0,0 +1,33 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. + +Inductive platform_builtin : Type := . + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := + match b with end. diff --git a/aarch64/CBuiltins.ml b/aarch64/CBuiltins.ml new file mode 100644 index 00000000..fdc1372d --- /dev/null +++ b/aarch64/CBuiltins.ml @@ -0,0 +1,72 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Processor-dependent builtin C functions *) + +open C + +(* va_list is a struct of size 32 and alignment 8, passed by reference *) + +let va_list_type = TArray(TInt(IULong, []), Some 4L, []) +let size_va_list = 32 +let va_list_scalar = false + +let builtins = { + builtin_typedefs = [ + "__builtin_va_list", va_list_type + ]; + builtin_functions = [ + (* Synchronization *) + "__builtin_fence", + (TVoid [], [], false); + (* Integer arithmetic *) + "__builtin_bswap64", + (TInt(IULongLong, []), [TInt(IULongLong, [])], false); + "__builtin_clz", + (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_clzl", + (TInt(IInt, []), [TInt(IULong, [])], false); + "__builtin_clzll", + (TInt(IInt, []), [TInt(IULongLong, [])], false); + "__builtin_cls", + (TInt(IInt, []), [TInt(IInt, [])], false); + "__builtin_clsl", + (TInt(IInt, []), [TInt(ILong, [])], false); + "__builtin_clsll", + (TInt(IInt, []), [TInt(ILongLong, [])], false); + (* Float arithmetic *) + "__builtin_fmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fnmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fnmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fmax", + (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmin", + (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); + ] +} + +(* Expand memory references inside extended asm statements. Used in C2C. *) + +let asm_mem_argument arg = Printf.sprintf "[%s]" arg diff --git a/aarch64/CombineOp.v b/aarch64/CombineOp.v new file mode 100644 index 00000000..4d78c9a0 --- /dev/null +++ b/aarch64/CombineOp.v @@ -0,0 +1,137 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Recognition of combined operations, addressing modes and conditions + during the [CSE] phase. *) + +Require Import Coqlib. +Require Import AST 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 (Oaddlimm m) ys) => + Some(Aindexed (Int64.add m n), ys) + | _ => 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/aarch64/CombineOpproof.v b/aarch64/CombineOpproof.v new file mode 100644 index 00000000..7d13b964 --- /dev/null +++ b/aarch64/CombineOpproof.v @@ -0,0 +1,161 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import FunInd. +Require Import Coqlib. +Require Import AST Integers Values Memory. +Require Import Op Registers 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 - addimml *) + UseGetSound. simpl. rewrite <- H0. rewrite Val.addl_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/aarch64/ConstpropOp.vp b/aarch64/ConstpropOp.vp new file mode 100644 index 00000000..c0a2c6bf --- /dev/null +++ b/aarch64/ConstpropOp.vp @@ -0,0 +1,401 @@ +(* *********************************************************************) +(* *) +(* 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 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 ValueAOp. + +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | L n => Some(Olongconst n) + | 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 *) + +Definition eval_static_shift (s: shift) (v: int) (n: amount32) : int := + match s with + | Slsl => Int.shl v n + | Slsr => Int.shru v n + | Sasr => Int.shr v n + | Sror => Int.ror v n + end. + +Definition eval_static_shiftl (s: shift) (v: int64) (n: amount64) : int64 := + match s with + | Slsl => Int64.shl' v n + | Slsr => Int64.shru' v n + | Sasr => Int64.shr' v n + | Sror => Int64.ror v (Int64.repr (Int.unsigned n)) + end. + +Definition eval_static_extend (x: extension) (v: int) (n: amount64) : int64 := + Int64.shl' (match x with Xsgn32 => Int64.repr (Int.signed v) + | Xuns32 => Int64.repr (Int.unsigned v) end) + n. + +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) + | Ccompshift c s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c (eval_static_shift s n2 a), r1 :: nil) + | Ccompushift c s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c (eval_static_shift s n2 a), 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) + | Ccomplshift c s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccomplimm c (eval_static_shiftl s n2 a), r1 :: nil) + | Ccomplushift c s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccompluimm c (eval_static_shiftl s n2 a), r1 :: nil) + | Ccompf c, r1 :: r2 :: nil, F n1 :: v2 :: nil => + if Float.eq_dec n1 Float.zero + then (Ccompfzero (swap_comparison c), r2 :: nil) + else (cond, args) + | Ccompf c, r1 :: r2 :: nil, v1 :: F n2 :: nil => + if Float.eq_dec n2 Float.zero + then (Ccompfzero c, r1 :: nil) + else (cond, args) + | Cnotcompf c, r1 :: r2 :: nil, F n1 :: v2 :: nil => + if Float.eq_dec n1 Float.zero + then (Cnotcompfzero (swap_comparison c), r2 :: nil) + else (cond, args) + | Cnotcompf c, r1 :: r2 :: nil, v1 :: F n2 :: nil => + if Float.eq_dec n2 Float.zero + then (Cnotcompfzero c, r1 :: nil) + else (cond, args) + | Ccompfs c, r1 :: r2 :: nil, FS n1 :: v2 :: nil => + if Float32.eq_dec n1 Float32.zero + then (Ccompfszero (swap_comparison c), r2 :: nil) + else (cond, args) + | Ccompfs c, r1 :: r2 :: nil, v1 :: FS n2 :: nil => + if Float32.eq_dec n2 Float32.zero + then (Ccompfszero c, r1 :: nil) + else (cond, args) + | Cnotcompfs c, r1 :: r2 :: nil, FS n1 :: v2 :: nil => + if Float32.eq_dec n1 Float32.zero + then (Cnotcompfszero (swap_comparison c), r2 :: nil) + else (cond, args) + | Cnotcompfs c, r1 :: r2 :: nil, v1 :: FS n2 :: nil => + if Float32.eq_dec n2 Float32.zero + then (Cnotcompfszero c, r1 :: nil) + else (cond, args) + | _, _, _ => + (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_select (c: condition) (ty: typ) + (r1 r2: reg) (args: list reg) (vl: list aval) := + match resolve_branch (eval_static_condition c vl) with + | Some b => (Omove, (if b then r1 else r2) :: nil) + | None => + let (c', args') := cond_strength_reduction c args vl in + (Osel c' ty, r1 :: r2 :: args') + end. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshift Slsl (mk_amount32 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 (Oshift Sasr (mk_amount32 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 (Oshift Slsr (mk_amount32 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 => (Oshift Slsl (mk_amount32 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 => (Oshift Slsr (mk_amount32 l), r1 :: nil) + | None => (Odivu, 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 (Oshiftl Slsl (mk_amount64 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 (Oshiftl Sasr (mk_amount64 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 (Oshiftl Slsr (mk_amount64 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 => (Oshiftl Slsl (mk_amount64 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 (Oshrlximm 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 => (Oshiftl Slsr (mk_amount64 l), r1 :: nil) + | None => (Odivlu, 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_zext (s: Z) (r: reg) (a: aval) := + if vincl a (Uns Ptop s) then (Omove, r :: nil) else (Ozext s, r :: nil). + +Definition make_sext (s: Z) (r: reg) (a: aval) := + if vincl a (Sgn Ptop s) then (Omove, r :: nil) else (Osext s, r :: nil). + +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list aval) := + match op, args, vl with + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Oaddshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (eval_static_shift s n2 a) r1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Osubshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg (eval_static_shift s n2 a)) 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 + | 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 + | Oandshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (eval_static_shift s n2 a) 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 + | Oorshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm (eval_static_shift s n2 a) 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 + | Oxorshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm (eval_static_shift s n2 a) r1 + | Obic, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (Int.not n2) r1 v1 + | Obicshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (Int.not (eval_static_shift s n2 a)) r1 v1 + | Oorn, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm (Int.not n2) r1 + | Oornshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm (Int.not (eval_static_shift s n2 a)) r1 + | Oeqv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm (Int.not n2) r1 + | Oeqvshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm (Int.not (eval_static_shift s n2 a)) 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 + | Ozext s, r1 :: nil, v1 :: nil => make_zext s r1 v1 + | Osext s, r1 :: nil, v1 :: nil => make_sext s r1 v1 + + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 + | Oaddlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (eval_static_shiftl s n2 a) r1 + | Oaddlext x a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addlimm (eval_static_extend x n2 a) r1 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 + | Osublshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg (eval_static_shiftl s n2 a)) r1 + | Osublext x a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addlimm (Int64.neg (eval_static_extend x n2 a)) 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 + | 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 + | Oandlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm (eval_static_shiftl s n2 a) 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 + | Oorlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm (eval_static_shiftl s n2 a) 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 + | Oxorlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm (eval_static_shiftl s n2 a) r1 + | Obicl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm (Int64.not n2) r1 v1 + | Obiclshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm (Int64.not (eval_static_shiftl s n2 a)) r1 v1 + | Oornl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm (Int64.not n2) r1 + | Oornlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm (Int64.not (eval_static_shiftl s n2 a)) r1 + | Oeqvl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm (Int64.not n2) r1 + | Oeqvlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm (Int64.not (eval_static_shiftl s n2 a)) 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 + | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 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 => + (Aglobal symb (Ptrofs.add n1 (Ptrofs.of_int64 n)), nil) + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 n)), nil) + | Aindexed2, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil => + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 n2)), nil) + | Aindexed2, r1 :: r2 :: nil, L n1 :: Ptr(Stk n2) :: nil => + (Ainstack (Ptrofs.add (Ptrofs.of_int64 n1) n2), nil) + | Aindexed2, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Aindexed n1, r2 :: nil) + | Aindexed2, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Aindexed n2, r1 :: nil) + | Aindexed2shift a, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil => + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 (Int64.shl' n2 a))), nil) + | Aindexed2shift a, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Aindexed (Int64.shl' n2 a), r1 :: nil) + | Aindexed2ext x a, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => + (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 (eval_static_extend x n2 a))), nil) + | Aindexed2ext x a, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Aindexed (eval_static_extend x n2 a), r1 :: nil) + | _, _, _ => + (addr, args) + end. + diff --git a/aarch64/ConstpropOpproof.v b/aarch64/ConstpropOpproof.v new file mode 100644 index 00000000..deab7cd4 --- /dev/null +++ b/aarch64/ConstpropOpproof.v @@ -0,0 +1,838 @@ +(* *********************************************************************) +(* *) +(* 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 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 ValueAOp ValueAnalysis. +Require Import ConstpropOp. + +Local Transparent Archi.ptr64. + +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; intros; destruct a; inv H; SimplVM. +- (* integer *) + exists (Vint n); auto. +- (* long *) + 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 eval_static_shift_correct: forall s v a, + eval_shift s (Vint v) a = Vint (eval_static_shift s v a). +Proof. + intros; destruct s; simpl; rewrite ? a32_range; auto. +Qed. + +Lemma eval_static_shiftl_correct: forall s v a, + eval_shiftl s (Vlong v) a = Vlong (eval_static_shiftl s v a). +Proof. + intros; destruct s; simpl; rewrite ? a64_range; auto. +Qed. + +Lemma eval_static_extend_correct: forall x v a, + eval_extend x (Vint v) a = Vlong (eval_static_extend x v a). +Proof. + unfold eval_extend, eval_static_extend; intros; destruct x; simpl; rewrite ? a64_range; 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. +- rewrite eval_static_shift_correct; auto. +- rewrite eval_static_shift_correct; auto. +- apply Val.swap_cmpl_bool. +- auto. +- apply Val.swap_cmplu_bool. +- auto. +- rewrite eval_static_shiftl_correct; auto. +- rewrite eval_static_shiftl_correct; auto. +- destruct (Float.eq_dec n1 Float.zero). + subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float.cmp_swap. auto. + simpl. rewrite H1; auto. +- destruct (Float.eq_dec n2 Float.zero). + subst n2. simpl. auto. + simpl. rewrite H1; auto. +- destruct (Float.eq_dec n1 Float.zero). + subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float.cmp_swap. auto. + simpl. rewrite H1; auto. +- destruct (Float.eq_dec n2 Float.zero); simpl; auto. + subst n2; auto. + rewrite H1; auto. +- destruct (Float32.eq_dec n1 Float32.zero). + subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float32.cmp_swap. auto. + simpl. rewrite H1; auto. +- destruct (Float32.eq_dec n2 Float32.zero). + subst n2. simpl. auto. + simpl. rewrite H1; auto. +- destruct (Float32.eq_dec n1 Float32.zero). + subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float32.cmp_swap. auto. + simpl. rewrite H1; auto. +- destruct (Float32.eq_dec n2 Float32.zero); simpl; auto. + subst n2; auto. + rewrite H1; 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_select_correct: + forall c ty r1 r2 args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_select c ty r1 r2 args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.select (eval_condition c e##args m) e#r1 e#r2 ty) v. +Proof. + unfold make_select; intros. + destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB. +- exists (if b then e#r1 else e#r2); split. ++ simpl. destruct b; auto. ++ destruct (eval_condition c e##args m) as [b'|] eqn:EC; simpl; auto. + assert (b = b'). + { eapply resolve_branch_sound; eauto. + rewrite <- EC. apply eval_static_condition_sound with bc. + subst vl. exact (aregs_sound _ _ _ args MATCH). } + subst b'. apply Val.lessdef_normalize. +- generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ. + econstructor; split. simpl; eauto. rewrite EQ; 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; rewrite ?Int.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. +Local Opaque mk_amount32. + 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) eqn:L. + econstructor; split. simpl. eauto. rewrite mk_amount32_eq; 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) eqn:L. + econstructor; split. simpl. eauto. rewrite mk_amount32_eq; 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) eqn:L. + econstructor; split. simpl. eauto. rewrite mk_amount32_eq; 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. + rewrite mk_amount32_eq; auto. eapply Int.is_power2_range; eauto. + econstructor; split; eauto. simpl. rewrite H; auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + destruct (Int.ltu i (Int.repr 31)) eqn:?. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + econstructor; split. simpl; eauto. + rewrite mk_amount32_eq by (eapply Int.is_power2_range; eauto). + rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. + 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. +Local Opaque mk_amount64. + 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') eqn:L. + econstructor; split. simpl. eauto. rewrite mk_amount64_eq; 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') eqn:L. + econstructor; split. simpl. eauto. rewrite mk_amount64_eq; 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') eqn:L. + econstructor; split. simpl. eauto. rewrite mk_amount64_eq; 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. + econstructor; split. simpl; eauto. + rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; eauto). + destruct (e#r1); simpl; auto. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.mul_pow2' by eauto. auto. + econstructor; split; eauto. simpl; rewrite H; auto. +Qed. + +Lemma make_divlimm_correct: + forall n r1 r2 v, + Val.divls e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divlimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divlimm. + destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. + rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divluimm_correct: + forall n r1 r2 v, + Val.divlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divluimm. + destruct (Int64.is_power2' n) eqn:?. + econstructor; split. simpl; eauto. + rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; 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_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_zext_correct: + forall s r x, + vmatch bc e#r x -> + let (op, args) := make_zext s r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext s e#r) v. +Proof. + intros; unfold make_zext. destruct (vincl x (Uns Ptop s)) eqn:INCL. +- exists e#r; split; auto. + assert (V: vmatch bc e#r (Uns Ptop s)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto. +- econstructor; split; simpl; eauto. +Qed. + +Lemma make_sext_correct: + forall s r x, + vmatch bc e#r x -> + let (op, args) := make_sext s r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext s e#r) v. +Proof. + intros; unfold make_sext. destruct (vincl x (Sgn Ptop s)) eqn:INCL. +- exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop s)). + { 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. +- (* 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. +- (* addshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_addimm_correct; auto. +- (* sub *) + InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. +- (* subshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct, 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. +- (* 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. +- (* andshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. 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. +- (* orshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. 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. +- (* xorshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_xorimm_correct; auto. +- (* bic *) + InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. +- (* bicshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_andimm_correct; auto. +- (* orn *) + InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +- (* ornshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_orimm_correct; auto. +- (* eor *) + InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +- (* eorshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. 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. +- (* zext *) + InvApproxRegs; SimplVM; inv H0. apply make_zext_correct; auto. +- (* sext *) + InvApproxRegs; SimplVM; inv H0. apply make_sext_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. +- (* addshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_addlimm_correct; auto. +- (* addext *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_extend_correct. apply make_addlimm_correct; auto. +- (* subl *) + InvApproxRegs; SimplVM; inv H0. rewrite Val.subl_addl_opp. apply make_addlimm_correct; auto. +- (* sublshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct, Val.subl_addl_opp. apply make_addlimm_correct; auto. +- (* sublextend *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_extend_correct, Val.subl_addl_opp. apply make_addlimm_correct; 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. +- (* 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. +- (* andlshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. 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. +- (* orlshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. 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. +- (* xorlshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_xorlimm_correct; auto. +- (* bicl *) + InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. +- (* biclshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_andlimm_correct; auto. +- (* ornl *) + InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +- (* ornlshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_orlimm_correct; auto. +- (* eorl *) + InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +- (* eorlshift *) + InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. 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. +- (* select *) + inv H0. apply make_select_correct; congruence. +- (* 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). +- econstructor; split; eauto. inv H0; simpl; auto. rewrite H2. + unfold Genv.symbol_address. destruct (Genv.find_symbol ge symb); auto. +- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. + inv H0; auto. rewrite H2; auto. +- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. + inv H; auto. rewrite H3; auto. +- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. + inv H0; auto. rewrite H3. rewrite Ptrofs.add_commut; auto. +- econstructor; split; eauto. rewrite Val.addl_commut. auto. +- econstructor; split; eauto. +- rewrite Ptrofs.add_zero_l. rewrite a64_range. econstructor; split; eauto. + inv H; auto. rewrite H3; auto. +- rewrite a64_range. econstructor; split; eauto. +- rewrite Ptrofs.add_zero_l, eval_static_extend_correct. + econstructor; split; eauto. inv H; auto. rewrite H3; auto. +- rewrite eval_static_extend_correct. + econstructor; split; eauto. +- exists res; auto. +Qed. + +End STRENGTH_REDUCTION. diff --git a/aarch64/Conventions1.v b/aarch64/Conventions1.v new file mode 100644 index 00000000..5914e8f2 --- /dev/null +++ b/aarch64/Conventions1.v @@ -0,0 +1,380 @@ +(* *********************************************************************) +(* *) +(* 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 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 Events Locations. +Require Archi. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in: +- 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 Procedure Call Standard for the ARM 64-bit Architecture + (AArch64) document: R19-R28 and F8-F15 are callee-save. *) + +Definition is_callee_save (r: mreg): bool := + match r with + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 => false + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => false + | R17 => false + | R19 | R20 | R21 | R22 | R23 => true + | R24 | R25 | R26 | R27 | R28 => true + | R29 => false + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 => false + | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 => true + | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 => false + | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => false + end. + +Definition int_caller_save_regs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 + :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15 + :: R17 :: R29 :: nil. + +Definition float_caller_save_regs := + F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 + :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: F23 + :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil. + +Definition int_callee_save_regs := + R19 :: R20 :: R21 :: R22 :: R23 + :: R24 :: R25 :: R26 :: R27 :: R28 :: nil. + +Definition float_callee_save_regs := + F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: nil. + +Definition destroyed_at_call := + List.filter (fun r => negb (is_callee_save r)) all_mregs. + +Definition dummy_int_reg := R0. (**r Used in [Coloring]. *) +Definition dummy_float_reg := F0. (**r Used in [Coloring]. *) + +Definition callee_save_type := mreg_type. + +Definition is_float_reg (r: mreg): bool := + match r with + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 + | R17 | R19 | R20 | R21 | R22 | R23 + | R24 | R25 | R26 | R27 | R28 + | R29 => false + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 + | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 + | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 + | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => true + end. + +(** * Function calling conventions *) + +(** The functions in this section determine the locations (machine registers + and stack slots) used to communicate arguments and results between the + caller and the callee during function calls. These locations are functions + of the signature of the function and of the call instruction. + Agreement between the caller and the callee on the locations to use + is guaranteed by our dynamic semantics for Cminor and RTL, which demand + that the signature of the call instruction is identical to that of the + called function. + + Calling conventions are largely arbitrary: they must respect the properties + proved in this section (such as no overlapping between the locations + of function arguments), but this leaves much liberty in choosing actual + locations. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R0] or [F0], depending on the type of the + returned value. We treat a function without result as a function + with one integer result. *) + +Definition loc_result (s: signature) : rpair mreg := + match s.(sig_res) with + | None => One R0 + | Some (Tint | Tlong | Tany32 | Tany64) => One R0 + | Some (Tfloat | Tsingle) => One F0 + 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. destruct (sig_res sig) as [[]|]; auto. +Qed. + +(** The result locations are caller-save registers *) + +Lemma loc_result_caller_save: + forall (s: signature), + forall_rpair (fun r => is_callee_save r = false) (loc_result s). +Proof. + intros. + unfold loc_result. destruct (sig_res s) as [[]|]; simpl; auto. +Qed. + +(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) + +Lemma loc_result_pair: + forall sg, + match loc_result sg with + | One _ => True + | Twolong r1 r2 => + r1 <> r2 /\ sg.(sig_res) = Some Tlong + /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + /\ Archi.ptr64 = false + end. +Proof. + intros; unfold loc_result; destruct (sig_res sg) as [[]|]; exact I. +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 first 8 integer arguments are passed in registers [R0...R7]. +- The first 8 FP arguments are passed in registers [F0...F7]. +- Extra arguments are passed on the stack, in [Outgoing] slots of size + 64 bits (2 words), consecutively assigned, starting at word offset 0. +**) + +Definition int_param_regs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: nil. + +Definition float_param_regs := + F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: nil. + +Fixpoint loc_arguments_rec + (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | (Tint | Tlong | Tany32 | Tany64) as ty :: tys => + match list_nth_z int_param_regs ir with + | None => + One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + 2) + | Some ireg => + One (R ireg) :: loc_arguments_rec tys (ir + 1) fr ofs + end + | (Tfloat | Tsingle) as ty :: tys => + match list_nth_z float_param_regs fr with + | None => + One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + 2) + | Some freg => + One (R freg) :: loc_arguments_rec tys ir (fr + 1) ofs + end + 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_args) 0 0 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Fixpoint size_arguments_rec (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z := + match tyl with + | nil => ofs + | (Tint | Tlong | Tany32 | Tany64) :: tys => + match list_nth_z int_param_regs ir with + | None => size_arguments_rec tys ir fr (ofs + 2) + | Some ireg => size_arguments_rec tys (ir + 1) fr ofs + end + | (Tfloat | Tsingle) :: tys => + match list_nth_z float_param_regs fr with + | None => size_arguments_rec tys ir fr (ofs + 2) + | Some freg => size_arguments_rec tys ir (fr + 1) ofs + end + end. + +Definition size_arguments (s: signature) : Z := + size_arguments_rec s.(sig_args) 0 0 0. + +(** Argument locations are either caller-save 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. + +Definition loc_argument_charact (ofs: Z) (l: loc) : Prop := + match l with + | R r => In r int_param_regs \/ In r float_param_regs + | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs') + | _ => False + end. + +Remark loc_arguments_rec_charact: + forall tyl ir fr ofs p, + In p (loc_arguments_rec tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_charact ofs) p. +Proof. + assert (X: forall ofs1 ofs2 l, loc_argument_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_charact ofs1 l). + { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_charact ofs1) p). + { destruct p; simpl; intuition eauto. } + assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). + { intros. apply Z.divide_add_r; auto. apply Z.divide_refl. } +Opaque list_nth_z. + induction tyl; simpl loc_arguments_rec; intros. +- contradiction. +- assert (A: forall ty, In p + match list_nth_z int_param_regs ir with + | Some ireg => One (R ireg) :: loc_arguments_rec tyl (ir + 1) fr ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_rec tyl ir fr (ofs + 2) + end -> + forall_rpair (loc_argument_charact ofs) p). + { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1. + subst. left. eapply list_nth_z_in; eauto. + eapply IHtyl; eauto. + subst. split. omega. assumption. + eapply Y; eauto. omega. } + assert (B: forall ty, In p + match list_nth_z float_param_regs fr with + | Some ireg => One (R ireg) :: loc_arguments_rec tyl ir (fr + 1) ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_rec tyl ir fr (ofs + 2) + end -> + forall_rpair (loc_argument_charact ofs) p). + { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1. + subst. right. eapply list_nth_z_in; eauto. + eapply IHtyl; eauto. + subst. split. omega. assumption. + eapply Y; eauto. omega. } + destruct a; eauto. +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. + assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by decide_goal. + assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal. + assert (X: forall l, loc_argument_charact 0 l -> loc_argument_acceptable l). + { unfold loc_argument_charact, loc_argument_acceptable. + destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto. + intros [C D]. split; auto. apply Z.divide_trans with 2; auto. + exists (2 / typealign ty); destruct ty; reflexivity. + } + exploit loc_arguments_rec_charact; eauto using Z.divide_0_r. + unfold forall_rpair; destruct p; intuition auto. +Qed. + +Hint Resolve loc_arguments_acceptable: locs. + +(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) + +Remark size_arguments_rec_above: + forall tyl ir fr ofs0, + ofs0 <= size_arguments_rec tyl ir fr ofs0. +Proof. + induction tyl; simpl; intros. + omega. + assert (A: ofs0 <= + match list_nth_z int_param_regs ir with + | Some _ => size_arguments_rec tyl (ir + 1) fr ofs0 + | None => size_arguments_rec tyl ir fr (ofs0 + 2) + end). + { destruct (list_nth_z int_param_regs ir); eauto. + apply Z.le_trans with (ofs0 + 2); auto. omega. } + assert (B: ofs0 <= + match list_nth_z float_param_regs fr with + | Some _ => size_arguments_rec tyl ir (fr + 1) ofs0 + | None => size_arguments_rec tyl ir fr (ofs0 + 2) + end). + { destruct (list_nth_z float_param_regs fr); eauto. + apply Z.le_trans with (ofs0 + 2); auto. omega. } + destruct a; auto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 0. +Proof. + intros; unfold size_arguments. apply Z.le_ge. apply size_arguments_rec_above. +Qed. + +Lemma loc_arguments_rec_bounded: + forall ofs ty tyl ir fr ofs0, + In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_rec tyl ir fr ofs0)) -> + ofs + typesize ty <= size_arguments_rec tyl ir fr ofs0. +Proof. + induction tyl; simpl; intros. +- contradiction. +- assert (T: forall ty0, typesize ty0 <= 2). + { destruct ty0; simpl; omega. } + assert (A: forall ty0, + In (S Outgoing ofs ty) (regs_of_rpairs + match list_nth_z int_param_regs ir with + | Some ireg => + One (R ireg) :: loc_arguments_rec tyl (ir + 1) fr ofs0 + | None => One (S Outgoing ofs0 ty0) :: loc_arguments_rec tyl ir fr (ofs0 + 2) + end) -> + ofs + typesize ty <= + match list_nth_z int_param_regs ir with + | Some _ => size_arguments_rec tyl (ir + 1) fr ofs0 + | None => size_arguments_rec tyl ir fr (ofs0 + 2) + end). + { intros. destruct (list_nth_z int_param_regs ir); simpl in H0; destruct H0. + - discriminate. + - eapply IHtyl; eauto. + - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_rec_above. + - eapply IHtyl; eauto. } + assert (B: forall ty0, + In (S Outgoing ofs ty) (regs_of_rpairs + match list_nth_z float_param_regs fr with + | Some ireg => + One (R ireg) :: loc_arguments_rec tyl ir (fr + 1) ofs0 + | None => One (S Outgoing ofs0 ty0) :: loc_arguments_rec tyl ir fr (ofs0 + 2) + end) -> + ofs + typesize ty <= + match list_nth_z float_param_regs fr with + | Some _ => size_arguments_rec tyl ir (fr + 1) ofs0 + | None => size_arguments_rec tyl ir fr (ofs0 + 2) + end). + { intros. destruct (list_nth_z float_param_regs fr); simpl in H0; destruct H0. + - discriminate. + - eapply IHtyl; eauto. + - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_rec_above. + - eapply IHtyl; eauto. } + destruct a; eauto. +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. + unfold loc_arguments, size_arguments; intros. + eauto using loc_arguments_rec_bounded. +Qed. + +Lemma loc_arguments_main: + loc_arguments signature_main = nil. +Proof. + unfold loc_arguments; reflexivity. +Qed. + diff --git a/aarch64/Machregs.v b/aarch64/Machregs.v new file mode 100644 index 00000000..b2a2308e --- /dev/null +++ b/aarch64/Machregs.v @@ -0,0 +1,210 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import String. +Require Import Coqlib Decidableplus Maps. +Require Import AST Op. + +(** ** Machine registers *) + +(** Integer register 16 is reserved as temporary and for call veeners. + Integer register 18 is reserved as the platform register. + Integer register 30 is reserved for the return address. *) + +Inductive mreg: Type := + (** Allocatable integer regs *) + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 + | R17 | R19 | R20 | R21 | R22 | R23 + | R24 | R25 | R26 | R27 | R28 | R29 + (** Allocatable floating-point regs *) + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 + | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 + | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 + | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31. + +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 + :: R17 :: R19 :: R20 :: R21 :: R22 :: R23 + :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 + :: F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 + :: F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 + :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: F23 + :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 + :: nil. + +Lemma all_mregs_complete: + forall (r: mreg), In r all_mregs. +Proof. + assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity). + intros. specialize (H r). InvBooleans. auto. +Qed. + +Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq. + +Instance Finite_mreg : Finite mreg := { + Finite_elements := all_mregs; + Finite_elements_spec := all_mregs_complete +}. + +Definition mreg_type (r: mreg): typ := 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 + | R17 => 17 | R19 => 19 + | R20 => 20 | R21 => 21 | R22 => 22 | R23 => 23 + | R24 => 24 | R25 => 25 | R26 => 26 | R27 => 27 + | R28 => 28 | R29 => 29 + | F0 => 32 | F1 => 33 | F2 => 34 | F3 => 35 + | F4 => 36 | F5 => 37 | F6 => 38 | F7 => 39 + | F8 => 40 | F9 => 41 | F10 => 42 | F11 => 43 + | F12 => 44 | F13 => 45 | F14 => 46 | F15 => 47 + | F16 => 48 | F17 => 49 | F18 => 50 | F19 => 51 + | F20 => 52 | F21 => 53 | F22 => 54 | F23 => 55 + | F24 => 56 | F25 => 57 | F26 => 58 | F27 => 59 + | F28 => 60 | F29 => 61 | F30 => 62 | F31 => 63 + 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 := + ("X0", R0) :: ("X1", R1) :: ("X2", R2) :: ("X3", R3) + :: ("X4", R4) :: ("X5", R5) :: ("X6", R6) :: ("X7", R7) + :: ("X8", R8) :: ("X9", R9) :: ("X10", R10) :: ("X11", R11) + :: ("X12", R12) :: ("X13", R13) :: ("X14", R14) :: ("X15", R15) + :: ("X17", R17) :: ("X19", R19) + :: ("X20", R20) :: ("X21", R21) :: ("X22", R22) :: ("X23", R23) + :: ("X24", R24) :: ("X25", R25) :: ("X26", R26) :: ("X27", R27) + :: ("X28", R28) :: ("X29", R29) + :: ("D0", F0) :: ("D1", F1) :: ("D2", F2) :: ("D3", F3) + :: ("D4", F4) :: ("D5", F5) :: ("D6", F6) :: ("D7", F7) + :: ("D8", F8) :: ("D9", F9) :: ("D10", F10) :: ("D11", F11) + :: ("D12", F12) :: ("D13", F13) :: ("D14", F14) :: ("D15", F15) + :: ("D16", F16) :: ("D17", F17) :: ("D18", F18) :: ("D19", F19) + :: ("D20", F20) :: ("D21", F21) :: ("D22", F22) :: ("D23", F23) + :: ("D24", F24) :: ("D25", F25) :: ("D26", F26) :: ("D27", F27) + :: ("D28", F28) :: ("D29", F29) :: ("D30", F30) :: ("D31", F31) + :: nil. + +Definition register_by_name (s: string) : option mreg := + let fix assoc (l: list (string * mreg)) : option mreg := + match l with + | nil => None + | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l' + end + in assoc register_names. + +(** ** Destroyed registers, preferred registers *) + +Definition destroyed_by_op (op: operation): list mreg := + match op with + | Oshrximm _ | Oshrlximm _ => R17 :: 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 := R17 :: 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_memcpy sz al => R15 :: R17 :: R29 :: nil + | EF_inline_asm txt sg clob => destroyed_by_clobber clob + | _ => nil + end. + +Definition destroyed_by_setstack (ty: typ): list mreg := nil. + +Definition destroyed_at_function_entry: list mreg := R29 :: nil. + +Definition destroyed_at_indirect_call: list mreg := nil. + +Definition temp_for_parent_frame: mreg := R29. + +Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := + (nil, None). + +Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := + (nil, nil). + +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 + destroyed_at_indirect_call + 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 is one for AArch64: [Olowlong], + which is actually a no-operation in the generated asm code. *) + +Definition two_address_op (op: operation) : bool := + match op with + | Olowlong => true + | _ => false + end. + +Global Opaque two_address_op. + +(* Constraints on constant propagation for builtins *) + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | 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/aarch64/Machregsaux.ml b/aarch64/Machregsaux.ml new file mode 100644 index 00000000..d7f10b9b --- /dev/null +++ b/aarch64/Machregsaux.ml @@ -0,0 +1,35 @@ +(* *********************************************************************) +(* *) +(* 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 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 s = + s = "X16" || s = "x16" || s = "X30" || s = "x30" + + +let name_of_register r = + try Some (Hashtbl.find register_names r) with Not_found -> None + +let register_by_name s = + Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) + +let can_reserve_register r = Conventions1.is_callee_save r diff --git a/aarch64/NeedOp.v b/aarch64/NeedOp.v new file mode 100644 index 00000000..8fcab9e1 --- /dev/null +++ b/aarch64/NeedOp.v @@ -0,0 +1,253 @@ +(* *********************************************************************) +(* *) +(* 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 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 AArch64 operators *) + +Definition needs_of_shift (s: shift) (a: amount32) (nv: nval) := + match s with + | Slsl => shlimm nv a + | Sasr => shrimm nv a + | Slsr => shruimm nv a + | Sror => ror nv a + end. + +Definition zero_ext' (s: Z) (nv: nval) := + if zle 0 s then zero_ext s nv else default nv. +Definition sign_ext' (s: Z) (nv: nval) := + if zlt 0 s then sign_ext s nv else default nv. + +Definition op1 (nv: nval) := nv :: nil. +Definition op2 (nv: nval) := nv :: nv :: nil. +Definition op1shift (s: shift) (a: amount32) (nv: nval) := + needs_of_shift s a nv :: nil. +Definition op2shift (s: shift) (a: amount32) (nv: nval) := + nv :: needs_of_shift s a nv :: nil. + +Definition needs_of_condition (cond: condition): list nval := nil. + +Definition needs_of_operation (op: operation) (nv: nval): list nval := + match op with + | Omove => nv :: nil + | Ointconst _ => nil + | Olongconst _ => nil + | Ofloatconst _ => nil + | Osingleconst _ => nil + | Oaddrsymbol _ _ => nil + | Oaddrstack _ => nil + | Oshift s a => op1shift s a nv + | Oadd | Osub | Omul => op2 (modarith nv) + | Oaddshift s a | Osubshift s a => op2shift s a (modarith nv) + | Oaddimm _ => op1 (modarith nv) + | Oneg => op1 (modarith nv) + | Onegshift s a => op1shift s a (modarith nv) + | Omuladd | Omulsub => + let n := modarith nv in n :: n :: n :: nil + | Odiv | Odivu => op2 (default nv) + | Oand | Oor | Oxor => op2 (bitwise nv) + | Oandshift s a | Oorshift s a | Oxorshift s a => op2shift s a (bitwise nv) + | Oandimm n => op1 (andimm nv n) + | Oorimm n => op1 (orimm nv n) + | Oxorimm n => op1 (bitwise nv) + | Onot => op1 (bitwise nv) + | Onotshift s a => needs_of_shift s a (bitwise nv) :: nil + | Obic | Oorn | Oeqv => + let n := bitwise nv in n :: bitwise n :: nil + | Obicshift s a | Oornshift s a | Oeqvshift s a => + let n := bitwise nv in n :: needs_of_shift s a (bitwise n) :: nil + | Oshl | Oshr | Oshru => op2 (default nv) + | Oshrximm _ => op1 (default nv) + | Ozext s => op1 (zero_ext' s nv) + | Osext s => op1 (sign_ext' s nv) + | Oshlzext s a => op1 (zero_ext' s (shlimm nv a)) + | Oshlsext s a => op1 (sign_ext' s (shlimm nv a)) + | Ozextshr a s => op1 (shruimm (zero_ext' s nv) a) + | Osextshr a s => op1 (shrimm (sign_ext' s nv) a) + + | Oshiftl _ _ | Oextend _ _ => op1 (default nv) + | Omakelong | Olowlong | Ohighlong => op1 (default nv) + | Oaddl | Osubl | Omull => op2 (default nv) + | Oaddlshift _ _ | Oaddlext _ _ | Osublshift _ _ | Osublext _ _ => op2 (default nv) + | Oaddlimm _ => op1 (default nv) + | Onegl => op1 (default nv) + | Oneglshift _ _ => op1 (default nv) + | Omulladd | Omullsub => let n := default nv in n :: n :: n :: nil + | Omullhs | Omullhu | Odivl | Odivlu => op2 (default nv) + | Oandl | Oorl | Oxorl | Obicl | Oornl | Oeqvl => op2 (default nv) + | Oandlshift _ _ | Oorlshift _ _ | Oxorlshift _ _ + | Obiclshift _ _ | Oornlshift _ _ | Oeqvlshift _ _ => op2 (default nv) + | Oandlimm _ | Oorlimm _ | Oxorlimm _ => op1 (default nv) + | Onotl => op1 (default nv) + | Onotlshift _ _ => op1 (default nv) + | Oshll | Oshrl | Oshrlu => op2 (default nv) + | Oshrlximm _ => op1 (default nv) + | Ozextl _ | Osextl _ + | Oshllzext _ _ | Oshllsext _ _ | Ozextshrl _ _ | Osextshrl _ _ => op1 (default nv) + | Onegf | Oabsf => op1 (default nv) + | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) + | Onegfs | Oabsfs => op1 (default nv) + | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) + | Ofloatofsingle | Osingleoffloat => op1 (default nv) + | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => op1 (default nv) + | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) + | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) + | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) + | Ocmp c => needs_of_condition c + | Osel c ty => nv :: nv :: needs_of_condition c + end. + +Definition operation_is_redundant (op: operation) (nv: nval): bool := + match op with + | Ozext s => zle 0 s && zero_ext_redundant s nv + | Osext s => zlt 0 s && sign_ext_redundant s 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. + +Lemma shift_sound: + forall v w s a x, + vagree v w (needs_of_shift s a x) -> + vagree (eval_shift s v a) (eval_shift s w a) x. +Proof. + intros until x; destruct s; simpl; intros. +- apply shlimm_sound; auto. +- apply shruimm_sound; auto. +- apply shrimm_sound; auto. +- apply ror_sound; auto. +Qed. + +Lemma zero_ext'_sound: + forall v w x n, + vagree v w (zero_ext' n x) -> + vagree (Val.zero_ext n v) (Val.zero_ext n w) x. +Proof. + unfold zero_ext'; intros. destruct (zle 0 n). +- apply zero_ext_sound; auto. +- assert (E: x = Nothing \/ Val.lessdef v w) by (destruct x; auto). + destruct E. subst x; simpl; auto. apply vagree_lessdef; apply Val.zero_ext_lessdef; auto. +Qed. + +Lemma sign_ext'_sound: + forall v w x n, + vagree v w (sign_ext' n x) -> + vagree (Val.sign_ext n v) (Val.sign_ext n w) x. +Proof. + unfold sign_ext'; intros. destruct (zlt 0 n). +- apply sign_ext_sound; auto. +- assert (E: x = Nothing \/ Val.lessdef v w) by (destruct x; auto). + destruct E. subst x; simpl; auto. apply vagree_lessdef; apply Val.sign_ext_lessdef; auto. +Qed. + +Section SOUNDNESS. + +Variable ge: genv. +Variable sp: block. +Variables m m': mem. +Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p. + +Lemma needs_of_condition_sound: + forall cond args b args', + eval_condition cond args m = Some b -> + vagree_list args args' (needs_of_condition cond) -> + eval_condition cond args' m' = Some b. +Proof. + intros. unfold needs_of_condition in H0. + eapply default_needs_of_condition_sound; eauto. +Qed. + +Lemma needs_of_operation_sound: + forall op args v nv args', + eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> + vagree_list args args' (needs_of_operation op nv) -> + nv <> Nothing -> + exists v', + eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' + /\ vagree v v' nv. +Proof. + unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); + simpl in *; FuncInv; InvAgree; TrivialExists. +- apply shift_sound; auto. +- apply add_sound; auto. +- apply add_sound; auto using shift_sound. +- apply add_sound; auto with na. +- apply neg_sound; auto. +- apply neg_sound; auto using shift_sound. +- apply sub_sound; auto. +- apply sub_sound; auto using shift_sound. +- apply mul_sound; auto. +- apply add_sound; auto. apply mul_sound; rewrite modarith_idem; auto. +- apply sub_sound; auto. apply mul_sound; rewrite modarith_idem; auto. +- apply and_sound; auto. +- apply and_sound; auto using shift_sound. +- apply andimm_sound; auto. +- apply or_sound; auto. +- apply or_sound; auto using shift_sound. +- apply orimm_sound; auto. +- apply xor_sound; auto. +- apply xor_sound; auto using shift_sound. +- apply xor_sound; auto with na. +- apply notint_sound; auto. +- apply notint_sound; auto using shift_sound. +- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto. +- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound. +- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto. +- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound. +- apply xor_sound; auto. apply notint_sound; rewrite bitwise_idem; auto. +- apply xor_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound. +- apply zero_ext'_sound; auto. +- apply sign_ext'_sound; auto. +- apply shlimm_sound; apply zero_ext'_sound; auto. +- apply shlimm_sound; apply sign_ext'_sound; auto. +- apply zero_ext'_sound; apply shruimm_sound; auto. +- apply sign_ext'_sound; apply shrimm_sound; auto. +- destruct (eval_condition cond args m) as [b|] eqn:EC. + erewrite needs_of_condition_sound by eauto. + apply select_sound; auto. + 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) m = Some v -> + vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> + vagree v arg1' nv. +Proof. + intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. +- apply andimm_redundant_sound; auto. +- apply orimm_redundant_sound; auto. +- InvBooleans. unfold zero_ext' in H5; rewrite zle_true in H5 by auto. + apply zero_ext_redundant_sound; auto. +- InvBooleans. unfold sign_ext' in H5; rewrite zlt_true in H5 by auto. + apply sign_ext_redundant_sound; auto. +Qed. + +End SOUNDNESS. diff --git a/aarch64/Op.v b/aarch64/Op.v new file mode 100644 index 00000000..34c03c77 --- /dev/null +++ b/aarch64/Op.v @@ -0,0 +1,1778 @@ +(* *********************************************************************) +(* *) +(* 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 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 Axioms Coqlib BoolEqual. +Require Import AST Integers Floats Values Memory Globalenvs Events. + +Set Implicit Arguments. +Local Transparent Archi.ptr64. + +(** Shift amounts *) + +Record amount32 : Type := { + a32_amount :> int; + a32_range : Int.ltu a32_amount Int.iwordsize = true }. + +Record amount64 : Type := { + a64_amount :> int; + a64_range : Int.ltu a64_amount Int64.iwordsize' = true }. + +(** Shifted operands *) + +Inductive shift : Type := + | Slsl (**r left shift *) + | Slsr (**r right unsigned shift *) + | Sasr (**r right signed shift *) + | Sror. (**r rotate right *) + +(** Sign- or zero-extended operands *) + +Inductive extension : Type := + | Xsgn32 (**r from signed 32-bit integer to 64-bit integer *) + | Xuns32. (**r from unsigned 32-bit integer to 64-bit integer *) + +(** Conditions (boolean-valued operators). *) + +Inductive condition: Type := +(** Tests over 32-bit integers *) + | Ccomp (c: comparison) (**r signed comparison *) + | Ccompu (c: comparison) (**r unsigned comparison *) + | Ccompimm (c: comparison) (n: int) (**r signed comparison with constant *) + | Ccompuimm (c: comparison) (n: int) (**r unsigned comparison with constant *) + | Ccompshift (c: comparison) (s: shift) (a: amount32) (**r signed comparison with shift *) + | Ccompushift (c: comparison) (s: shift) (a: amount32)(**r unsigned comparison width shift *) + | Cmaskzero (n: int) (**r test [(arg & n) == 0] *) + | Cmasknotzero (n: int) (**r test [(arg & n) != 0] *) +(** Tests over 64-bit integers *) + | Ccompl (c: comparison) (**r signed comparison *) + | Ccomplu (c: comparison) (**r unsigned comparison *) + | Ccomplimm (c: comparison) (n: int64) (**r signed comparison with constant *) + | Ccompluimm (c: comparison) (n: int64) (**r unsigned comparison with constant *) + | Ccomplshift (c: comparison) (s: shift) (a: amount64)(**r signed comparison with shift *) + | Ccomplushift (c: comparison) (s: shift) (a: amount64)(**r unsigned comparison width shift *) + | Cmasklzero (n: int64) (**r test [(arg & n) == 0] *) + | Cmasklnotzero (n: int64) (**r test [(arg & n) != 0] *) +(** Tests over 64-bit floating-point numbers *) + | Ccompf (c: comparison) (**r FP comparison *) + | Cnotcompf (c: comparison) (**r negation of an FP comparison *) + | Ccompfzero (c: comparison) (**r comparison with 0.0 *) + | Cnotcompfzero (c: comparison) (**r negation of comparison with 0.0 *) +(** Tests over 32-bit floating-point numbers *) + | Ccompfs (c: comparison) (**r FP comparison *) + | Cnotcompfs (c: comparison) (**r negation of an FP comparison *) + | Ccompfszero (c: comparison) (**r equal to 0.0 *) + | Cnotcompfszero (c: comparison). (**r not equal to 0.0 *) + +(** 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 *) +(** 32-bit integer arithmetic *) + | Oshift (s: shift) (a: amount32) (**r shift or rotate by immediate quantity *) + | Oadd (**r [rd = r1 + r2] *) + | Oaddshift (s: shift) (a: amount32) (**r [rd = r1 + shifted r2] *) + | Oaddimm (n: int) (**r [rd = r1 + n] *) + | Oneg (**r [rd = - r1] *) + | Onegshift (s: shift) (a: amount32) (**r [rd = - shifted r1] *) + | Osub (**r [rd = r1 - r2] *) + | Osubshift (s: shift) (a: amount32) (**r [rd = r1 - shifted r2] *) + | Omul (**r [rd = r1 * r2] *) + | Omuladd (**r [rd = r1 + r2 * r3] *) + | Omulsub (**r [rd = r1 - r2 * r3] *) + | Odiv (**r [rd = r1 / r2] (signed) *) + | Odivu (**r [rd = r1 / r2] (unsigned) *) + | Oand (**r [rd = r1 & r2] *) + | Oandshift (s: shift) (a: amount32) (**r [rd = r1 & shifted r2] *) + | Oandimm (n: int) (**r [rd = r1 & n] *) + | Oor (**r [rd = r1 | r2] *) + | Oorshift (s: shift) (a: amount32) (**r [rd = r1 | shifted r2] *) + | Oorimm (n: int) (**r [rd = r1 | n] *) + | Oxor (**r [rd = r1 ^ r2] *) + | Oxorshift (s: shift) (a: amount32) (**r [rd = r1 ^ shifted r2] *) + | Oxorimm (n: int) (**r [rd = r1 ^ n] *) + | Onot (**r [rd = ~r1] *) + | Onotshift (s: shift) (a: amount32) (**r [rd = ~ shifted r1] *) + | Obic (**r [rd = r1 & ~r2] *) + | Obicshift (s: shift) (a: amount32) (**r [rd = r1 ^ ~ shifted r2] *) + | Oorn (**r [rd = r1 | ~r2] *) + | Oornshift (s: shift) (a: amount32) (**r [rd = r1 | ~ shifted r2] *) + | Oeqv (**r [rd = r1 ^ ~r2] *) + | Oeqvshift (s: shift) (a: amount32) (**r [rd = r1 | ~ shifted r2] *) + | Oshl (**r [rd = r1 << r2] *) + | Oshr (**r [rd = r1 >> r2] (signed) *) + | Oshru (**r [rd = r1 >> r2] (unsigned) *) + | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) + | Ozext (s: Z) (**r [rd = zero_ext(r1,s)] *) + | Osext (s: Z) (**r [rd = sign_ext(r1,s)] *) + | Oshlzext (s: Z) (a: amount32) (**r [rd = zero_ext(r1,s) << a] *) + | Oshlsext (s: Z) (a: amount32) (**r [rd = sign_ext(r1,s) << a] *) + | Ozextshr (a: amount32) (s: Z) (**r [rd = zero_ext(r1 >> a, s)] *) + | Osextshr (a: amount32) (s: Z) (**r [rd = sign_ext(r1 >> a, s)] *) +(** 64-bit integer arithmetic *) + | Oshiftl (s: shift) (a: amount64) (**r shift or rotate by immediate quantity *) + | Oextend (x: extension) (a: amount64) (**r convert from 32 to 64 bits and shift *) + | Omakelong (**r [rd = r1 << 32 | r2] *) + | Olowlong (**r [rd = low-word(r1)] *) + | Ohighlong (**r [rd = high-word(r1)] *) + | Oaddl (**r [rd = r1 + r2] *) + | Oaddlshift (s: shift) (a: amount64) (**r [rd = r1 + shifted r2] *) + | Oaddlext (x: extension) (a: amount64) (**r [rd = r1 + shifted, converted r2] *) + | Oaddlimm (n: int64) (**r [rd = r1 + n] *) + | Onegl (**r [rd = - r1] *) + | Oneglshift (s: shift) (a: amount64) (**r [rd = - shifted r1] *) + | Osubl (**r [rd = r1 - r2] *) + | Osublshift (s: shift) (a: amount64) (**r [rd = r1 - shifted r2] *) + | Osublext (x: extension) (a: amount64) (**r [rd = r1 - shifted, converted r2] *) + | Omull (**r [rd = r1 * r2] *) + | Omulladd (**r [rd = r1 + r2 * r3] *) + | Omullsub (**r [rd = r1 - r2 * r3] *) + | 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) *) + | Oandl (**r [rd = r1 & r2] *) + | Oandlshift (s: shift) (a: amount64) (**r [rd = r1 & shifted r2] *) + | Oandlimm (n: int64) (**r [rd = r1 & n] *) + | Oorl (**r [rd = r1 | r2] *) + | Oorlshift (s: shift) (a: amount64) (**r [rd = r1 | shifted r2] *) + | Oorlimm (n: int64) (**r [rd = r1 | n] *) + | Oxorl (**r [rd = r1 ^ r2] *) + | Oxorlshift (s: shift) (a: amount64) (**r [rd = r1 ^ shifted r2] *) + | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) + | Onotl (**r [rd = ~r1] *) + | Onotlshift (s: shift) (a: amount64) (**r [rd = ~ shifted r1] *) + | Obicl (**r [rd = r1 & ~r2] *) + | Obiclshift (s: shift) (a: amount64) (**r [rd = r1 ^ ~ shifted r2] *) + | Oornl (**r [rd = r1 | ~r2] *) + | Oornlshift (s: shift) (a: amount64) (**r [rd = r1 | ~ shifted r2] *) + | Oeqvl (**r [rd = r1 ^ ~r2] *) + | Oeqvlshift (s: shift) (a: amount64) (**r [rd = r1 | ~ shifted r2] *) + | Oshll (**r [rd = r1 << r2] *) + | Oshrl (**r [rd = r1 >> r2] (signed) *) + | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) + | Oshrlximm (n: int) (**r [rd = r1 / 2^n] (signed) *) + | Ozextl (s: Z) (**r [rd = zero_ext(r1,s)] *) + | Osextl (s: Z) (**r [rd = sign_ext(r1,s)] *) + | Oshllzext (s: Z) (a: amount64) (**r [rd = zero_ext(r1,s) << a] *) + | Oshllsext (s: Z) (a: amount64) (**r [rd = sign_ext(r1,s) << a] *) + | Ozextshrl (a: amount64) (s: Z) (**r [rd = zero_ext(r1 >> a, s)] *) + | Osextshrl (a: amount64) (s: Z) (**r [rd = sign_ext(r1 >> a, s)] *) +(** 64-bit 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] *) +(** 32-bit floating-point arithmetic *) + | Onegfs (**r [rd = - r1] *) + | Oabsfs (**r [rd = abs(r1)] *) + | Oaddfs (**r [rd = r1 + r2] *) + | Osubfs (**r [rd = r1 - r2] *) + | Omulfs (**r [rd = r1 * r2] *) + | Odivfs (**r [rd = r1 / r2] *) + | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) +(** Conversions between int and float *) + | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (**r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (**r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu (**r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (**r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (**r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (**r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (**r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (**r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (**r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) +(** Boolean tests *) + | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Osel (cond: condition) (ty: typ). (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *) + +(** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) + +Inductive addressing: Type := + | Aindexed (ofs: int64) (**r Address is [r1 + offset] *) + | Aindexed2 (**r Address is [r1 + r2] *) + | Aindexed2shift (a: amount64) (**r Address is [r1 + r2 << a] *) + | Aindexed2ext (x: extension) (a: amount64) (**r Address is [r1 + sign-or-zero-ext(r2) << a] *) + | Aglobal (id: ident) (ofs: ptrofs) (**r Address is [global + offset] *) + | Ainstack (ofs: ptrofs). (**r Address is [stack_pointer + offset] *) + +(** Comparison functions (used in modules [CSE] and [Allocation]). *) + +Definition eq_amount32 (x y: amount32): {x=y} + {x<>y}. +Proof. + destruct x as [x Px], y as [y Py]. + destruct (Int.eq_dec x y). +- subst y. assert (Px = Py) by (apply proof_irr). subst Py. left; auto. +- right; congruence. +Defined. + +Definition eq_amount64 (x y: amount64): {x=y} + {x<>y}. +Proof. + destruct x as [x Px], y as [y Py]. + destruct (Int.eq_dec x y). +- subst y. assert (Px = Py) by (apply proof_irr). subst Py. left; auto. +- right; congruence. +Defined. + +Definition eq_shift (x y: shift): {x=y} + {x<>y}. +Proof. + decide equality. +Defined. + +Definition eq_extension (x y: extension): {x=y} + {x<>y}. +Proof. + decide equality. +Defined. + +Definition eq_condition (x y: condition) : {x=y} + {x<>y}. +Proof. + assert (forall (x y: comparison), {x=y}+{x<>y}) by decide equality. + generalize Int.eq_dec Int64.eq_dec eq_shift eq_amount32 eq_amount64; intro. + decide equality. +Defined. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize ident_eq Int64.eq_dec Ptrofs.eq_dec eq_extension eq_amount64; intros. + decide equality. +Defined. + +Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. +Proof. + intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec + zeq ident_eq eq_shift eq_extension eq_amount32 eq_amount64 + typ_eq eq_condition; + decide equality. +Defined. + +(** Alternative: + +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 + zeq ident_eq eq_shift eq_extension eq_amount32 eq_amount64 + eq_condition typ_eq; boolean_equality. +Defined. + +Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. +Proof. + decidable_equality_from beq_operation. +Defined. +*) + +(** * 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_shift (s: shift) (v: val) (n: amount32) : val := + match s with + | Slsl => Val.shl v (Vint n) + | Slsr => Val.shru v (Vint n) + | Sasr => Val.shr v (Vint n) + | Sror => Val.ror v (Vint n) + end. + +Definition eval_shiftl (s: shift) (v: val) (n: amount64) : val := + match s with + | Slsl => Val.shll v (Vint n) + | Slsr => Val.shrlu v (Vint n) + | Sasr => Val.shrl v (Vint n) + | Sror => Val.rorl v (Vint n) + end. + +Definition eval_extend (x: extension) (v: val) (n: amount64) : val := + Val.shll + (match x with + | Xsgn32 => Val.longofint v + | Xuns32 => Val.longofintu v + end) + (Vint n). + +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) + | Ccompshift c s a, v1 :: v2 :: nil => Val.cmp_bool c v1 (eval_shift s v2 a) + | Ccompushift c s a, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (eval_shift s v2 a) + | Cmaskzero n, v1 :: nil => Val.cmp_bool Ceq (Val.and v1 (Vint n)) (Vint Int.zero) + | Cmasknotzero n, v1 :: nil => Val.cmp_bool Cne (Val.and v1 (Vint n)) (Vint Int.zero) + + | 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) + | Ccomplshift c s a, v1 :: v2 :: nil => Val.cmpl_bool c v1 (eval_shiftl s v2 a) + | Ccomplushift c s a, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (eval_shiftl s v2 a) + | Cmasklzero n, v1 :: nil => Val.cmpl_bool Ceq (Val.andl v1 (Vlong n)) (Vlong Int64.zero) + | Cmasklnotzero n, v1 :: nil => Val.cmpl_bool Cne (Val.andl v1 (Vlong n)) (Vlong Int64.zero) + + | 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) + | Ccompfzero c, v1 :: nil => Val.cmpf_bool c v1 (Vfloat Float.zero) + | Cnotcompfzero c, v1 :: nil => option_map negb (Val.cmpf_bool c v1 (Vfloat Float.zero)) + + | 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) + | Ccompfszero c, v1 :: nil => Val.cmpfs_bool c v1 (Vsingle Float32.zero) + | Cnotcompfszero c, v1 :: nil => option_map negb (Val.cmpfs_bool c v1 (Vsingle Float32.zero)) + + | _, _ => None + end. + +Definition eval_operation + (F V: Type) (genv: Genv.t F V) (sp: val) + (op: operation) (vl: list val) (m: mem): option val := + match op, vl with + | Omove, v1::nil => Some v1 + | Ointconst n, nil => Some (Vint n) + | Olongconst n, nil => Some (Vlong n) + | Ofloatconst n, nil => Some (Vfloat n) + | Osingleconst n, nil => Some (Vsingle n) + | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs) + | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs) + + | Oshift s a, v1 :: nil => Some (eval_shift s v1 a) + | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) + | Oaddshift s a, v1 :: v2 :: nil => Some (Val.add v1 (eval_shift s v2 a)) + | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) + | Oneg, v1 :: nil => Some (Val.neg v1) + | Onegshift s a, v1 :: nil => Some (Val.neg (eval_shift s v1 a)) + | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) + | Osubshift s a, v1 :: v2 :: nil => Some (Val.sub v1 (eval_shift s v2 a)) + | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) + | Omuladd, v1 :: v2 :: v3 :: nil => Some (Val.add v1 (Val.mul v2 v3)) + | Omulsub, v1 :: v2 :: v3 :: nil => Some (Val.sub v1 (Val.mul v2 v3)) + | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 + | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 + | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) + | Oandshift s a, v1 :: v2 :: nil => Some (Val.and v1 (eval_shift s v2 a)) + | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) + | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) + | Oorshift s a, v1 :: v2 :: nil => Some (Val.or v1 (eval_shift s v2 a)) + | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) + | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) + | Oxorshift s a, v1 :: v2 :: nil => Some (Val.xor v1 (eval_shift s v2 a)) + | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) + | Onot, v1 :: nil => Some (Val.notint v1) + | Onotshift s a, v1 :: nil => Some (Val.notint (eval_shift s v1 a)) + | Obic, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint v2)) + | Obicshift s a, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint (eval_shift s v2 a))) + | Oorn, v1 :: v2 :: nil => Some (Val.or v1 (Val.notint v2)) + | Oornshift s a, v1 :: v2 :: nil => Some (Val.or v1 (Val.notint (eval_shift s v2 a))) + | Oeqv, v1 :: v2 :: nil => Some (Val.xor v1 (Val.notint v2)) + | Oeqvshift s a, v1 :: v2 :: nil => Some (Val.xor v1 (Val.notint (eval_shift s v2 a))) + | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) + | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) + | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Ozext s, v1 :: nil => Some (Val.zero_ext s v1) + | Osext s, v1 :: nil => Some (Val.sign_ext s v1) + | Oshlzext s a, v1 :: nil => Some (Val.shl (Val.zero_ext s v1) (Vint a)) + | Oshlsext s a, v1 :: nil => Some (Val.shl (Val.sign_ext s v1) (Vint a)) + | Ozextshr a s, v1 :: nil => Some (Val.zero_ext s (Val.shru v1 (Vint a))) + | Osextshr a s, v1 :: nil => Some (Val.sign_ext s (Val.shr v1 (Vint a))) + + | Oshiftl s a, v1 :: nil => Some (eval_shiftl s v1 a) + | Oextend x a, v1 :: nil => Some (eval_extend x v1 a) + | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) + | Olowlong, v1::nil => Some (Val.loword v1) + | Ohighlong, v1::nil => Some (Val.hiword v1) + | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) + | Oaddlshift s a, v1 :: v2 :: nil => Some (Val.addl v1 (eval_shiftl s v2 a)) + | Oaddlext x a, v1 :: v2 :: nil => Some (Val.addl v1 (eval_extend x v2 a)) + | Oaddlimm n, v1 :: nil => Some (Val.addl v1 (Vlong n)) + | Onegl, v1 :: nil => Some (Val.negl v1) + | Oneglshift s a, v1 :: nil => Some (Val.negl (eval_shiftl s v1 a)) + | Osubl, v1 :: v2 :: nil => Some (Val.subl v1 v2) + | Osublshift s a, v1 :: v2 :: nil => Some (Val.subl v1 (eval_shiftl s v2 a)) + | Osublext x a, v1 :: v2 :: nil => Some (Val.subl v1 (eval_extend x v2 a)) + | Omull, v1 :: v2 :: nil => Some (Val.mull v1 v2) + | Omulladd, v1 :: v2 :: v3 :: nil => Some (Val.addl v1 (Val.mull v2 v3)) + | Omullsub, v1 :: v2 :: v3 :: nil => Some (Val.subl v1 (Val.mull v2 v3)) + | 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 + | Oandl, v1 :: v2 :: nil => Some (Val.andl v1 v2) + | Oandlshift s a, v1 :: v2 :: nil => Some (Val.andl v1 (eval_shiftl s v2 a)) + | Oandlimm n, v1 :: nil => Some (Val.andl v1 (Vlong n)) + | Oorl, v1 :: v2 :: nil => Some (Val.orl v1 v2) + | Oorlshift s a, v1 :: v2 :: nil => Some (Val.orl v1 (eval_shiftl s v2 a)) + | Oorlimm n, v1 :: nil => Some (Val.orl v1 (Vlong n)) + | Oxorl, v1 :: v2 :: nil => Some (Val.xorl v1 v2) + | Oxorlshift s a, v1 :: v2 :: nil => Some (Val.xorl v1 (eval_shiftl s v2 a)) + | Oxorlimm n, v1 :: nil => Some (Val.xorl v1 (Vlong n)) + | Onotl, v1 :: nil => Some (Val.notl v1) + | Onotlshift s a, v1 :: nil => Some (Val.notl (eval_shiftl s v1 a)) + | Obicl, v1 :: v2 :: nil => Some (Val.andl v1 (Val.notl v2)) + | Obiclshift s a, v1 :: v2 :: nil => Some (Val.andl v1 (Val.notl (eval_shiftl s v2 a))) + | Oornl, v1 :: v2 :: nil => Some (Val.orl v1 (Val.notl v2)) + | Oornlshift s a, v1 :: v2 :: nil => Some (Val.orl v1 (Val.notl (eval_shiftl s v2 a))) + | Oeqvl, v1 :: v2 :: nil => Some (Val.xorl v1 (Val.notl v2)) + | Oeqvlshift s a, v1 :: v2 :: nil => Some (Val.xorl v1 (Val.notl (eval_shiftl s v2 a))) + | Oshll, v1 :: v2 :: nil => Some (Val.shll v1 v2) + | Oshrl, v1 :: v2 :: nil => Some (Val.shrl v1 v2) + | Oshrlu, v1 :: v2 :: nil => Some (Val.shrlu v1 v2) + | Oshrlximm n, v1::nil => Val.shrxl v1 (Vint n) + | Ozextl s, v1 :: nil => Some (Val.zero_ext_l s v1) + | Osextl s, v1 :: nil => Some (Val.sign_ext_l s v1) + | Oshllzext s a, v1 :: nil => Some (Val.shll (Val.zero_ext_l s v1) (Vint a)) + | Oshllsext s a, v1 :: nil => Some (Val.shll (Val.sign_ext_l s v1) (Vint a)) + | Ozextshrl a s, v1 :: nil => Some (Val.zero_ext_l s (Val.shrlu v1 (Vint a))) + | Osextshrl a s, v1 :: nil => Some (Val.sign_ext_l s (Val.shrl v1 (Vint a))) + + | Onegf, v1::nil => Some (Val.negf v1) + | Oabsf, v1::nil => Some (Val.absf v1) + | Oaddf, v1::v2::nil => Some (Val.addf v1 v2) + | Osubf, v1::v2::nil => Some (Val.subf v1 v2) + | Omulf, v1::v2::nil => Some (Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some (Val.divf v1 v2) + + | Onegfs, v1::nil => Some (Val.negfs v1) + | Oabsfs, v1::nil => Some (Val.absfs v1) + | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) + | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2) + | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2) + | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) + + | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) + | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ointuoffloat, v1::nil => Val.intuoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ofloatofintu, v1::nil => Val.floatofintu v1 + | Ointofsingle, v1::nil => Val.intofsingle v1 + | Ointuofsingle, v1::nil => Val.intuofsingle v1 + | Osingleofint, v1::nil => Val.singleofint v1 + | Osingleofintu, v1::nil => Val.singleofintu v1 + | Olongoffloat, v1::nil => Val.longoffloat v1 + | Olonguoffloat, v1::nil => Val.longuoffloat v1 + | Ofloatoflong, v1::nil => Val.floatoflong v1 + | Ofloatoflongu, v1::nil => Val.floatoflongu v1 + | Olongofsingle, v1::nil => Val.longofsingle v1 + | Olonguofsingle, v1::nil => Val.longuofsingle v1 + | Osingleoflong, v1::nil => Val.singleoflong v1 + | Osingleoflongu, v1::nil => Val.singleoflongu v1 + + | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) + | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty) + | _, _ => None + end. + +Definition eval_addressing + (F V: Type) (genv: Genv.t F V) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, v1 :: nil => Some (Val.addl v1 (Vlong n)) + | Aindexed2, v1 :: v2 :: nil => Some (Val.addl v1 v2) + | Aindexed2shift a, v1 :: v2 :: nil => Some (Val.addl v1 (Val.shll v2 (Vint a))) + | Aindexed2ext x a, v1 :: v2 :: nil => Some (Val.addl v1 (eval_extend x v2 a)) + | 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 _ |- _ => + change Archi.ptr64 with true in H; simpl in H; 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 + | Ccompshift _ _ _ => Tint :: Tint :: nil + | Ccompushift _ _ _ => Tint :: Tint :: nil + | Cmaskzero _ => Tint :: nil + | Cmasknotzero _ => Tint :: nil + | Ccompl _ => Tlong :: Tlong :: nil + | Ccomplu _ => Tlong :: Tlong :: nil + | Ccomplimm _ _ => Tlong :: nil + | Ccompluimm _ _ => Tlong :: nil + | Ccomplshift _ _ _ => Tlong :: Tlong :: nil + | Ccomplushift _ _ _ => Tlong :: Tlong :: nil + | Cmasklzero _ => Tint :: nil + | Cmasklnotzero _ => Tint :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + | Ccompfzero _ => Tfloat :: nil + | Cnotcompfzero _ => Tfloat :: nil + | Ccompfs _ => Tsingle :: Tsingle :: nil + | Cnotcompfs _ => Tsingle :: Tsingle :: nil + | Ccompfszero _ => Tsingle :: nil + | Cnotcompfszero _ => 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) + + | Oshift _ _ => (Tint :: nil, Tint) + | Oadd => (Tint :: Tint :: nil, Tint) + | Oaddshift _ _ => (Tint :: Tint :: nil, Tint) + | Oaddimm _ => (Tint :: nil, Tint) + | Oneg => (Tint :: nil, Tint) + | Onegshift _ _ => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Osubshift _ _ => (Tint :: Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Omuladd => (Tint :: Tint :: Tint :: nil, Tint) + | Omulsub => (Tint :: Tint :: Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Oand => (Tint :: Tint :: nil, Tint) + | Oandshift _ _ => (Tint :: Tint :: nil, Tint) + | Oandimm _ => (Tint :: nil, Tint) + | Oor => (Tint :: Tint :: nil, Tint) + | Oorshift _ _ => (Tint :: Tint :: nil, Tint) + | Oorimm _ => (Tint :: nil, Tint) + | Oxor => (Tint :: Tint :: nil, Tint) + | Oxorshift _ _ => (Tint :: Tint :: nil, Tint) + | Oxorimm _ => (Tint :: nil, Tint) + | Onot => (Tint :: nil, Tint) + | Onotshift _ _ => (Tint :: nil, Tint) + | Obic => (Tint :: Tint :: nil, Tint) + | Obicshift _ _ => (Tint :: Tint :: nil, Tint) + | Oorn => (Tint :: Tint :: nil, Tint) + | Oornshift _ _ => (Tint :: Tint :: nil, Tint) + | Oeqv => (Tint :: Tint :: nil, Tint) + | Oeqvshift _ _ => (Tint :: Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | Ozext _ => (Tint :: nil, Tint) + | Osext _ => (Tint :: nil, Tint) + | Oshlzext _ _ => (Tint :: nil, Tint) + | Oshlsext _ _ => (Tint :: nil, Tint) + | Ozextshr _ _ => (Tint :: nil, Tint) + | Osextshr _ _ => (Tint :: nil, Tint) + + | Oshiftl _ _ => (Tlong :: nil, Tlong) + | Oextend _ _ => (Tint :: nil, Tlong) + | Omakelong => (Tint :: Tint :: nil, Tlong) + | Olowlong => (Tlong :: nil, Tint) + | Ohighlong => (Tlong :: nil, Tint) + | Oaddl => (Tlong :: Tlong :: nil, Tlong) + | Oaddlshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Oaddlext _ _ => (Tlong :: Tint :: nil, Tlong) + | Oaddlimm _ => (Tlong :: nil, Tlong) + | Onegl => (Tlong :: nil, Tlong) + | Oneglshift _ _ => (Tlong :: nil, Tlong) + | Osubl => (Tlong :: Tlong :: nil, Tlong) + | Osublshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Osublext _ _ => (Tlong :: Tint :: nil, Tlong) + | Omull => (Tlong :: Tlong :: nil, Tlong) + | Omulladd => (Tlong :: Tlong :: Tlong :: nil, Tlong) + | Omullsub => (Tlong :: Tlong :: Tlong :: nil, Tlong) + | Omullhs => (Tlong :: Tlong :: nil, Tlong) + | Omullhu => (Tlong :: Tlong :: nil, Tlong) + | Odivl => (Tlong :: Tlong :: nil, Tlong) + | Odivlu => (Tlong :: Tlong :: nil, Tlong) + | Oandl => (Tlong :: Tlong :: nil, Tlong) + | Oandlshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Oandlimm _ => (Tlong :: nil, Tlong) + | Oorl => (Tlong :: Tlong :: nil, Tlong) + | Oorlshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Oorlimm _ => (Tlong :: nil, Tlong) + | Oxorl => (Tlong :: Tlong :: nil, Tlong) + | Oxorlshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Oxorlimm _ => (Tlong :: nil, Tlong) + | Onotl => (Tlong :: nil, Tlong) + | Onotlshift _ _ => (Tlong :: nil, Tlong) + | Obicl => (Tlong :: Tlong :: nil, Tlong) + | Obiclshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Oornl => (Tlong :: Tlong :: nil, Tlong) + | Oornlshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Oeqvl => (Tlong :: Tlong :: nil, Tlong) + | Oeqvlshift _ _ => (Tlong :: Tlong :: nil, Tlong) + | Oshll => (Tlong :: Tint :: nil, Tlong) + | Oshrl => (Tlong :: Tint :: nil, Tlong) + | Oshrlu => (Tlong :: Tint :: nil, Tlong) + | Oshrlximm _ => (Tlong :: nil, Tlong) + | Ozextl _ => (Tlong :: nil, Tlong) + | Osextl _ => (Tlong :: nil, Tlong) + | Oshllzext _ _ => (Tlong :: nil, Tlong) + | Oshllsext _ _ => (Tlong :: nil, Tlong) + | Ozextshrl _ _ => (Tlong :: nil, Tlong) + | Osextshrl _ _ => (Tlong :: nil, Tlong) + + | Onegf => (Tfloat :: nil, Tfloat) + | Oabsf => (Tfloat :: nil, Tfloat) + | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) + | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) + | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) + | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) + + | Onegfs => (Tsingle :: nil, Tsingle) + | Oabsfs => (Tsingle :: nil, Tsingle) + | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osingleoffloat => (Tfloat :: nil, Tsingle) + | Ofloatofsingle => (Tsingle :: nil, Tfloat) + + | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ofloatofintu => (Tint :: nil, Tfloat) + | Ointofsingle => (Tsingle :: nil, Tint) + | Ointuofsingle => (Tsingle :: nil, Tint) + | Osingleofint => (Tint :: nil, Tsingle) + | Osingleofintu => (Tint :: nil, Tsingle) + | Olongoffloat => (Tfloat :: nil, Tlong) + | Olonguoffloat => (Tfloat :: nil, Tlong) + | Ofloatoflong => (Tlong :: nil, Tfloat) + | Ofloatoflongu => (Tlong :: nil, Tfloat) + | Olongofsingle => (Tsingle :: nil, Tlong) + | Olonguofsingle => (Tsingle :: nil, Tlong) + | Osingleoflong => (Tlong :: nil, Tsingle) + | Osingleoflongu => (Tlong :: nil, Tsingle) + + | Ocmp c => (type_of_condition c, Tint) + | Osel c ty => (ty :: ty :: type_of_condition c, ty) + end. + +Definition type_of_addressing (addr: addressing) : list typ := + match addr with + | Aindexed _ => Tptr :: nil + | Aindexed2 => Tptr :: Tlong :: nil + | Aindexed2shift _ => Tptr :: Tlong :: nil + | Aindexed2ext _ _ => Tptr :: Tint :: 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 v1, v2; simpl; auto. +Qed. + +Remark type_sub: + forall v1 v2, Val.has_type (Val.sub v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.add. destruct v1, v2; simpl; 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 v1, v2; simpl; auto. +Qed. + +Remark type_subl: + forall v1 v2, Val.has_type (Val.subl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.addl. destruct v1, v2; simpl; auto. + destruct (eq_block b b0); auto. +Qed. + +Lemma type_of_operation_sound: + forall op vl sp v m, + op <> Omove -> + eval_operation genv sp op vl m = Some v -> + Val.has_type v (snd (type_of_operation op)). +Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + intros. + destruct op; simpl; simpl in H0; FuncInv; subst; simpl. + (* move *) + - congruence. + (* intconst, longconst, floatconst, singleconst *) + - exact I. + - exact I. + - exact I. + - exact I. + (* addrsymbol *) + - unfold Genv.symbol_address. destruct (Genv.find_symbol genv id)... + (* addrstack *) + - destruct sp... + (* 32-bit integer operations *) + - destruct s, v0; try exact I; simpl; rewrite a32_range... + - apply type_add. + - apply type_add. + - apply type_add. + - destruct v0... + - destruct (eval_shift s v0 a)... + - apply type_sub. + - apply type_sub. + - destruct v0... destruct v1... + - apply type_add. + - apply type_sub. + - 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... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shift s v1 a)... + - destruct v0... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shift s v1 a)... + - destruct v0... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shift s v1 a)... + - destruct v0... + - destruct v0... + - destruct (eval_shift s v0 a)... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shift s v1 a)... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shift s v1 a)... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shift s v1 a)... + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + - destruct v0... + - destruct v0... + - destruct (Val.zero_ext s v0)... simpl; rewrite a32_range... + - destruct (Val.sign_ext s v0)... simpl; rewrite a32_range... + - destruct (Val.shru v0 (Vint a))... + - destruct (Val.shr v0 (Vint a))... + (* 64-bit integer operations *) + - destruct s, v0; try exact I; simpl; rewrite a64_range... + - unfold eval_extend. destruct (match x with + | Xsgn32 => Val.longofint v0 + | Xuns32 => Val.longofintu v0 + end)... + simpl; rewrite a64_range... + - destruct v0... destruct v1... + - destruct v0... + - destruct v0... + - apply type_addl. + - apply type_addl. + - apply type_addl. + - apply type_addl. + - destruct v0... + - destruct (eval_shiftl s v0 a)... + - apply type_subl. + - apply type_subl. + - apply type_subl. + - destruct v0... destruct v1... + - apply type_addl. + - apply type_subl. + - destruct v0... destruct v1... + - destruct v0... destruct v1... + - 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... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shiftl s v1 a)... + - destruct v0... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shiftl s v1 a)... + - destruct v0... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shiftl s v1 a)... + - destruct v0... + - destruct v0... + - destruct (eval_shiftl s v0 a)... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shiftl s v1 a)... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shiftl s v1 a)... + - destruct v0... destruct v1... + - destruct v0... destruct (eval_shiftl s v1 a)... + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... + - destruct v0... + - destruct v0... + - destruct (Val.zero_ext_l s v0)... simpl; rewrite a64_range... + - destruct (Val.sign_ext_l s v0)... simpl; rewrite a64_range... + - destruct (Val.shrlu v0 (Vint a))... + - destruct (Val.shrl v0 (Vint a))... + + (* 64-bit FP *) + - destruct v0... + - destruct v0... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* 32-bit FP *) + - destruct v0... + - destruct v0... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* singleoffloat, floatofsingle *) + - destruct v0... + - destruct v0... + (* intoffloat, intuoffloat *) + - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... + (* floatofint, floatofintu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* intofsingle, intuofsingle *) + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2... + (* singleofint, singleofintu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* longoffloat, longuoffloat *) + - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float.to_longu f); inv H2... + (* floatoflong, floatoflongu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* longofsingle, longuofsingle *) + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_longu f); inv H2... + (* singleoflong, singleoflongu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* cmp *) + - destruct (eval_condition cond vl m) as [[]|]... + - unfold Val.select. destruct (eval_condition cond vl m). apply Val.normalize_type. exact I. +Qed. + +End SOUNDNESS. + +(** * Manipulating and transforming operations *) + +(** Constructing shift amounts *) + +Section SHIFT_AMOUNT. + +Variable l: Z. +Hypothesis l_range: 0 <= l < 32. +Variable N: int. +Hypothesis N_eq: Int.unsigned N = two_p l. + +Remark mk_amount_range: + forall n, Int.ltu (Int.zero_ext l n) N = true. +Proof. + intros; unfold Int.ltu. apply zlt_true. rewrite N_eq. apply (Int.zero_ext_range l n). assumption. +Qed. + +Remark mk_amount_eq: + forall n, Int.ltu n N = true -> Int.zero_ext l n = n. +Proof. + intros. + transitivity (Int.repr (Int.unsigned (Int.zero_ext l n))). + symmetry; apply Int.repr_unsigned. + transitivity (Int.repr (Int.unsigned n)). + f_equal. rewrite Int.zero_ext_mod. apply Int.ltu_inv in H. rewrite N_eq in H. + apply Z.mod_small. assumption. assumption. + apply Int.repr_unsigned. +Qed. + +End SHIFT_AMOUNT. + +Program Definition mk_amount32 (n: int): amount32 := + {| a32_amount := Int.zero_ext 5 n |}. +Next Obligation. + apply mk_amount_range. omega. reflexivity. +Qed. + +Lemma mk_amount32_eq: forall n, + Int.ltu n Int.iwordsize = true -> a32_amount (mk_amount32 n) = n. +Proof. + intros. eapply mk_amount_eq; eauto. omega. reflexivity. +Qed. + +Program Definition mk_amount64 (n: int): amount64 := + {| a64_amount := Int.zero_ext 6 n |}. +Next Obligation. + apply mk_amount_range. omega. reflexivity. +Qed. + +Lemma mk_amount64_eq: forall n, + Int.ltu n Int64.iwordsize' = true -> a64_amount (mk_amount64 n) = n. +Proof. + intros. eapply mk_amount_eq; eauto. omega. reflexivity. +Qed. + +(** 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 + | Ccompshift c s a => Ccompshift (negate_comparison c) s a + | Ccompushift c s a => Ccompushift (negate_comparison c) s a + | Cmaskzero n => Cmasknotzero n + | Cmasknotzero n => Cmaskzero 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 + | Ccomplshift c s a => Ccomplshift (negate_comparison c) s a + | Ccomplushift c s a => Ccomplushift (negate_comparison c) s a + | Cmasklzero n => Cmasklnotzero n + | Cmasklnotzero n => Cmasklzero n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Ccompfzero c => Cnotcompfzero c + | Cnotcompfzero c => Ccompfzero c + | Ccompfs c => Cnotcompfs c + | Cnotcompfs c => Ccompfs c + | Ccompfszero c => Cnotcompfszero c + | Cnotcompfszero c => Ccompfszero 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_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply (Val.negate_cmp_bool Ceq). + repeat (destruct vl; auto). apply (Val.negate_cmp_bool Cne). + 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). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). apply (Val.negate_cmpl_bool Ceq). + repeat (destruct vl; auto). apply (Val.negate_cmpl_bool Cne). + 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.cmpf_bool c v (Vfloat Float.zero)) as [[]|]; auto. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v (Vsingle Float32.zero)) as [[]|]; auto. +Qed. + +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: Z) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => addr + end. + +Definition shift_stack_operation (delta: Z) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +Qed. + +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Proof. + intros. destruct op; auto. +Qed. + +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. +Proof. + intros. destruct addr; simpl; auto. destruct vl; auto. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = + eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. +Proof. + intros. destruct op; simpl; auto. destruct vl; auto. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +(** Offset an addressing mode [addr] by a quantity [delta], so that + it designates the pointer [delta] bytes past the pointer designated + by [addr]. May be undefined, in which case [None] is returned. *) + +Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := + match addr with + | Aindexed n => Some(Aindexed (Int64.add n (Int64.repr delta))) + | Aindexed2 => None + | Aindexed2shift _ => None + | Aindexed2ext _ _ => None + | 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. discriminate. +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 16 n) n + | Olongconst n => Int64.eq (Int64.sign_ext 16 n) n + | Oaddrstack _ => true + | _ => false + end. + +(** Operations that depend on the memory state. *) + +Definition cond_depends_on_memory (c: condition) : bool := + match c with + | Ccomplu _ | Ccompluimm _ _ | Ccomplushift _ _ _ => true + | _ => false + end. + +Lemma cond_depends_on_memory_correct: + forall c args m1 m2, + cond_depends_on_memory c = false -> + eval_condition c args m1 = eval_condition c args m2. +Proof. + intros; destruct c; simpl; discriminate || reflexivity. +Qed. + +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp c => cond_depends_on_memory c + | Osel c yu => cond_depends_on_memory c + | _ => 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. destruct op; auto. + simpl. rewrite (cond_depends_on_memory_correct cond args m1 m2 H). auto. + simpl. destruct args; auto. destruct args; auto. + rewrite (cond_depends_on_memory_correct cond args m1 m2 H). auto. +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_shift_inject: + forall v1 v2 s a, + Val.inject f v1 v2 -> Val.inject f (eval_shift s v1 a) (eval_shift s v2 a). +Proof. + intros; inv H; destruct s; simpl; auto; rewrite a32_range; auto. +Qed. + +Lemma eval_shiftl_inject: + forall v1 v2 s a, + Val.inject f v1 v2 -> Val.inject f (eval_shiftl s v1 a) (eval_shiftl s v2 a). +Proof. + intros; inv H; destruct s; simpl; auto; rewrite a64_range; auto. +Qed. + +Lemma eval_extend_inject: + forall v1 v2 x a, + Val.inject f v1 v2 -> Val.inject f (eval_extend x v1 a) (eval_extend x v2 a). +Proof. + unfold eval_extend; intros; inv H; destruct x; simpl; auto; rewrite a64_range; auto. +Qed. + +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. +(* 32-bit integers *) +- 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. +- revert H0. generalize (eval_shift_inject s a H2); intros J; inv H3; inv J; simpl; congruence. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies, eval_shift_inject. +- inv H3; inv H0; auto. +- inv H3; inv H0; auto. +(* 64-bit integers *) +- 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. +- revert H0. generalize (eval_shiftl_inject s a H2); intros J; inv H3; inv J; simpl; congruence. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies, eval_shiftl_inject. +- inv H3; inv H0; auto. +- inv H3; inv H0; auto. +(* 64-bit floats *) +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; simpl in H0; inv H0; auto. +- inv H3; simpl in H0; inv H0; auto. +(* 32-bit floats *) +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; simpl in H0; inv H0; auto. +- inv H3; simpl in H0; inv H0; auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => + exists v1; split; auto + | _ => idtac + end. + +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_operation op) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_operation ge1 sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + (* addrsymbol *) + - apply GL; simpl; auto. + (* addrstack *) + - apply Val.offset_ptr_inject; auto. + (* shift *) + - apply eval_shift_inject; auto. + (* add *) + - apply Val.add_inject; auto. + - apply Val.add_inject; auto using eval_shift_inject. + - apply Val.add_inject; auto. + (* neg, sub *) + - inv H4; simpl; auto. + - generalize (eval_shift_inject s a H4); intros J; inv J; simpl; auto. + - apply Val.sub_inject; auto. + - apply Val.sub_inject; auto using eval_shift_inject. + (* mul, muladd, mulsub *) + - inv H4; inv H2; simpl; auto. + - apply Val.add_inject; auto. inv H2; inv H3; simpl; auto. + - apply Val.sub_inject; auto. inv H2; inv H3; 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. + (* and*) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto. + - inv H4; simpl; auto. + (* or *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto. + - inv H4; simpl; auto. + (* xor *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto. + - inv H4; simpl; auto. + (* not *) + - inv H4; simpl; auto. + - generalize (eval_shift_inject s a H4); intros J; inv J; simpl; auto. + (* bic *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto. + (* nor *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto. + (* eqv *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto. + (* shl *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + (* shr *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + (* shru *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + (* shrx *) + - inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + (* shift-ext *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + - inv H4; simpl; auto; rewrite a32_range; auto. + - inv H4; simpl; auto; rewrite a32_range; auto. + - inv H4; simpl; auto; rewrite a32_range; simpl; auto. + - inv H4; simpl; auto; rewrite a32_range; simpl; auto. + + (* shiftl *) + - apply eval_shiftl_inject; auto. + (* extend *) + - apply eval_extend_inject; auto. + (* makelong, low, high *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addl *) + - apply Val.addl_inject; auto. + - apply Val.addl_inject; auto using eval_shiftl_inject. + - apply Val.addl_inject; auto using eval_extend_inject. + - apply Val.addl_inject; auto. + (* negl, subl *) + - inv H4; simpl; auto. + - generalize (eval_shiftl_inject s a H4); intros J; inv J; simpl; auto. + - apply Val.subl_inject; auto. + - apply Val.subl_inject; auto using eval_shiftl_inject. + - apply Val.subl_inject; auto using eval_extend_inject. + (* mull, mulladd, mullsub, mullhs, mullhu *) + - inv H4; inv H2; simpl; auto. + - apply Val.addl_inject; auto. inv H2; inv H3; simpl; auto. + - apply Val.subl_inject; auto. inv H2; inv H3; 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. + (* andl *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto. + - inv H4; simpl; auto. + (* orl *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto. + - inv H4; simpl; auto. + (* xorl *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto. + - inv H4; simpl; auto. + (* notl *) + - inv H4; simpl; auto. + - generalize (eval_shiftl_inject s a H4); intros J; inv J; simpl; auto. + (* bicl *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto. + (* norl *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto. + (* eqvl *) + - inv H4; inv H2; simpl; auto. + - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto. + (* shll *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + (* shrl *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + (* shrlu *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + (* shrlx *) + - inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + (* shift-ext *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + - inv H4; simpl; auto; rewrite a64_range; auto. + - inv H4; simpl; auto; rewrite a64_range; auto. + - inv H4; simpl; auto; rewrite a64_range; simpl; auto. + - inv H4; simpl; auto; rewrite a64_range; 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. + (* negfs, absfs *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addfs, subfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* mulfs, divfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* singleoffloat, floatofsingle *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* intoffloat, intuoffloat *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. + exists (Vint i); auto. + (* floatofint, floatofintu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* intofsingle, intuofsingle *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2. + exists (Vint i); auto. + (* singleofint, singleofintu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* longoffloat, longuoffloat *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_longu f0); simpl in H2; inv H2. + exists (Vlong i); auto. + (* floatoflong, floatoflongu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* longofsingle, longuofsingle *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_longu f0); simpl in H2; inv H2. + exists (Vlong i); auto. + (* singleoflong, singleoflongu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* cmp, sel *) + - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. + - apply Val.select_inject; auto. + destruct (eval_condition cond vl1 m1) eqn:?; auto. + right; symmetry; eapply eval_condition_inj; eauto. +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; auto. +- apply Val.addl_inject; auto. +- apply Val.addl_inject; auto. inv H3; simpl; auto; rewrite a64_range; auto. +- apply Val.addl_inject; auto using eval_extend_inject. +- apply H; simpl; auto. +- apply Val.offset_ptr_inject; auto. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. +Proof. + intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_list_lessdef. eauto. auto. +Qed. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + intros. apply val_inject_lessdef. auto. + apply val_inject_lessdef; auto. + eauto. + auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +End EVAL_LESSDEF. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Remark symbol_address_inject: + forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. +Qed. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +End EVAL_INJECT. + +(** * Handling of builtin arguments *) + +Definition builtin_arg_ok_1 + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match c, ba with + | OK_all, _ => true + | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true + | OK_addrstack, BA_addrstack _ => true + | OK_addressing, BA_addrstack _ => true + | OK_addressing, BA_addptr (BA _) (BA_int _) => true + | OK_addressing, BA_addptr (BA _) (BA_long _) => true + | _, _ => false + end. + +Definition builtin_arg_ok + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match ba with + | (BA _ | BA_splitlong (BA _) (BA _)) => true + | _ => builtin_arg_ok_1 ba c + end. diff --git a/aarch64/PrintOp.ml b/aarch64/PrintOp.ml new file mode 100644 index 00000000..1780104c --- /dev/null +++ b/aarch64/PrintOp.ml @@ -0,0 +1,247 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printing of operators, conditions, addressing modes *) + +open Printf +open Camlcoq +open Integers +open Op + +let comparison_name = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let shift pp (s, a) = + match s with + | Slsl -> fprintf pp "<< %ld" (camlint_of_coqint a) + | Slsr -> fprintf pp ">>u %ld" (camlint_of_coqint a) + | Sasr -> fprintf pp ">>s %ld" (camlint_of_coqint a) + | Sror -> fprintf pp "ror %ld" (camlint_of_coqint a) + +let shiftl pp (s, a) = + match s with + | Slsl -> fprintf pp "< fprintf pp ">>lu %ld" (camlint_of_coqint a) + | Sasr -> fprintf pp ">>ls %ld" (camlint_of_coqint a) + | Sror -> fprintf pp "rorl %ld" (camlint_of_coqint a) + +let extend_name = function + | Xsgn32 -> "sext" + | Xuns32 -> "zext" + +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) + | (Ccompshift(c, s, a), [r1;r2]) -> + fprintf pp "%a %ss %a %a" reg r1 (comparison_name c) reg r2 shift (s, a) + | (Ccompushift(c, s, a), [r1;r2]) -> + fprintf pp "%a %su %a %a" reg r1 (comparison_name c) reg r2 shift (s, a) + | (Cmaskzero n, [r1]) -> + fprintf pp "%a & 0x%lx == 0" reg r1 (camlint_of_coqint n) + | (Cmasknotzero n, [r1]) -> + fprintf pp "%a & 0x%lx != 0" reg r1 (camlint_of_coqint n) + | (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 %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Ccomplshift(c, s, a), [r1;r2]) -> + fprintf pp "%a %sls %a %a" reg r1 (comparison_name c) reg r2 shift (s, a) + | (Ccomplushift(c, s, a), [r1;r2]) -> + fprintf pp "%a %slu %a %a" reg r1 (comparison_name c) reg r2 shift (s, a) + | (Cmasklzero n, [r1]) -> + fprintf pp "%a & 0x%Lx == 0" reg r1 (camlint64_of_coqint n) + | (Cmasklnotzero n, [r1]) -> + fprintf pp "%a & 0x%Lx != 0" reg r1 (camlint64_of_coqint n) + | (Ccompf c, [r1;r2]) -> + fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 + | (Cnotcompf c, [r1;r2]) -> + fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 + | (Ccompfzero c, [r1]) -> + fprintf pp "%a %sf 0.0" reg r1 (comparison_name c) + | (Cnotcompfzero c, [r1]) -> + fprintf pp "%a not(%sf) 0.0" reg r1 (comparison_name c) + | (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 + | (Ccompfszero c, [r1]) -> + fprintf pp "%a %sfs 0.0" reg r1 (comparison_name c) + | (Cnotcompfszero c, [r1]) -> + fprintf pp "%a not(%sfs) 0.0" reg r1 (comparison_name c) + | _ -> + fprintf pp "" + +let print_operation reg pp = function + | Omove, [r1] -> reg pp r1 + | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) + | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n) + | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n) + | Oaddrsymbol(id, ofs), [] -> + fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) + | Oaddrstack ofs, [] -> + fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) +(* 32-bit integer arithmetic *) + | Oshift(s, a), [r1] -> fprintf pp "%a %a" reg r1 shift (s,a) + | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Oaddshift(s, a), [r1;r2] -> fprintf pp "%a + %a %a" reg r1 reg r2 shift (s,a) + | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Oneg, [r1] -> fprintf pp "- %a" reg r1 + | Onegshift(s, a), [r1] -> fprintf pp "- (%a %a)" reg r1 shift (s,a) + | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Osubshift(s, a), [r1;r2] -> fprintf pp "%a - %a %a" reg r1 reg r2 shift (s,a) + | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | Omuladd, [r1;r2;r3] -> fprintf pp "%a + %a * %a" reg r3 reg r1 reg r2 + | Omulsub, [r1;r2;r3] -> fprintf pp "%a - %a * %a" reg r3 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 + | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 + | Oandshift(s, a), [r1;r2] -> fprintf pp "%a & %a %a" reg r1 reg r2 shift (s,a) + | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) + | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 + | Oorshift(s, a), [r1;r2] -> fprintf pp "%a | %a %a" reg r1 reg r2 shift (s,a) + | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) + | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 + | Oxorshift(s, a), [r1;r2] -> fprintf pp "%a ^ %a %a" reg r1 reg r2 shift (s,a) + | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Onot, [r1] -> fprintf pp "~ %a" reg r1 + | Onotshift(s, a), [r1] -> fprintf pp "~ (%a %a)" reg r1 shift (s,a) + | Obic, [r1;r2] -> fprintf pp "%a & ~ %a" reg r1 reg r2 + | Obicshift(s, a), [r1;r2] -> fprintf pp "%a & ~ %a %a" reg r1 reg r2 shift (s,a) + | Oorn, [r1;r2] -> fprintf pp "%a | ~ %a" reg r1 reg r2 + | Oornshift(s, a), [r1;r2] -> fprintf pp "%a | ~ %a %a" reg r1 reg r2 shift (s,a) + | Oeqv, [r1;r2] -> fprintf pp "%a ^ ~ %a" reg r1 reg r2 + | Oeqvshift(s, a), [r1;r2] -> fprintf pp "%a ^ ~ %a %a" reg r1 reg r2 shift (s,a) + | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 + | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 + | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 + | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) + | Ozext s, [r1] -> fprintf pp "zext(%d, %a)" (Z.to_int s) reg r1 + | Osext s, [r1] -> fprintf pp "sext(%d, %a)" (Z.to_int s) reg r1 + | Oshlzext(s, a), [r1] -> fprintf pp "zext(%d, %a) << %ld" (Z.to_int s) reg r1 (camlint_of_coqint a) + | Oshlsext(s, a), [r1] -> fprintf pp "sext(%d, %a) << %ld" (Z.to_int s) reg r1 (camlint_of_coqint a) + | Ozextshr(a, s), [r1] -> fprintf pp "zext(%d, %a >>u %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a) + | Osextshr(a, s), [r1] -> fprintf pp "sext(%d, %a >>s %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a) +(* 64-bit integer arithmetic *) + | Oshiftl(s, a), [r1] -> fprintf pp "%a %a" reg r1 shiftl (s,a) + | Oextend(x, a), [r1] -> fprintf pp "%s(32, %a) < 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 + | Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2 + | Oaddlshift(s, a), [r1;r2] -> fprintf pp "%a +l %a %a" reg r1 reg r2 shiftl (s,a) + | Oaddlext(x, a), [r1;r2] -> fprintf pp "%a +l %s(%a) << %ld" reg r1 (extend_name x) reg r2 (camlint_of_coqint a) + | Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n) + | Onegl, [r1] -> fprintf pp "-l %a" reg r1 + | Oneglshift(s, a), [r1] -> fprintf pp "-l (%a %a)" reg r1 shiftl (s,a) + | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2 + | Osublext(x, a), [r1;r2] -> fprintf pp "%a +l %s(%a) << %ld" reg r1 (extend_name x) reg r2 (camlint_of_coqint a) + | Osublshift(s, a), [r1;r2] -> fprintf pp "%a -l %a %a" reg r1 reg r2 shiftl (s,a) + | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2 + | Omulladd, [r1;r2;r3] -> fprintf pp "%a +l %a *l %a" reg r3 reg r1 reg r2 + | Omullsub, [r1;r2;r3] -> fprintf pp "%a -l %a *l %a" reg r3 reg r1 reg r2 + | Omullhs, [r1;r2] -> fprintf pp "%a *hls %a" reg r1 reg r2 + | Omullhu, [r1;r2] -> fprintf pp "%a *hlu %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 + | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2 + | Oandlshift(s, a), [r1;r2] -> fprintf pp "%a &l %a %a" reg r1 reg r2 shiftl (s,a) + | 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 + | Oorlshift(s, a), [r1;r2] -> fprintf pp "%a |l %a %a" reg r1 reg r2 shiftl (s,a) + | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) + | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 + | Oxorlshift(s, a), [r1;r2] -> fprintf pp "%a ^l %a %a" reg r1 reg r2 shiftl (s,a) + | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) + | Onotl, [r1] -> fprintf pp "~l %a" reg r1 + | Onotlshift(s, a), [r1] -> fprintf pp "~l (%a %a)" reg r1 shiftl (s,a) + | Obicl, [r1;r2] -> fprintf pp "%a &l ~l %a" reg r1 reg r2 + | Obiclshift(s, a), [r1;r2] -> fprintf pp "%a &l ~l %a %a" reg r1 reg r2 shiftl (s,a) + | Oornl, [r1;r2] -> fprintf pp "%a |l ~l %a" reg r1 reg r2 + | Oornlshift(s, a), [r1;r2] -> fprintf pp "%a |l ~l %a %a" reg r1 reg r2 shiftl (s,a) + | Oeqvl, [r1;r2] -> fprintf pp "%a ^l ~l %a" reg r1 reg r2 + | Oeqvlshift(s, a), [r1;r2] -> fprintf pp "%a ^l ~l %a %a" reg r1 reg r2 shift (s,a) + | Oshll, [r1;r2] -> fprintf pp "%a < fprintf pp "%a >>ls %a" reg r1 reg r2 + | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 + | Oshrlximm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) + | Ozextl s, [r1] -> fprintf pp "zextl(%d, %a)" (Z.to_int s) reg r1 + | Osextl s, [r1] -> fprintf pp "sextl(%d, %a)" (Z.to_int s) reg r1 + | Oshllzext(s, a), [r1] -> fprintf pp "zextl(%d, %a) < fprintf pp "sextl(%d, %a) < fprintf pp "zextl(%d, %a >>lu %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a) + | Osextshrl(a, s), [r1] -> fprintf pp "sextl(%d, %a >>ls %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a) +(* 64-bit floating-point arithmetic *) + | 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 +(* 32-bit floating-point arithmetic *) + | 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 +(* Conversions between int and float *) + | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 + | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 + | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 + | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%a)" reg r1 + | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 + | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 + | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 + | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 + | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 + | Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1 + | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 + | Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1 + | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 + | Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1 + | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 + | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 +(* Boolean tests *) + | Ocmp c, args -> print_condition reg pp (c, args) + | Osel (c, ty), r1::r2::args -> + fprintf pp "%a ?%s %a : %a" + (print_condition reg) (c, args) + (PrintAST.name_of_type ty) reg r1 reg r2 + | _ -> fprintf pp "" + +let print_addressing reg pp = function + | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_coqint n) + | Aindexed2, [r1; r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Aindexed2shift a, [r1; r2] -> fprintf pp "%a + %a << %ld" reg r1 reg r2 (camlint_of_coqint a) + | Aindexed2ext(x, a), [r1; r2] -> fprintf pp "%a + %s(%a) << %ld" reg r1 (extend_name x) reg r2 (camlint_of_coqint a) + | 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/aarch64/SelectLong.vp b/aarch64/SelectLong.vp new file mode 100644 index 00000000..ddf6e212 --- /dev/null +++ b/aarch64/SelectLong.vp @@ -0,0 +1,478 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib Zbits. +Require Import Compopts AST Integers Floats. +Require Import Op CminorSel SelectOp. + +Local Open Scope cminorsel_scope. + +(** ** Constants **) + +Definition longconst (n: int64) : expr := + Eop (Olongconst n) Enil. + +(** ** Conversions *) + +Nondetfunction intoflong (e: expr) := + match e with + | Eop (Olongconst n) Enil => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil + | _ => Eop Olowlong (e ::: Enil) + end. + +Nondetfunction longofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => longconst (Int64.repr (Int.signed n)) + | _ => Eop (Oextend Xsgn32 (mk_amount64 Int.zero)) (e ::: Enil) + end. + +Nondetfunction longofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => longconst (Int64.repr (Int.unsigned n)) + | _ => Eop (Oextend Xuns32 (mk_amount64 Int.zero)) (e ::: Enil) + end. + +(** ** Integer addition and pointer addition *) + +Nondetfunction addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else + match e with + | Eop (Olongconst m) Enil => longconst (Int64.add n m) + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | _ => Eop (Oaddlimm n) (e ::: Enil) + end. + +Nondetfunction addl (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | Eop (Oshiftl s a) (t1:::Enil), t2 ?? arith_shift s => + Eop (Oaddlshift s a) (t2 ::: t1 ::: Enil) + | t1, Eop (Oshiftl s a) (t2:::Enil) ?? arith_shift s => + Eop (Oaddlshift s a) (t1 ::: t2 ::: Enil) + | Eop (Oextend x a) (t1:::Enil), t2 => + Eop (Oaddlext x a) (t2 ::: t1 ::: Enil) + | t1, Eop (Oextend x a) (t2:::Enil) => + Eop (Oaddlext x a) (t1 ::: t2 ::: Enil) + | Eop Omull (t1:::t2:::Enil), t3 => + Eop Omulladd (t3:::t1:::t2:::Enil) + | t1, Eop Omull (t2:::t3:::Enil) => + Eop Omulladd (t1:::t2:::t3:::Enil) + | _, _ => Eop Oaddl (e1:::e2:::Enil) + end. + +(** ** Opposite *) + +Nondetfunction negl (e: expr) := + match e with + | Eop (Olongconst n) Enil => Eop (Olongconst (Int64.neg n)) Enil + | Eop (Oshiftl s a) (t1:::Enil) ?? arith_shift s => Eop (Oneglshift s a) (t1:::Enil) + | _ => Eop Onegl (e ::: Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction subl (e1: expr) (e2: expr) := + 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 (Oshiftl s a) (t2:::Enil) ?? arith_shift s => + Eop (Osublshift s a) (t1:::t2::: Enil) + | t1, Eop (Oextend x a) (t2:::Enil) => + Eop (Osublext x a) (t1 ::: t2 ::: Enil) + | t1, Eop Omull (t2:::t3:::Enil) => + Eop Omullsub (t1:::t2:::t3:::Enil) + | _, _ => Eop Osubl (e1:::e2:::Enil) + end. + +(** ** Immediate shift left *) + +Definition shllimm_base (e1: expr) (n: int) := + Eop (Oshiftl Slsl (mk_amount64 n)) (e1 ::: Enil). + +Nondetfunction shllimm (e1: expr) (n: int) := + 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 => + Eop (Olongconst (Int64.shl' n1 n)) Enil + | Eop (Oshiftl Slsl a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int64.iwordsize' + then shllimm_base t1 (Int.add a n) + else shllimm_base e1 n + | Eop (Ozextl s) (t1:::Enil) => + Eop (Oshllzext s (mk_amount64 n)) (t1:::Enil) + | Eop (Osextl s) (t1:::Enil) => + Eop (Oshllsext s (mk_amount64 n)) (t1:::Enil) + | Eop (Oshllzext s a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int64.iwordsize' + then Eop (Oshllzext s (mk_amount64 (Int.add a n))) (t1:::Enil) + else shllimm_base e1 n + | Eop (Oshllsext s a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int64.iwordsize' + then Eop (Oshllsext s (mk_amount64 (Int.add a n))) (t1:::Enil) + else shllimm_base e1 n + | Eop (Oextend x a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int64.iwordsize' + then Eop (Oextend x (mk_amount64 (Int.add a n))) (t1:::Enil) + else shllimm_base e1 n + | _ => + shllimm_base e1 n + end. + +(** ** Immediate shift right (logical) *) + +Definition shrluimm_base (e1: expr) (n: int) := + Eop (Oshiftl Slsr (mk_amount64 n)) (e1 ::: Enil). + +Nondetfunction shrluimm (e1: expr) (n: int) := + 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 => + Eop (Olongconst (Int64.shru' n1 n)) Enil + | Eop (Oshiftl Slsl a) (t1:::Enil) => + if Int.ltu n a + then Eop (Oshllzext (Int64.zwordsize - Int.unsigned a) (mk_amount64 (Int.sub a n))) (t1:::Enil) + else Eop (Ozextshrl (mk_amount64 (Int.sub n a)) (Int64.zwordsize - Int.unsigned n)) (t1:::Enil) + | Eop (Oshiftl Slsr a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int64.iwordsize' + then shrluimm_base t1 (Int.add a n) + else shrluimm_base e1 n + | Eop (Ozextl s) (t1:::Enil) => + if zlt (Int.unsigned n) s + then Eop (Ozextshrl (mk_amount64 n) (s - Int.unsigned n)) (t1:::Enil) + else Eop (Olongconst Int64.zero) Enil + | _ => + shrluimm_base e1 n + end. + +(** ** Immediate shift right (arithmetic) *) + +Definition shrlimm_base (e1: expr) (n: int) := + Eop (Oshiftl Sasr (mk_amount64 n)) (e1 ::: Enil). + +Nondetfunction shrlimm (e1: expr) (n: int) := + 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 => + Eop (Olongconst (Int64.shr' n1 n)) Enil + | Eop (Oshiftl Slsl a) (t1:::Enil) => + if Int.ltu n a + then Eop (Oshllsext (Int64.zwordsize - Int.unsigned a) (mk_amount64 (Int.sub a n))) (t1:::Enil) + else Eop (Osextshrl (mk_amount64 (Int.sub n a)) (Int64.zwordsize - Int.unsigned n)) (t1:::Enil) + | Eop (Oshiftl Sasr a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int64.iwordsize' + then shrlimm_base t1 (Int.add a n) + else shrlimm_base e1 n + | Eop (Osextl s) (t1:::Enil) => + if zlt (Int.unsigned n) s && zlt s Int64.zwordsize + then Eop (Osextshrl (mk_amount64 n) (s - Int.unsigned n)) (t1:::Enil) + else shrlimm_base e1 n + | _ => + shrlimm_base e1 n + end. + +(** ** Integer multiply *) + +Definition mullimm_base (n1: int64) (e2: expr) := + match Int64.one_bits' n1 with + | i :: nil => + shllimm e2 i + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) + | _ => + Eop Omull (Eop (Olongconst n1) Enil ::: e2 ::: Enil) + end. + +Nondetfunction mullimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then Eop (Olongconst Int64.zero) Enil + else if Int64.eq n1 Int64.one then e2 + else match e2 with + | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.mul n1 n2)) Enil + | 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) := + 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 mullhs (e1: expr) (n2: int64) := + Eop Omullhs (e1 ::: longconst n2 ::: Enil). + +Definition mullhu (e1: expr) (n2: int64) := + Eop Omullhu (e1 ::: longconst n2 ::: Enil). + +(** ** Integer conversions *) + +Nondetfunction zero_ext_l (sz: Z) (e: expr) := + match e with + | Eop (Olongconst n) Enil => Eop (Olongconst (Int64.zero_ext sz n)) Enil + | Eop (Oshiftl Slsr a) (t1:::Enil) => Eop (Ozextshrl a sz) (t1:::Enil) + | Eop (Oshiftl Slsl a) (t1:::Enil) => + if zlt (Int.unsigned a) sz + then Eop (Oshllzext (sz - Int.unsigned a) a) (t1:::Enil) + else Eop (Ozextl sz) (e:::Enil) + | _ => Eop (Ozextl sz) (e:::Enil) + end. + +(** ** Bitwise not *) + +Nondetfunction notl (e: expr) := + match e with + | Eop (Olongconst n) Enil => Eop (Olongconst (Int64.not n)) Enil + | Eop (Oshiftl s a) (t1:::Enil) => Eop (Onotlshift s a) (t1:::Enil) + | Eop Onotl (t1:::Enil) => t1 + | Eop (Onotlshift s a) (t1:::Enil) => Eop (Oshiftl s a) (t1:::Enil) + | Eop Obicl (t1:::t2:::Enil) => Eop Oornl (t2:::t1:::Enil) + | Eop Oornl (t1:::t2:::Enil) => Eop Obicl (t2:::t1:::Enil) + | Eop Oxorl (t1:::t2:::Enil) => Eop Oeqvl (t1:::t2:::Enil) + | Eop Oeqvl (t1:::t2:::Enil) => Eop Oxorl (t1:::t2:::Enil) + | _ => Eop Onotl (e:::Enil) + end. + +(** ** Bitwise and *) + +Definition andlimm_base (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then Eop (Olongconst Int64.zero) Enil else + if Int64.eq n1 Int64.mone then e2 else + match Z_is_power2m1 (Int64.unsigned n1) with + | Some s => zero_ext_l s e2 + | None => Eop (Oandlimm n1) (e2 ::: Enil) + end. + +Nondetfunction andlimm (n1: int64) (e2: expr) := + match e2 with + | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.and n1 n2)) Enil + | Eop (Oandlimm n2) (t2:::Enil) => andlimm_base (Int64.and n1 n2) t2 + | Eop (Ozextl s) (t2:::Enil) => + if zle 0 s + then andlimm_base (Int64.and n1 (Int64.repr (two_p s - 1))) t2 + else andlimm_base n1 e2 + | _ => andlimm_base n1 e2 + end. + +Nondetfunction andl (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | Eop Onotl (t1:::Enil), t2 => Eop Obicl (t2:::t1:::Enil) + | t1, Eop Onotl (t2:::Enil) => Eop Obicl (t1:::t2:::Enil) + | Eop (Onotlshift s a) (t1:::Enil), t2 => Eop (Obiclshift s a) (t2:::t1:::Enil) + | t1, Eop (Onotlshift s a) (t2:::Enil) => Eop (Obiclshift s a) (t1:::t2:::Enil) + | Eop (Oshiftl s a) (t1:::Enil), t2 => Eop (Oandlshift s a) (t2:::t1:::Enil) + | t1, Eop (Oshiftl s a) (t2:::Enil) => Eop (Oandlshift s a) (t1:::t2:::Enil) + | _, _ => Eop Oandl (e1:::e2:::Enil) + end. + +(** ** Bitwise or *) + +Nondetfunction orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 + else if Int64.eq n1 Int64.mone then Eop (Olongconst Int64.mone) Enil + else match e2 with + | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.or n1 n2)) Enil + | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorlimm n1) (e2:::Enil) + end. + +Nondetfunction orl (e1: expr) (e2: expr) := + 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 (t2:::t1:::Enil) + | t1, Eop Onotl (t2:::Enil) => Eop Oornl (t1:::t2:::Enil) + | Eop (Onotlshift s a) (t1:::Enil), t2 => Eop (Oornlshift s a) (t2:::t1:::Enil) + | t1, Eop (Onotlshift s a) (t2:::Enil) => Eop (Oornlshift s a) (t1:::t2:::Enil) + | Eop (Oshiftl Slsl a1) (t1:::Enil), Eop (Oshiftl Slsr a2) (t2:::Enil) => + if Int.eq (Int.add a1 a2) Int64.iwordsize' && same_expr_pure t1 t2 + then Eop (Oshiftl Sror a2) (t2:::Enil) + else Eop (Oorlshift Slsr a2) (Eop (Oshiftl Slsl a1) (t1:::Enil):::t2:::Enil) + | Eop (Oshiftl Slsr a1) (t1:::Enil), Eop (Oshiftl Slsl a2) (t2:::Enil) => + if Int.eq (Int.add a2 a1) Int64.iwordsize' && same_expr_pure t1 t2 + then Eop (Oshiftl Sror a1) (t1:::Enil) + else Eop (Oorlshift Slsl a2) (Eop (Oshiftl Slsr a1) (t1:::Enil):::t2:::Enil) + | Eop (Oshiftl s a) (t1:::Enil), t2 => Eop (Oorlshift s a) (t2:::t1:::Enil) + | t1, Eop (Oshiftl s a) (t2:::Enil) => Eop (Oorlshift s a) (t1:::t2:::Enil) + | _, _ => Eop Oorl (e1:::e2:::Enil) + end. + +(** ** Bitwise xor *) + +Definition xorlimm_base (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then notl e2 else + Eop (Oxorlimm n1) (e2:::Enil). + +Nondetfunction xorlimm (n1: int64) (e2: expr) := + match e2 with + | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.xor n1 n2)) Enil + | Eop (Oxorlimm n2) (t2:::Enil) => xorlimm_base (Int64.xor n1 n2) t2 + | _ => xorlimm_base n1 e2 + end. + +Nondetfunction xorl (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 + | Eop Onotl (t1:::Enil), t2 => Eop Oeqvl (t2:::t1:::Enil) + | t1, Eop Onotl (t2:::Enil) => Eop Oeqvl (t1:::t2:::Enil) + | Eop (Onotlshift s a) (t1:::Enil), t2 => Eop (Oeqvlshift s a) (t2:::t1:::Enil) + | t1, Eop (Onotlshift s a) (t2:::Enil) => Eop (Oeqvlshift s a) (t1:::t2:::Enil) + | Eop (Oshiftl s a) (t1:::Enil), t2 => Eop (Oxorlshift s a) (t2:::t1:::Enil) + | t1, Eop (Oshiftl s a) (t2:::Enil) => Eop (Oxorlshift s a) (t1:::t2:::Enil) + | _, _ => Eop Oxorl (e1:::e2:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition modl_aux (divop: operation) (e1 e2: expr) := + Elet e1 + (Elet (lift e2) + (Eop Omullsub (Eletvar 1 ::: + Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: + Eletvar 0 ::: + Enil))). + +Definition divls_base (e1: expr) (e2: expr) := Eop Odivl (e1:::e2:::Enil). +Definition modls_base := modl_aux Odivl. +Definition divlu_base (e1: expr) (e2: expr) := Eop Odivlu (e1:::e2:::Enil). +Definition modlu_base := modl_aux Odivlu. + +Definition shrxlimm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 else Eop (Oshrlximm n2) (e1:::Enil). + +(** ** General shifts *) + +Nondetfunction shll (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shllimm e1 n2 + | _ => Eop Oshll (e1:::e2:::Enil) + end. + +Nondetfunction shrl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrlimm e1 n2 + | _ => Eop Oshrl (e1:::e2:::Enil) + end. + +Nondetfunction shrlu (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrluimm e1 n2 + | _ => Eop Oshrlu (e1:::e2:::Enil) + end. + +(** ** Comparisons *) + +Nondetfunction complimm (default: comparison -> int64 -> condition) + (sem: comparison -> int64 -> int64 -> bool) + (c: comparison) (e1: expr) (n2: int64) := + match c, e1 with + | c, Eop (Olongconst n1) Enil => + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | Ceq, Eop (Oandlimm m) (t1:::Enil) => + if Int64.eq n2 Int64.zero + then Eop (Ocmp (Cmasklzero m)) (t1:::Enil) + else Eop (Ocmp (default c n2)) (e1:::Enil) + | Cne, Eop (Oandlimm m) (t1:::Enil) => + if Int64.eq n2 Int64.zero + then Eop (Ocmp (Cmasklnotzero m)) (t1:::Enil) + else Eop (Ocmp (default c n2)) (e1:::Enil) + | _, _ => + Eop (Ocmp (default c n2)) (e1:::Enil) + end. + +Nondetfunction cmpl (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => + complimm Ccomplimm Int64.cmp (swap_comparison c) t2 n1 + | t1, Eop (Olongconst n2) Enil => + complimm Ccomplimm Int64.cmp c t1 n2 + | Eop (Oshiftl s a) (t1:::Enil), t2 ?? arith_shift s => + Eop (Ocmp (Ccomplshift (swap_comparison c) s a)) (t2:::t1:::Enil) + | t1, Eop (Oshiftl s a) (t2:::Enil) ?? arith_shift s => + Eop (Ocmp (Ccomplshift c s a)) (t1:::t2:::Enil) + | _, _ => + Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) + end. + +Nondetfunction cmplu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => + complimm Ccompluimm Int64.cmpu (swap_comparison c) t2 n1 + | t1, Eop (Olongconst n2) Enil => + complimm Ccompluimm Int64.cmpu c t1 n2 + | Eop (Oshiftl s a) (t1:::Enil), t2 ?? arith_shift s => + Eop (Ocmp (Ccomplushift (swap_comparison c) s a)) (t2:::t1:::Enil) + | t1, Eop (Oshiftl s a) (t2:::Enil) ?? arith_shift s => + Eop (Ocmp (Ccomplushift c s a)) (t1:::t2:::Enil) + | _, _ => + Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) + end. + +(** ** Floating-point conversions *) + +Definition longoffloat (e: expr) := + Eop Olongoffloat (e:::Enil). + +Definition longuoffloat (e: expr) := + Eop Olonguoffloat (e:::Enil). + +Definition floatoflong (e: expr) := + Eop Ofloatoflong (e:::Enil). + +Definition floatoflongu (e: expr) := + Eop Ofloatoflongu (e:::Enil). + +Definition longofsingle (e: expr) := + Eop Olongofsingle (e:::Enil). + +Definition longuofsingle (e: expr) := + Eop Olonguofsingle (e:::Enil). + +Definition singleoflong (e: expr) := + Eop Osingleoflong (e:::Enil). + +Definition singleoflongu (e: expr) := + Eop Osingleoflongu (e:::Enil). + diff --git a/aarch64/SelectLongproof.v b/aarch64/SelectLongproof.v new file mode 100644 index 00000000..b051369c --- /dev/null +++ b/aarch64/SelectLongproof.v @@ -0,0 +1,764 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection for 64-bit integer operators *) + +Require Import Coqlib Zbits. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Cminor Op CminorSel. +Require Import SelectOp SelectLong SelectOpproof. + +Local Open Scope cminorsel_scope. +Local Transparent Archi.ptr64. + +(** * Correctness of the smart constructors *) + +Section CMCONSTR. + +Variable ge: genv. +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. + +(** ** Constants *) + +Theorem eval_longconst: + forall le n, eval_expr ge sp e m le (longconst n) (Vlong n). +Proof. + intros; EvalOp. +Qed. + +(** ** Conversions *) + +Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword. +Proof. + unfold intoflong; red; intros until x; destruct (intoflong_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu. +Proof. + unfold longofintu; red; intros until x; destruct (longofintu_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. simpl. unfold eval_extend. rewrite mk_amount64_eq by reflexivity. + destruct x; simpl; auto. rewrite Int64.shl'_zero. auto. +Qed. + +Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. +Proof. + unfold longofint; red; intros until x; destruct (longofint_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. simpl. unfold eval_extend. rewrite mk_amount64_eq by reflexivity. + destruct x; simpl; auto. rewrite Int64.shl'_zero. auto. +Qed. + +(** ** Addition, opposite, subtraction *) + +Theorem eval_addlimm: + forall n, unary_constructor_sound (addlimm n) (fun x => Val.addl x (Vlong n)). +Proof. + red; unfold addlimm; intros until x. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. intros. exists x; split; auto. + destruct x; simpl; auto. + rewrite Int64.add_zero; auto. + rewrite Ptrofs.add_zero; auto. +- case (addlimm_match a); intros; InvEval; subst. ++ rewrite Int64.add_commut; TrivialExists. ++ TrivialExists. simpl. rewrite Ptrofs.add_commut, Genv.shift_symbol_address_64; auto. ++ econstructor; split. EvalOp. destruct sp; simpl; auto. + rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0); auto. ++ rewrite Val.addl_assoc, Int64.add_commut; TrivialExists. ++ TrivialExists. +Qed. + +Theorem eval_addl: binary_constructor_sound addl Val.addl. +Proof. + red; intros until y. + unfold addl; case (addl_match a b); intros; InvEval; subst. +- rewrite Val.addl_commut. apply eval_addlimm; auto. +- apply eval_addlimm; auto. +- 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. +- TrivialExists. simpl. + rewrite Val.addl_commut, Val.addl_assoc. f_equal; f_equal. + destruct sp; simpl; auto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut n2). auto. +- TrivialExists. simpl. + rewrite <- (Val.addl_commut v1), <- (Val.addl_commut (Val.addl v1 (Vlong n2))). + rewrite Val.addl_assoc. f_equal; f_equal. + destruct sp; simpl; auto. rewrite Ptrofs.add_assoc. auto. +- 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. +- rewrite <- Val.addl_assoc. apply eval_addlimm. EvalOp. +- rewrite Val.addl_commut. TrivialExists. +- TrivialExists. +- rewrite Val.addl_commut. TrivialExists. +- TrivialExists. +- rewrite Val.addl_commut. TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_negl: unary_constructor_sound negl (fun v => Val.subl (Vlong Int64.zero) v). +Proof. + red; intros until x; unfold negl. case (negl_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_subl: binary_constructor_sound subl Val.subl. +Proof. + red; intros until y; unfold subl; case (subl_match a b); intros; InvEval; subst. +- rewrite Val.subl_addl_opp. apply eval_addlimm; auto. +- 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. +- rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. +- rewrite Val.subl_addl_r. apply eval_addlimm; EvalOp. +- TrivialExists. +- TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +(** ** Immediate shifts *) + +Remark eval_shllimm_base: forall le a n x, + eval_expr ge sp e m le a x -> + Int.ltu n Int64.iwordsize' = true -> + eval_expr ge sp e m le (shllimm_base a n) (Val.shll x (Vint n)). +Proof. +Local Opaque mk_amount64. + unfold shlimm_base; intros; EvalOp. simpl. rewrite mk_amount64_eq by auto. auto. +Qed. + +Theorem eval_shllimm: + forall n, unary_constructor_sound (fun a => shllimm a n) + (fun x => Val.shll x (Vint n)). +Proof. + red; intros until x; unfold shllimm. + predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int64.iwordsize') eqn:L]; simpl. +- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int64.shl'_zero; auto. +- destruct (shllimm_match a); intros; InvEval; subst. ++ TrivialExists. simpl; rewrite L; auto. ++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2. +* econstructor; split. eapply eval_shllimm_base; eauto. + destruct v1; simpl; auto. rewrite a64_range; simpl. rewrite L, L2. + rewrite Int64.shl'_shl'; auto using a64_range. +* econstructor; split; [|eauto]. apply eval_shllimm_base; auto. EvalOp. ++ TrivialExists. simpl. rewrite mk_amount64_eq; auto. ++ TrivialExists. simpl. rewrite mk_amount64_eq; auto. ++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2. +* TrivialExists. simpl. rewrite mk_amount64_eq by auto. + destruct (Val.zero_ext_l s v1); simpl; auto. + rewrite a64_range; simpl; rewrite L, L2. + rewrite Int64.shl'_shl'; auto using a64_range. +* econstructor; split. eapply eval_shllimm_base; eauto. EvalOp; simpl; eauto. auto. ++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2. +* TrivialExists. simpl. rewrite mk_amount64_eq by auto. + destruct (Val.sign_ext_l s v1); simpl; auto. + rewrite a64_range; simpl; rewrite L, L2. + rewrite Int64.shl'_shl'; auto using a64_range. +* econstructor; split. eapply eval_shllimm_base; eauto. EvalOp; simpl; eauto. auto. ++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2. +* TrivialExists. simpl. unfold eval_extend. rewrite mk_amount64_eq by auto. + destruct (match x0 with Xsgn32 => Val.longofint v1 | Xuns32 => Val.longofintu v1 end); simpl; auto. + rewrite a64_range; simpl; rewrite L, L2. + rewrite Int64.shl'_shl'; auto using a64_range. +* econstructor; split. eapply eval_shllimm_base; eauto. EvalOp; simpl; eauto. auto. ++ econstructor; eauto using eval_shllimm_base. +- intros; TrivialExists. +Qed. + +Remark eval_shrluimm_base: forall le a n x, + eval_expr ge sp e m le a x -> + Int.ltu n Int64.iwordsize' = true -> + eval_expr ge sp e m le (shrluimm_base a n) (Val.shrlu x (Vint n)). +Proof. + unfold shrluimm_base; intros; EvalOp. simpl. rewrite mk_amount64_eq by auto. auto. +Qed. + +Remark sub_shift_amount: + forall y z, + Int.ltu y Int64.iwordsize' = true -> Int.ltu z Int64.iwordsize' = true -> Int.unsigned y <= Int.unsigned z -> + Int.ltu (Int.sub z y) Int64.iwordsize' = true. +Proof. + intros. unfold Int.ltu; apply zlt_true. + apply Int.ltu_inv in H. apply Int.ltu_inv in H0. + change (Int.unsigned Int64.iwordsize') with Int64.zwordsize in *. + unfold Int.sub; rewrite Int.unsigned_repr. omega. + assert (Int64.zwordsize < Int.max_unsigned) by reflexivity. omega. +Qed. + +Theorem eval_shrluimm: + forall n, unary_constructor_sound (fun a => shrluimm a n) + (fun x => Val.shrlu x (Vint n)). +Proof. +Local Opaque Int64.zwordsize. + red; intros until x; unfold shrluimm. + predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int64.iwordsize') eqn:L]; simpl. +- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int64.shru'_zero; auto. +- destruct (shrluimm_match a); intros; InvEval; subst. ++ TrivialExists. simpl; rewrite L; auto. ++ destruct (Int.ltu n a) eqn:L2. +* assert (L3: Int.ltu (Int.sub a n) Int64.iwordsize' = true). + { apply sub_shift_amount; auto using a64_range. + apply Int.ltu_inv in L2. omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. + simpl. rewrite L. rewrite Int64.shru'_shl', L2 by auto using a64_range. auto. +* assert (L3: Int.ltu (Int.sub n a) Int64.iwordsize' = true). + { apply sub_shift_amount; auto using a64_range. + unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. + simpl. rewrite L. rewrite Int64.shru'_shl', L2 by auto using a64_range. auto. ++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2. +* econstructor; split. eapply eval_shrluimm_base; eauto. + destruct v1; simpl; auto. rewrite a64_range; simpl. rewrite L, L2. + rewrite Int64.shru'_shru'; auto using a64_range. +* econstructor; split; [|eauto]. apply eval_shrluimm_base; auto. EvalOp. ++ destruct (zlt (Int.unsigned n) s). +* econstructor; split. EvalOp. rewrite mk_amount64_eq by auto. + destruct v1; simpl; auto. rewrite ! L; simpl. + set (s' := s - Int.unsigned n). + replace s with (s' + Int.unsigned n) by (unfold s'; omega). + rewrite Int64.shru'_zero_ext. auto. unfold s'; omega. +* econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite ! L; simpl. + rewrite Int64.shru'_zero_ext_0 by omega. auto. ++ econstructor; eauto using eval_shrluimm_base. +- intros; TrivialExists. +Qed. + +Remark eval_shrlimm_base: forall le a n x, + eval_expr ge sp e m le a x -> + Int.ltu n Int64.iwordsize' = true -> + eval_expr ge sp e m le (shrlimm_base a n) (Val.shrl x (Vint n)). +Proof. + unfold shrlimm_base; intros; EvalOp. simpl. rewrite mk_amount64_eq by auto. auto. +Qed. + +Theorem eval_shrlimm: + forall n, unary_constructor_sound (fun a => shrlimm a n) + (fun x => Val.shrl x (Vint n)). +Proof. + red; intros until x; unfold shrlimm. + predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int64.iwordsize') eqn:L]; simpl. +- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int64.shr'_zero; auto. +- destruct (shrlimm_match a); intros; InvEval; subst. ++ TrivialExists. simpl; rewrite L; auto. ++ destruct (Int.ltu n a) eqn:L2. +* assert (L3: Int.ltu (Int.sub a n) Int64.iwordsize' = true). + { apply sub_shift_amount; auto using a64_range. + apply Int.ltu_inv in L2. omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. + simpl. rewrite L. rewrite Int64.shr'_shl', L2 by auto using a64_range. auto. +* assert (L3: Int.ltu (Int.sub n a) Int64.iwordsize' = true). + { apply sub_shift_amount; auto using a64_range. + unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto. + simpl. rewrite L. rewrite Int64.shr'_shl', L2 by auto using a64_range. auto. ++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2. +* econstructor; split. eapply eval_shrlimm_base; eauto. + destruct v1; simpl; auto. rewrite a64_range; simpl. rewrite L, L2. + rewrite Int64.shr'_shr'; auto using a64_range. +* econstructor; split; [|eauto]. apply eval_shrlimm_base; auto. EvalOp. ++ destruct (zlt (Int.unsigned n) s && zlt s Int64.zwordsize) eqn:E. +* InvBooleans. econstructor; split. EvalOp. rewrite mk_amount64_eq by auto. + destruct v1; simpl; auto. rewrite ! L; simpl. + set (s' := s - Int.unsigned n). + replace s with (s' + Int.unsigned n) by (unfold s'; omega). + rewrite Int64.shr'_sign_ext. auto. unfold s'; omega. unfold s'; omega. +* econstructor; split; [|eauto]. apply eval_shrlimm_base; auto. EvalOp. ++ econstructor; eauto using eval_shrlimm_base. +- intros; TrivialExists. +Qed. + +(** ** Multiplication *) + +Lemma eval_mullimm_base: + forall n, unary_constructor_sound (mullimm_base n) (fun x => Val.mull x (Vlong n)). +Proof. + intros; red; intros; unfold mullimm_base. + assert (DFL: exists v, eval_expr ge sp e m le (Eop Omull (Eop (Olongconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mull x (Vlong n)) v). + { rewrite Val.mull_commut; TrivialExists. } + generalize (Int64.one_bits'_decomp n); generalize (Int64.one_bits'_range n); + destruct (Int64.one_bits' n) as [ | i [ | j []]]; intros P Q. +- apply DFL. +- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). + apply eval_shllimm; auto. + simpl in Q. destruct x; auto; simpl. rewrite P by auto with coqlib. + rewrite Q, Int64.add_zero, Int64.shl'_mul. auto. +- exploit (eval_shllimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shllimm j (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit (eval_addl (x :: le)). eexact A1. eexact A2. intros [v [A B]]. + exists v; split. econstructor; eauto. + simpl in Q. rewrite Q, Int64.add_zero. eapply Val.lessdef_trans; [|eexact B]. + eapply Val.lessdef_trans; [|eapply Val.addl_lessdef; eauto]. + destruct x; simpl; auto; rewrite ! P by auto with coqlib. + rewrite Int64.mul_add_distr_r, <- ! Int64.shl'_mul. auto. +- apply DFL. +Qed. + +Theorem eval_mullimm: + forall n, unary_constructor_sound (mullimm n) (fun x => Val.mull x (Vlong n)). +Proof. + intros; red; intros until x; unfold mullimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + intros. exists (Vlong Int64.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int64.mul_zero. auto. + predSpec Int64.eq Int64.eq_spec n Int64.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int64.mul_one. auto. + case (mullimm_match a); intros; InvEval; subst. +- TrivialExists. simpl. rewrite Int64.mul_commut; auto. +- rewrite Val.mull_addl_distr_l. + exploit eval_mullimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addlimm (Int64.mul n n2) le (mullimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.addl_lessdef; eauto. + rewrite Val.mull_commut; auto. +- apply eval_mullimm_base; auto. +Qed. + +Theorem eval_mull: binary_constructor_sound mull Val.mull. +Proof. + red; intros until y; unfold mull; case (mull_match a b); intros; InvEval; subst. +- 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; red; intros; TrivialExists. +Qed. + +Theorem eval_mullhs: + forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). +Proof. + unfold mullhs; red; intros; TrivialExists. +Qed. + +(** Integer conversions *) + +Theorem eval_zero_ext_l: + forall sz, 0 <= sz -> unary_constructor_sound (zero_ext_l sz) (Val.zero_ext_l sz). +Proof. + intros; red; intros until x; unfold zero_ext_l; case (zero_ext_l_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. +- destruct (zlt (Int.unsigned a0) sz). ++ econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a64_range; simpl. + apply Val.lessdef_same. f_equal. rewrite Int64.shl'_zero_ext by omega. f_equal. omega. ++ TrivialExists. +- TrivialExists. +Qed. + +(** Bitwise not, and, or, xor *) + +Theorem eval_notl: unary_constructor_sound notl Val.notl. +Proof. + assert (INV: forall v, Val.lessdef (Val.notl (Val.notl v)) v). + { destruct v; auto. simpl; rewrite Int64.not_involutive; auto. } + unfold notl; red; intros until x; case (notl_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. +- exists v1; auto. +- exists (eval_shiftl s v1 a0); split; auto. EvalOp. +- econstructor; split. EvalOp. + destruct v1; simpl; auto; destruct v0; simpl; auto. + rewrite Int64.not_and_or_not, Int64.not_involutive, Int64.or_commut. auto. +- econstructor; split. EvalOp. + destruct v1; simpl; auto; destruct v0; simpl; auto. + rewrite Int64.not_or_and_not, Int64.not_involutive, Int64.and_commut. auto. +- econstructor; split. EvalOp. + destruct v1; simpl; auto; destruct v0; simpl; auto. + unfold Int64.not; rewrite ! Int64.xor_assoc. auto. +- econstructor; split. EvalOp. + destruct v1; simpl; auto; destruct v0; simpl; auto. + unfold Int64.not; rewrite ! Int64.xor_assoc, Int64.xor_idem, Int64.xor_zero. auto. +- TrivialExists. +Qed. + +Lemma eval_andlimm_base: + forall n, unary_constructor_sound (andlimm_base n) (fun x => Val.andl x (Vlong n)). +Proof. + intros; red; intros. unfold andlimm_base. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int64.and_zero. auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + exists x; split; auto. + subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto. + destruct (Z_is_power2m1 (Int64.unsigned n)) as [s|] eqn:P. + assert (0 <= s) by (eapply Z_is_power2m1_nonneg; eauto). + rewrite <- (Int64.repr_unsigned n), (Z_is_power2m1_sound _ _ P), <- Val.zero_ext_andl by auto. + apply eval_zero_ext_l; auto. + TrivialExists. +Qed. + +Theorem eval_andlimm: + forall n, unary_constructor_sound (andlimm n) (fun x => Val.andl x (Vlong n)). +Proof. + intros; red; intros until x. unfold andlimm. + case (andlimm_match a); intros; InvEval; subst. +- rewrite Int64.and_commut; TrivialExists. +- rewrite Val.andl_assoc, Int64.and_commut. apply eval_andlimm_base; auto. +- destruct (zle 0 s). ++ replace (Val.zero_ext_l s v1) with (Val.andl v1 (Vlong (Int64.repr (two_p s - 1)))). + rewrite Val.andl_assoc, Int64.and_commut. + apply eval_andlimm_base; auto. + destruct v1; simpl; auto. rewrite Int64.zero_ext_and by auto. auto. ++ apply eval_andlimm_base. EvalOp. +- apply eval_andlimm_base; auto. +Qed. + +Theorem eval_andl: binary_constructor_sound andl Val.andl. +Proof. + red; intros until y; unfold andl; case (andl_match a b); intros; InvEval; subst. +- rewrite Val.andl_commut; apply eval_andlimm; auto. +- apply eval_andlimm; auto. +- rewrite Val.andl_commut; TrivialExists. +- TrivialExists. +- rewrite Val.andl_commut; TrivialExists. +- TrivialExists. +- rewrite Val.andl_commut; TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_orlimm: + forall n, unary_constructor_sound (orlimm n) (fun x => Val.orl x (Vlong n)). +Proof. + intros; red; intros until x. unfold orlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + intros. subst. exists x; split; auto. + destruct x; simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + intros. exists (Vlong Int64.mone); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int64.or_mone. auto. + destruct (orlimm_match a); intros; InvEval; subst. +- rewrite Int64.or_commut; TrivialExists. +- rewrite Val.orl_assoc, Int64.or_commut; TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_orl: binary_constructor_sound orl Val.orl. +Proof. + red; intros until y; unfold orl; case (orl_match a b); intros; InvEval; subst. +- rewrite Val.orl_commut. apply eval_orlimm; auto. +- apply eval_orlimm; auto. +- rewrite Val.orl_commut; TrivialExists. +- TrivialExists. +- rewrite Val.orl_commut; TrivialExists. +- TrivialExists. +- (* shl - shru *) + destruct (Int.eq (Int.add a1 a2) Int64.iwordsize' && same_expr_pure t1 t2) eqn:?. ++ InvBooleans. apply Int.same_if_eq in H. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst. + econstructor; split. EvalOp. + destruct v0; simpl; auto. rewrite ! a64_range. simpl. rewrite <- Int64.or_ror'; auto using a64_range. ++ TrivialExists. +- (* shru - shl *) + destruct (Int.eq (Int.add a2 a1) Int64.iwordsize' && same_expr_pure t1 t2) eqn:?. ++ InvBooleans. apply Int.same_if_eq in H. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst. + econstructor; split. EvalOp. + destruct v0; simpl; auto. rewrite ! a64_range. simpl. + rewrite Int64.or_commut, <- Int64.or_ror'; auto using a64_range. ++ TrivialExists. +- rewrite Val.orl_commut; TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +Lemma eval_xorlimm_base: + forall n, unary_constructor_sound (xorlimm_base n) (fun x => Val.xorl x (Vlong n)). +Proof. + intros; red; intros. unfold xorlimm_base. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int64.xor_zero. auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + subst n. change (Val.xorl x (Vlong Int64.mone)) with (Val.notl x). apply eval_notl; auto. + TrivialExists. +Qed. + +Theorem eval_xorlimm: + forall n, unary_constructor_sound (xorlimm n) (fun x => Val.xorl x (Vlong n)). +Proof. + intros; red; intros until x. unfold xorlimm. + destruct (xorlimm_match a); intros; InvEval; subst. +- rewrite Int64.xor_commut; TrivialExists. +- rewrite Val.xorl_assoc; simpl. rewrite (Int64.xor_commut n2). apply eval_xorlimm_base; auto. +- apply eval_xorlimm_base; auto. +Qed. + +Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. +Proof. + red; intros until y; unfold xorl; case (xorl_match a b); intros; InvEval; subst. +- rewrite Val.xorl_commut; apply eval_xorlimm; auto. +- apply eval_xorlimm; auto. +- rewrite Val.xorl_commut; TrivialExists. +- TrivialExists. +- rewrite Val.xorl_commut; TrivialExists. +- TrivialExists. +- rewrite Val.xorl_commut; TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +(** ** Integer division and modulus *) + +Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. +Proof. + red; intros; unfold divls_base; TrivialExists. +Qed. + +Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. +Proof. + red; intros; unfold modls_base, modl_aux. + exploit Val.modls_divls; eauto. intros (q & A & B). subst z. + TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. +Qed. + +Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. +Proof. + red; intros; unfold divlu_base; TrivialExists. +Qed. + +Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. +Proof. + red; intros; unfold modlu_base, modl_aux. + exploit Val.modlu_divlu; eauto. intros (q & A & B). subst z. + TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. +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. + intros; unfold shrxlimm. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exists x; split; auto. + destruct x; simpl in H0; try discriminate. + change (Int.ltu Int.zero (Int.repr 63)) with true in H0; inv H0. + rewrite Int64.shrx'_zero. auto. +- TrivialExists. +Qed. + +(** General shifts *) + +Theorem eval_shll: binary_constructor_sound shll Val.shll. +Proof. + red; intros until y; unfold shll; case (shll_match b); intros. + InvEval. apply eval_shllimm; auto. + TrivialExists. +Qed. + +Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. +Proof. + red; intros until y; unfold shrl; case (shrl_match b); intros. + InvEval. apply eval_shrlimm; auto. + TrivialExists. +Qed. + +Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. +Proof. + red; intros until y; unfold shrlu; case (shrlu_match b); intros. + InvEval. apply eval_shrluimm; auto. + TrivialExists. +Qed. + +(** Comparisons *) + +Remark option_map_of_bool_inv: forall ov w, + option_map Val.of_bool ov = Some w -> Val.of_optbool ov = w. +Proof. + intros. destruct ov; inv H; auto. +Qed. + +Section COMP_IMM. + +Variable default: comparison -> int64 -> condition. +Variable intsem: comparison -> int64 -> int64 -> bool. +Variable sem: comparison -> val -> val -> option val. + +Hypothesis sem_int: forall c x y, + sem c (Vlong x) (Vlong y) = Some (Val.of_bool (intsem c x y)). +Hypothesis sem_undef: forall c v, + sem c Vundef v = None. +Hypothesis sem_eq: forall x y, + sem Ceq (Vlong x) (Vlong y) = Some (Val.of_bool (Int64.eq x y)). +Hypothesis sem_ne: forall x y, + sem Cne (Vlong x) (Vlong y) = Some (Val.of_bool (negb (Int64.eq x y))). +Hypothesis sem_default: forall c v n, + sem c v (Vlong n) = option_map Val.of_bool (eval_condition (default c n) (v :: nil) m). + +Lemma eval_complimm_default: forall le a x c n2 v, + sem c x (Vlong n2) = Some v -> + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le (Eop (Ocmp (default c n2)) (a:::Enil)) v. +Proof. + intros. EvalOp. simpl. rewrite sem_default in H. apply option_map_of_bool_inv in H. + congruence. +Qed. + +Lemma eval_complimm: + forall le c a n2 x v, + eval_expr ge sp e m le a x -> + sem c x (Vlong n2) = Some v -> + eval_expr ge sp e m le (complimm default intsem c a n2) v. +Proof. + intros until x; unfold complimm; case (complimm_match c a); intros; InvEval; subst. +- (* constant *) + rewrite sem_int in H0; inv H0. EvalOp. destruct (intsem c0 n1 n2); auto. +- (* mask zero *) + predSpec Int64.eq Int64.eq_spec n2 Int64.zero. ++ subst n2. destruct v1; simpl in H0; rewrite ? sem_undef, ? sem_eq in H0; inv H0. + EvalOp. ++ eapply eval_complimm_default; eauto. EvalOp. +- (* mask not zero *) + predSpec Int64.eq Int64.eq_spec n2 Int64.zero. ++ subst n2. destruct v1; simpl in H0; rewrite ? sem_undef, ? sem_ne in H0; inv H0. + EvalOp. ++ eapply eval_complimm_default; eauto. EvalOp. +- (* default *) + eapply eval_complimm_default; eauto. +Qed. + +Hypothesis sem_swap: + forall c x y, sem (swap_comparison c) x y = sem c y x. + +Lemma eval_complimm_swap: + forall le c a n2 x v, + eval_expr ge sp e m le a x -> + sem c (Vlong n2) x = Some v -> + eval_expr ge sp e m le (complimm default intsem (swap_comparison c) a n2) v. +Proof. + intros. eapply eval_complimm; eauto. rewrite sem_swap; auto. +Qed. + +End COMP_IMM. + +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. + intros until y; unfold cmpl; case (cmpl_match a b); intros; InvEval; subst. +- apply eval_complimm_swap with (sem := Val.cmpl) (x := y); auto. + intros; unfold Val.cmpl; rewrite Val.swap_cmpl_bool; auto. +- apply eval_complimm with (sem := Val.cmpl) (x := x); auto. +- EvalOp. simpl. rewrite Val.swap_cmpl_bool. apply option_map_of_bool_inv in H1. congruence. +- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence. +- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence. +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. + intros until y; unfold cmplu; case (cmplu_match a b); intros; InvEval; subst. +- apply eval_complimm_swap with (sem := Val.cmplu (Mem.valid_pointer m)) (x := y); auto. + intros; unfold Val.cmplu; rewrite Val.swap_cmplu_bool; auto. +- apply eval_complimm with (sem := Val.cmplu (Mem.valid_pointer m)) (x := x); auto. +- EvalOp. simpl. rewrite Val.swap_cmplu_bool. apply option_map_of_bool_inv in H1. congruence. +- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence. +- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence. +Qed. + + +(** Floating-point conversions *) + +Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. +Proof. + red; intros; TrivialExists. +Qed. + +End CMCONSTR. diff --git a/aarch64/SelectOp.vp b/aarch64/SelectOp.vp new file mode 100644 index 00000000..5bd96987 --- /dev/null +++ b/aarch64/SelectOp.vp @@ -0,0 +1,566 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +Require Import Coqlib Zbits. +Require Import Compopts AST Integers Floats Builtins. +Require Import Op CminorSel. + +Local Open Scope cminorsel_scope. + +(** "ror" shifted operands are not supported by arithmetic operations *) + +Definition arith_shift (s: shift) := + match s with Sror => false | _ => true end. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: ptrofs) := + Eop (Oaddrsymbol id ofs) Enil. + +Definition addrstack (ofs: ptrofs) := + Eop (Oaddrstack ofs) Enil. + +(** ** Integer addition *) + +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil + | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | _ => Eop (Oaddimm n) (e ::: Enil) + end. + +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oshift s a) (t1:::Enil), t2 ?? arith_shift s => + Eop (Oaddshift s a) (t2 ::: t1 ::: Enil) + | 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) + | t1, Eop Omul (t2:::t3:::Enil) => + Eop Omuladd (t1:::t2:::t3:::Enil) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. + +(** ** Opposite *) + +Nondetfunction negint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil + | Eop (Oshift s a) (t1:::Enil) ?? arith_shift s => Eop (Onegshift s a) (t1:::Enil) + | _ => Eop Oneg (e ::: 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 (Oshift s a) (t2:::Enil) ?? arith_shift s => + Eop (Osubshift s a) (t1:::t2::: Enil) + | t1, Eop Omul (t2:::t3:::Enil) => + Eop Omulsub (t1:::t2:::t3:::Enil) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. + +(** ** Immediate shift left *) + +Definition shlimm_base (e1: expr) (n: int) := + Eop (Oshift Slsl (mk_amount32 n)) (e1 ::: Enil). + +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 (Oshift Slsl a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int.iwordsize + then shlimm_base t1 (Int.add a n) + else shlimm_base e1 n + | Eop (Ozext s) (t1:::Enil) => + Eop (Oshlzext s (mk_amount32 n)) (t1:::Enil) + | Eop (Osext s) (t1:::Enil) => + Eop (Oshlsext s (mk_amount32 n)) (t1:::Enil) + | Eop (Oshlzext s a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int.iwordsize + then Eop (Oshlzext s (mk_amount32 (Int.add a n))) (t1:::Enil) + else shlimm_base e1 n + | Eop (Oshlsext s a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int.iwordsize + then Eop (Oshlsext s (mk_amount32 (Int.add a n))) (t1:::Enil) + else shlimm_base e1 n + | _ => + shlimm_base e1 n + end. + +(** ** Immediate shift right (logical) *) + +Definition shruimm_base (e1: expr) (n: int) := + Eop (Oshift Slsr (mk_amount32 n)) (e1 ::: Enil). + +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 (Oshift Slsl a) (t1:::Enil) => + if Int.ltu n a + then Eop (Oshlzext (Int.zwordsize - Int.unsigned a) (mk_amount32 (Int.sub a n))) (t1:::Enil) + else Eop (Ozextshr (mk_amount32 (Int.sub n a)) (Int.zwordsize - Int.unsigned n)) (t1:::Enil) + | Eop (Oshift Slsr a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int.iwordsize + then shruimm_base t1 (Int.add a n) + else shruimm_base e1 n + | Eop (Ozext s) (t1:::Enil) => + if zlt (Int.unsigned n) s + then Eop (Ozextshr (mk_amount32 n) (s - Int.unsigned n)) (t1:::Enil) + else Eop (Ointconst Int.zero) Enil + | _ => + shruimm_base e1 n + end. + +(** ** Immediate shift right (arithmetic) *) + +Definition shrimm_base (e1: expr) (n: int) := + Eop (Oshift Sasr (mk_amount32 n)) (e1 ::: Enil). + +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 (Oshift Slsl a) (t1:::Enil) => + if Int.ltu n a + then Eop (Oshlsext (Int.zwordsize - Int.unsigned a) (mk_amount32 (Int.sub a n))) (t1:::Enil) + else Eop (Osextshr (mk_amount32 (Int.sub n a)) (Int.zwordsize - Int.unsigned n)) (t1:::Enil) + | Eop (Oshift Sasr a) (t1:::Enil) => + if Int.ltu (Int.add a n) Int.iwordsize + then shrimm_base t1 (Int.add a n) + else shrimm_base e1 n + | Eop (Osext s) (t1:::Enil) => + if zlt (Int.unsigned n) s && zlt s Int.zwordsize + then Eop (Osextshr (mk_amount32 n) (s - Int.unsigned n)) (t1:::Enil) + else shrimm_base e1 n + | _ => + shrimm_base e1 n + end. + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) + end. + +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. + +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. + +Definition mulhs (e1: expr) (e2: expr) := + Eop Olowlong + (Eop (Oshiftl Sasr (mk_amount64 (Int.repr 32))) + (Eop Omull (Eop (Oextend Xsgn32 (mk_amount64 Int.zero)) (e1 ::: Enil) ::: + Eop (Oextend Xsgn32 (mk_amount64 Int.zero)) (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil). + +Definition mulhu (e1: expr) (e2: expr) := + Eop Olowlong + (Eop (Oshiftl Slsr (mk_amount64 (Int.repr 32))) + (Eop Omull (Eop (Oextend Xuns32 (mk_amount64 Int.zero)) (e1 ::: Enil) ::: + Eop (Oextend Xuns32 (mk_amount64 Int.zero)) (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil). + +(** ** Integer conversions *) + +Nondetfunction zero_ext (sz: Z) (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.zero_ext sz n)) Enil + | Eop (Oshift Slsr a) (t1:::Enil) => Eop (Ozextshr a sz) (t1:::Enil) + | Eop (Oshift Slsl a) (t1:::Enil) => + if zlt (Int.unsigned a) sz + then Eop (Oshlzext (sz - Int.unsigned a) a) (t1:::Enil) + else Eop (Ozext sz) (e:::Enil) + | _ => Eop (Ozext sz) (e:::Enil) + end. + +Nondetfunction sign_ext (sz: Z) (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext sz n)) Enil + | Eop (Oshift Sasr a) (t1:::Enil) => Eop (Osextshr a sz) (t1:::Enil) + | Eop (Oshift Slsl a) (t1:::Enil) => + if zlt (Int.unsigned a) sz + then Eop (Oshlsext (sz - Int.unsigned a) a) (t1:::Enil) + else Eop (Osext sz) (e:::Enil) + | _ => Eop (Osext sz) (e:::Enil) + end. + +Definition cast8unsigned (e: expr) := zero_ext 8 e. +Definition cast8signed (e: expr) := sign_ext 8 e. +Definition cast16unsigned (e: expr) := zero_ext 16 e. +Definition cast16signed (e: expr) := sign_ext 16 e. + +(** ** Bitwise not *) + +Nondetfunction notint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.not n)) Enil + | Eop (Oshift s a) (t1:::Enil) => Eop (Onotshift s a) (t1:::Enil) + | Eop Onot (t1:::Enil) => t1 + | Eop (Onotshift s a) (t1:::Enil) => Eop (Oshift s a) (t1:::Enil) + | Eop Obic (t1:::t2:::Enil) => Eop Oorn (t2:::t1:::Enil) + | Eop Oorn (t1:::t2:::Enil) => Eop Obic (t2:::t1:::Enil) + | Eop Oxor (t1:::t2:::Enil) => Eop Oeqv (t1:::t2:::Enil) + | Eop Oeqv (t1:::t2:::Enil) => Eop Oxor (t1:::t2:::Enil) + | _ => Eop Onot (e:::Enil) + end. + +(** ** Bitwise and *) + +Definition andimm_base (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 Z_is_power2m1 (Int.unsigned n1) with + | Some s => zero_ext s e2 + | None => Eop (Oandimm n1) (e2 ::: Enil) + end. + +Nondetfunction andimm (n1: int) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => andimm_base (Int.and n1 n2) t2 + | Eop (Ozext s) (t2:::Enil) => + if zle 0 s + then andimm_base (Int.and n1 (Int.repr (two_p s - 1))) t2 + else andimm_base n1 e2 + | _ => andimm_base n1 e2 + 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 Obic (t2:::t1:::Enil) + | t1, Eop Onot (t2:::Enil) => Eop Obic (t1:::t2:::Enil) + | Eop (Onotshift s a) (t1:::Enil), t2 => Eop (Obicshift s a) (t2:::t1:::Enil) + | t1, Eop (Onotshift s a) (t2:::Enil) => Eop (Obicshift s a) (t1:::t2:::Enil) + | Eop (Oshift s a) (t1:::Enil), t2 => Eop (Oandshift s a) (t2:::t1:::Enil) + | t1, Eop (Oshift s a) (t2:::Enil) => Eop (Oandshift s a) (t1:::t2:::Enil) + | _, _ => Eop Oand (e1:::e2:::Enil) + end. + +(** ** Bitwise or *) + +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. + +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 Onot (t1:::Enil), t2 => Eop Oorn (t2:::t1:::Enil) + | t1, Eop Onot (t2:::Enil) => Eop Oorn (t1:::t2:::Enil) + | Eop (Onotshift s a) (t1:::Enil), t2 => Eop (Oornshift s a) (t2:::t1:::Enil) + | t1, Eop (Onotshift s a) (t2:::Enil) => Eop (Oornshift s a) (t1:::t2:::Enil) + | Eop (Oshift Slsl a1) (t1:::Enil), Eop (Oshift Slsr a2) (t2:::Enil) => + if Int.eq (Int.add a1 a2) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Oshift Sror a2) (t2:::Enil) + else Eop (Oorshift Slsr a2) (Eop (Oshift Slsl a1) (t1:::Enil):::t2:::Enil) + | Eop (Oshift Slsr a1) (t1:::Enil), Eop (Oshift Slsl a2) (t2:::Enil) => + if Int.eq (Int.add a2 a1) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Oshift Sror a1) (t1:::Enil) + else Eop (Oorshift Slsl a2) (Eop (Oshift Slsr a1) (t1:::Enil):::t2:::Enil) + | Eop (Oshift s a) (t1:::Enil), t2 => Eop (Oorshift s a) (t2:::t1:::Enil) + | t1, Eop (Oshift s a) (t2:::Enil) => Eop (Oorshift s a) (t1:::t2:::Enil) + | _, _ => Eop Oor (e1:::e2:::Enil) + end. + +(** ** Bitwise xor *) + +Definition xorimm_base (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else + if Int.eq n1 Int.mone then notint e2 else + Eop (Oxorimm n1) (e2:::Enil). + +Nondetfunction xorimm (n1: int) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => xorimm_base (Int.xor n1 n2) t2 + | _ => xorimm_base n1 e2 + 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 Onot (t1:::Enil), t2 => Eop Oeqv (t2:::t1:::Enil) + | t1, Eop Onot (t2:::Enil) => Eop Oeqv (t1:::t2:::Enil) + | Eop (Onotshift s a) (t1:::Enil), t2 => Eop (Oeqvshift s a) (t2:::t1:::Enil) + | t1, Eop (Onotshift s a) (t2:::Enil) => Eop (Oeqvshift s a) (t1:::t2:::Enil) + | Eop (Oshift s a) (t1:::Enil), t2 => Eop (Oxorshift s a) (t2:::t1:::Enil) + | t1, Eop (Oshift s a) (t2:::Enil) => Eop (Oxorshift s a) (t1:::t2:::Enil) + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition mod_aux (divop: operation) (e1 e2: expr) := + Elet e1 + (Elet (lift e2) + (Eop Omulsub (Eletvar 1 ::: + Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: + Eletvar 0 ::: + Enil))). + +Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition mods_base := mod_aux Odiv. +Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). +Definition modu_base := mod_aux Odivu. + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::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 + | Ceq, Eop (Oandimm m) (t1:::Enil) => + if Int.eq n2 Int.zero + then Eop (Ocmp (Cmaskzero m)) (t1:::Enil) + else Eop (Ocmp (default c n2)) (e1:::Enil) + | Cne, Eop (Oandimm m) (t1:::Enil) => + if Int.eq n2 Int.zero + then Eop (Ocmp (Cmasknotzero m)) (t1:::Enil) + else Eop (Ocmp (default c n2)) (e1:::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 (Oshift s a) (t1:::Enil), t2 ?? arith_shift s => + Eop (Ocmp (Ccompshift (swap_comparison c) s a)) (t2:::t1:::Enil) + | t1, Eop (Oshift s a) (t2:::Enil) ?? arith_shift s => + Eop (Ocmp (Ccompshift c s a)) (t1:::t2:::Enil) + | _, _ => + 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 (Oshift s a) (t1:::Enil), t2 ?? arith_shift s => + Eop (Ocmp (Ccompushift (swap_comparison c) s a)) (t2:::t1:::Enil) + | t1, Eop (Oshift s a) (t2:::Enil) ?? arith_shift s => + Eop (Ocmp (Ccompushift c s a)) (t1:::t2:::Enil) + | _, _ => + 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). + +(** ** Floating-point conversions *) + +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). + +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => Eop Ofloatofintu (e ::: Enil) + end. + +Nondetfunction floatofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil + | _ => Eop Ofloatofint (e ::: Enil) + end. + +Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). +Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). + +Nondetfunction singleofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_int n)) Enil + | _ => Eop Osingleofint (e ::: Enil) + end. + +Nondetfunction singleofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_intu n)) Enil + | _ => Eop Osingleofintu (e ::: Enil) + end. + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). + +(** ** Selection *) + +Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) := + if match ty with + | Tint => true + | Tlong => true + | Tfloat => true + | Tsingle => true + | _ => false + end + then Some (Eop (Osel cond ty) (e1 ::: e2 ::: args)) + else None. + +(** ** 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 => (Aglobal id ofs, Enil) + | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) + | Eop (Oaddlshift Slsl a) (e1:::e2:::Enil) => (Aindexed2shift a, e1:::e2:::Enil) + | Eop (Oaddlext x a) (e1:::e2:::Enil) => (Aindexed2ext x a, e1:::e2:::Enil) + | Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) + | _ => (Aindexed Int64.zero, e:::Enil) + end. + +(** ** Arguments of builtins *) + +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Olongconst n) Enil => BA_long n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | Eop (Oaddlimm n) (e1:::Enil) => BA_addptr (BA e1) (BA_long n) + | _ => BA e + end. + +(** Platform-specific known builtins *) + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. diff --git a/aarch64/SelectOpproof.v b/aarch64/SelectOpproof.v new file mode 100644 index 00000000..b78a5ed8 --- /dev/null +++ b/aarch64/SelectOpproof.v @@ -0,0 +1,1070 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection for operators *) + +Require Import Coqlib Zbits. +Require Import AST Integers Floats Values Memory Builtins Globalenvs. +Require Import Cminor Op CminorSel. +Require Import SelectOp. + +Local Open Scope cminorsel_scope. +Local Transparent Archi.ptr64. + +(** * 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 := + eauto with evalexpr; + match goal with + | [ |- eval_expr _ _ _ _ _ _ _ ] => eapply eval_Eop; [EvalOp|try reflexivity; auto] + | [ |- eval_exprlist _ _ _ _ _ _ _ ] => econstructor; EvalOp + | _ => idtac + end. + +Ltac InvEval1 := + match goal with + | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => + inv H; InvEval1 + | _ => + idtac + end. + +Ltac InvEval2 := + match goal with + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => + simpl in H; inv H + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | _ => + idtac + end. + +Ltac InvEval := InvEval1; InvEval2; InvEval2. + +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + +(** * Correctness of the smart constructors *) + +Section CMCONSTR. + +Variable ge: genv. +Variable sp: val. +Variable e: env. +Variable m: mem. + +(** We now show that the code generated by "smart constructor" functions + such as [Selection.notint] behaves as expected. Continuing the + [notint] example, we show that if the expression [e] + evaluates to some integer value [Vint n], then [Selection.notint e] + evaluates to a value [Vint (Int.not n)] which is indeed the integer + negation of the value of [e]. + + All proofs follow a common pattern: +- Reasoning by case over the result of the classification functions + (such as [add_match] for integer addition), gathering additional + information on the shape of the argument expressions in the non-default + cases. +- Inversion of the evaluations of the arguments, exploiting the additional + information thus gathered. +- Equational reasoning over the arithmetic operations performed, + using the lemmas from the [Int] and [Float] modules. +- Construction of an evaluation derivation for the expression returned + by the smart constructor. +*) + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +(** ** Constants *) + +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. TrivialExists. +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. TrivialExists. +Qed. + +(** ** Addition, opposite, subtraction *) + +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. ++ subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. +Qed. + +Theorem eval_add: binary_constructor_sound add Val.add. +Proof. + red; intros until y. + unfold add; case (add_match a b); intros; InvEval; subst. +- rewrite Val.add_commut. apply eval_addimm; auto. +- apply eval_addimm; auto. +- 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. +- 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. +- rewrite <- Val.add_assoc. apply eval_addimm. EvalOp. +- rewrite Val.add_commut. TrivialExists. +- TrivialExists. +- rewrite Val.add_commut. TrivialExists. +- TrivialExists. +- 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; subst. +- TrivialExists. +- TrivialExists. +- 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; subst. +- rewrite Val.sub_add_opp. apply eval_addimm; auto. +- 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. +- rewrite Val.sub_add_l. apply eval_addimm; EvalOp. +- rewrite Val.sub_add_r. apply eval_addimm; EvalOp. +- TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +(** ** Immediate shifts *) + +Remark eval_shlimm_base: forall le a n x, + eval_expr ge sp e m le a x -> + Int.ltu n Int.iwordsize = true -> + eval_expr ge sp e m le (shlimm_base a n) (Val.shl x (Vint n)). +Proof. +Local Opaque mk_amount32. + unfold shlimm_base; intros; EvalOp. simpl. rewrite mk_amount32_eq by auto. auto. +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; [| destruct (Int.ltu n Int.iwordsize) eqn:L]; simpl. +- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. +- destruct (shlimm_match a); intros; InvEval; subst. ++ TrivialExists. simpl; rewrite L; auto. ++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2. +* econstructor; split. eapply eval_shlimm_base; eauto. + destruct v1; simpl; auto. rewrite a32_range; simpl. rewrite L, L2. + rewrite Int.shl_shl; auto using a32_range. +* econstructor; split; [|eauto]. apply eval_shlimm_base; auto. EvalOp. ++ TrivialExists. simpl. rewrite mk_amount32_eq; auto. ++ TrivialExists. simpl. rewrite mk_amount32_eq; auto. ++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2. +* TrivialExists. simpl. rewrite mk_amount32_eq by auto. + destruct (Val.zero_ext s v1); simpl; auto. + rewrite a32_range; simpl; rewrite L, L2. + rewrite Int.shl_shl; auto using a32_range. +* econstructor; split. eapply eval_shlimm_base; eauto. EvalOp; simpl; eauto. auto. ++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2. +* TrivialExists. simpl. rewrite mk_amount32_eq by auto. + destruct (Val.sign_ext s v1); simpl; auto. + rewrite a32_range; simpl; rewrite L, L2. + rewrite Int.shl_shl; auto using a32_range. +* econstructor; split. eapply eval_shlimm_base; eauto. EvalOp; simpl; eauto. auto. ++ econstructor; eauto using eval_shlimm_base. +- intros; TrivialExists. +Qed. + +Remark eval_shruimm_base: forall le a n x, + eval_expr ge sp e m le a x -> + Int.ltu n Int.iwordsize = true -> + eval_expr ge sp e m le (shruimm_base a n) (Val.shru x (Vint n)). +Proof. + unfold shruimm_base; intros; EvalOp. simpl. rewrite mk_amount32_eq by auto. auto. +Qed. + +Remark sub_shift_amount: + forall y z, + Int.ltu y Int.iwordsize = true -> Int.ltu z Int.iwordsize = true -> Int.unsigned y <= Int.unsigned z -> + Int.ltu (Int.sub z y) Int.iwordsize = true. +Proof. + intros. unfold Int.ltu; apply zlt_true. rewrite Int.unsigned_repr_wordsize. + apply Int.ltu_iwordsize_inv in H. apply Int.ltu_iwordsize_inv in H0. + unfold Int.sub; rewrite Int.unsigned_repr. omega. + generalize Int.wordsize_max_unsigned; omega. +Qed. + +Theorem eval_shruimm: + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). +Proof. +Local Opaque Int.zwordsize. + red; intros until x; unfold shruimm. + predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int.iwordsize) eqn:L]; simpl. +- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. +- destruct (shruimm_match a); intros; InvEval; subst. ++ TrivialExists. simpl; rewrite L; auto. ++ destruct (Int.ltu n a) eqn:L2. +* assert (L3: Int.ltu (Int.sub a n) Int.iwordsize = true). + { apply sub_shift_amount; auto using a32_range. + apply Int.ltu_inv in L2. omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. + simpl. rewrite L. rewrite Int.shru_shl, L2 by auto using a32_range. auto. +* assert (L3: Int.ltu (Int.sub n a) Int.iwordsize = true). + { apply sub_shift_amount; auto using a32_range. + unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. + simpl. rewrite L. rewrite Int.shru_shl, L2 by auto using a32_range. auto. ++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2. +* econstructor; split. eapply eval_shruimm_base; eauto. + destruct v1; simpl; auto. rewrite a32_range; simpl. rewrite L, L2. + rewrite Int.shru_shru; auto using a32_range. +* econstructor; split; [|eauto]. apply eval_shruimm_base; auto. EvalOp. ++ destruct (zlt (Int.unsigned n) s). +* econstructor; split. EvalOp. rewrite mk_amount32_eq by auto. + destruct v1; simpl; auto. rewrite ! L; simpl. + set (s' := s - Int.unsigned n). + replace s with (s' + Int.unsigned n) by (unfold s'; omega). + rewrite Int.shru_zero_ext. auto. unfold s'; omega. +* econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite ! L; simpl. + rewrite Int.shru_zero_ext_0 by omega. auto. ++ econstructor; eauto using eval_shruimm_base. +- intros; TrivialExists. +Qed. + +Remark eval_shrimm_base: forall le a n x, + eval_expr ge sp e m le a x -> + Int.ltu n Int.iwordsize = true -> + eval_expr ge sp e m le (shrimm_base a n) (Val.shr x (Vint n)). +Proof. + unfold shrimm_base; intros; EvalOp. simpl. rewrite mk_amount32_eq by auto. 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; [| destruct (Int.ltu n Int.iwordsize) eqn:L]; simpl. +- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. +- destruct (shrimm_match a); intros; InvEval; subst. ++ TrivialExists. simpl; rewrite L; auto. ++ destruct (Int.ltu n a) eqn:L2. +* assert (L3: Int.ltu (Int.sub a n) Int.iwordsize = true). + { apply sub_shift_amount; auto using a32_range. + apply Int.ltu_inv in L2. omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. + simpl. rewrite L. rewrite Int.shr_shl, L2 by auto using a32_range. auto. +* assert (L3: Int.ltu (Int.sub n a) Int.iwordsize = true). + { apply sub_shift_amount; auto using a32_range. + unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. } + econstructor; split. EvalOp. + destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto. + simpl. rewrite L. rewrite Int.shr_shl, L2 by auto using a32_range. auto. ++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2. +* econstructor; split. eapply eval_shrimm_base; eauto. + destruct v1; simpl; auto. rewrite a32_range; simpl. rewrite L, L2. + rewrite Int.shr_shr; auto using a32_range. +* econstructor; split; [|eauto]. apply eval_shrimm_base; auto. EvalOp. ++ destruct (zlt (Int.unsigned n) s && zlt s Int.zwordsize) eqn:E. +* InvBooleans. econstructor; split. EvalOp. rewrite mk_amount32_eq by auto. + destruct v1; simpl; auto. rewrite ! L; simpl. + set (s' := s - Int.unsigned n). + replace s with (s' + Int.unsigned n) by (unfold s'; omega). + rewrite Int.shr_sign_ext. auto. unfold s'; omega. unfold s'; omega. +* econstructor; split; [|eauto]. apply eval_shrimm_base; auto. EvalOp. ++ econstructor; eauto using eval_shrimm_base. +- intros; TrivialExists. +Qed. + +(** ** Multiplication *) + +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). + { rewrite Val.mul_commut; TrivialExists. } + generalize (Int.one_bits_decomp n); generalize (Int.one_bits_range n); + destruct (Int.one_bits n) as [ | i [ | j []]]; intros P Q. +- apply DFL. +- replace (Val.mul x (Vint n)) with (Val.shl x (Vint i)). + apply eval_shlimm; auto. + simpl in Q. rewrite <- Val.shl_mul, Q, Int.add_zero. simpl. rewrite P by auto with coqlib. auto. +- exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm j (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. + simpl in Q. rewrite Q, Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one j))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint j))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. eapply Val.lessdef_trans; [|eauto]. apply Val.add_lessdef; auto. + simpl. repeat rewrite P by auto with coqlib. auto. +- apply DFL. +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; subst. +- TrivialExists. simpl. rewrite Int.mul_commut; auto. +- 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; subst. +- rewrite Val.mul_commut. apply eval_mulimm; auto. +- apply eval_mulimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mulhs: binary_constructor_sound mulhs Val.mulhs. +Proof. + unfold mulhs; red; intros. econstructor; split. EvalOp. + unfold eval_shiftl, eval_extend. rewrite ! mk_amount64_eq by auto. + destruct x; simpl; auto. destruct y; simpl; auto. + change (Int.ltu Int.zero Int64.iwordsize') with true; simpl. + rewrite ! Int64.shl'_zero. + 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 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. +Qed. + +Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu. +Proof. + unfold mulhu; red; intros. econstructor; split. EvalOp. + unfold eval_shiftl, eval_extend. rewrite ! mk_amount64_eq by auto. + destruct x; simpl; auto. destruct y; simpl; auto. + change (Int.ltu Int.zero Int64.iwordsize') with true; simpl. + rewrite ! Int64.shl'_zero. + 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 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. +Qed. + +(** Integer conversions *) + +Theorem eval_zero_ext: + forall sz, 0 <= sz -> unary_constructor_sound (zero_ext sz) (Val.zero_ext sz). +Proof. + intros; red; intros until x; unfold zero_ext; case (zero_ext_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. +- destruct (zlt (Int.unsigned a0) sz). ++ econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a32_range; simpl. + apply Val.lessdef_same. f_equal. rewrite Int.shl_zero_ext by omega. f_equal. omega. ++ TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_sign_ext: + forall sz, 0 < sz -> unary_constructor_sound (sign_ext sz) (Val.sign_ext sz). +Proof. + intros; red; intros until x; unfold sign_ext; case (sign_ext_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. +- destruct (zlt (Int.unsigned a0) sz). ++ econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a32_range; simpl. + apply Val.lessdef_same. f_equal. rewrite Int.shl_sign_ext by omega. f_equal. omega. ++ TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + apply eval_sign_ext; omega. +Qed. + +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). +Proof. + apply eval_zero_ext; omega. +Qed. + +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + apply eval_sign_ext; omega. +Qed. + +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + apply eval_zero_ext; omega. +Qed. + +(** Bitwise not, and, or, xor *) + +Theorem eval_notint: unary_constructor_sound notint Val.notint. +Proof. + assert (INV: forall v, Val.lessdef (Val.notint (Val.notint v)) v). + { destruct v; auto. simpl; rewrite Int.not_involutive; auto. } + unfold notint; red; intros until x; case (notint_match a); intros; InvEval; subst. +- TrivialExists. +- TrivialExists. +- exists v1; auto. +- exists (eval_shift s v1 a0); split; auto. EvalOp. +- econstructor; split. EvalOp. + destruct v1; simpl; auto; destruct v0; simpl; auto. + rewrite Int.not_and_or_not, Int.not_involutive, Int.or_commut. auto. +- econstructor; split. EvalOp. + destruct v1; simpl; auto; destruct v0; simpl; auto. + rewrite Int.not_or_and_not, Int.not_involutive, Int.and_commut. auto. +- econstructor; split. EvalOp. + rewrite ! Val.not_xor, Val.xor_assoc; auto. +- econstructor; split. EvalOp. + destruct v1; simpl; auto; destruct v0; simpl; auto. + unfold Int.not; rewrite ! Int.xor_assoc, Int.xor_idem, Int.xor_zero. auto. +- TrivialExists. +Qed. + +Lemma eval_andimm_base: + forall n, unary_constructor_sound (andimm_base n) (fun x => Val.and x (Vint n)). +Proof. + intros; red; intros. unfold andimm_base. + predSpec Int.eq Int.eq_spec n Int.zero. + 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. + exists x; split; auto. + subst. destruct x; simpl; auto. rewrite Int.and_mone; auto. + destruct (Z_is_power2m1 (Int.unsigned n)) as [s|] eqn:P. + assert (0 <= s) by (eapply Z_is_power2m1_nonneg; eauto). + rewrite <- (Int.repr_unsigned n), (Z_is_power2m1_sound _ _ P), <- Val.zero_ext_and by auto. + apply eval_zero_ext; auto. + 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. + case (andimm_match a); intros; InvEval; subst. +- rewrite Int.and_commut; TrivialExists. +- rewrite Val.and_assoc, Int.and_commut. apply eval_andimm_base; auto. +- destruct (zle 0 s). ++ rewrite Val.zero_ext_and, Val.and_assoc, Int.and_commut by auto. + apply eval_andimm_base; auto. ++ apply eval_andimm_base. EvalOp. +- apply eval_andimm_base; auto. +Qed. + +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval; subst. +- rewrite Val.and_commut; apply eval_andimm; auto. +- apply eval_andimm; auto. +- rewrite Val.and_commut; TrivialExists. +- TrivialExists. +- rewrite Val.and_commut; TrivialExists. +- TrivialExists. +- rewrite Val.and_commut; TrivialExists. +- TrivialExists. +- 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; subst. +- rewrite Int.or_commut; TrivialExists. +- rewrite Val.or_assoc, Int.or_commut; TrivialExists. +- 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. destruct a1; try discriminate. destruct a2; try discriminate. + simpl in H; destruct (ident_eq i i0); inv H. + split. auto. inv H0; inv H1; congruence. +Qed. + +Theorem eval_or: binary_constructor_sound or Val.or. +Proof. + red; intros until y; unfold or; case (or_match a b); intros; InvEval; subst. +- rewrite Val.or_commut. apply eval_orimm; auto. +- apply eval_orimm; auto. +- rewrite Val.or_commut; TrivialExists. +- TrivialExists. +- rewrite Val.or_commut; TrivialExists. +- TrivialExists. +- (* shl - shru *) + destruct (Int.eq (Int.add a1 a2) Int.iwordsize && same_expr_pure t1 t2) eqn:?. ++ InvBooleans. apply Int.same_if_eq in H. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst. + econstructor; split. EvalOp. + destruct v0; simpl; auto. rewrite ! a32_range. simpl. rewrite <- Int.or_ror; auto using a32_range. ++ TrivialExists. +- (* shru - shl *) + destruct (Int.eq (Int.add a2 a1) Int.iwordsize && same_expr_pure t1 t2) eqn:?. ++ InvBooleans. apply Int.same_if_eq in H. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst. + econstructor; split. EvalOp. + destruct v0; simpl; auto. rewrite ! a32_range. simpl. + rewrite Int.or_commut, <- Int.or_ror; auto using a32_range. ++ TrivialExists. +- rewrite Val.or_commut; TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +Lemma eval_xorimm_base: + forall n, unary_constructor_sound (xorimm_base n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros. unfold xorimm_base. + 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. rewrite <- Val.not_xor. apply eval_notint; auto. + TrivialExists. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. unfold xorimm. + destruct (xorimm_match a); intros; InvEval; subst. +- rewrite Int.xor_commut; TrivialExists. +- rewrite Val.xor_assoc; simpl. rewrite (Int.xor_commut n2). apply eval_xorimm_base; auto. +- apply eval_xorimm_base; auto. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval; subst. +- rewrite Val.xor_commut; apply eval_xorimm; auto. +- apply eval_xorimm; auto. +- rewrite Val.xor_commut; TrivialExists. +- TrivialExists. +- rewrite Val.xor_commut; TrivialExists. +- TrivialExists. +- rewrite Val.xor_commut; TrivialExists. +- TrivialExists. +- TrivialExists. +Qed. + +(** ** Integer division and modulus *) + +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; TrivialExists. +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, mod_aux. + exploit Val.mods_divs; eauto. intros (q & A & B). subst z. + TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. +Qed. + +Theorem eval_divu_base: + 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 -> + 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; TrivialExists. +Qed. + +Theorem eval_modu_base: + 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 -> + 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, mod_aux. + exploit Val.modu_divu; eauto. intros (q & A & B). subst z. + TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. +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. + change (Int.ltu Int.zero (Int.repr 31)) with true in H0; inv H0. + rewrite Int.shrx_zero by (compute; auto). auto. +- TrivialExists. +Qed. + +(** General shifts *) + +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. + +(** Floating-point operations *) + +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; InvEval; subst. +- (* constant *) + rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto. +- (* eq cmp *) + 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 *) + 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. +- (* mask zero *) + predSpec Int.eq Int.eq_spec n2 Int.zero. ++ subst n2. econstructor; split. EvalOp. simpl. + destruct v1; simpl; try (rewrite sem_undef; auto). + rewrite sem_eq. destruct (Int.eq (Int.and i m0) Int.zero); auto. ++ TrivialExists. simpl. rewrite sem_default. auto. +- (* mask not zero *) + predSpec Int.eq Int.eq_spec n2 Int.zero. ++ subst n2. econstructor; split. EvalOp. simpl. + destruct v1; simpl; try (rewrite sem_undef; auto). + rewrite sem_ne. destruct (Int.eq (Int.and i m0) Int.zero); auto. ++ TrivialExists. simpl. rewrite sem_default. 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; subst. +- eapply eval_compimm_swap; eauto. + intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto. +- eapply eval_compimm; eauto. +- TrivialExists. simpl. rewrite Val.swap_cmp_bool. auto. +- TrivialExists. +- 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; subst. +- eapply eval_compimm_swap; eauto. + intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto. +- eapply eval_compimm; eauto. +- TrivialExists. simpl. rewrite Val.swap_cmpu_bool. auto. +- TrivialExists. +- 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. + +(** Floating-point conversions *) + +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle. +Proof. + red; intros; TrivialExists. +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; TrivialExists. +Qed. + +Theorem eval_floatofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold floatofint. case (floatofint_match a); intros; InvEval. +- TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_intuoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros; TrivialExists. +Qed. + +Theorem eval_floatofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold floatofintu. case (floatofintu_match a); intros; InvEval. +- TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_intofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. +Proof. + intros; TrivialExists. +Qed. + +Theorem eval_singleofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofint x = Some y -> + exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold singleofint. case (singleofint_match a); intros; InvEval. +- TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_intuofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. +Proof. + intros; TrivialExists. +Qed. + +Theorem eval_singleofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofintu x = Some y -> + exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold singleofintu. case (singleofintu_match a); intros; InvEval. +- TrivialExists. +- TrivialExists. +Qed. + +(** Selection *) + +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. + destruct (match ty with Tint | Tlong | Tfloat | Tsingle => true | _ => false end); inv H. + rewrite <- H3; TrivialExists. +Qed. + +(** Addressing modes *) + +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. +- econstructor; split. EvalOp. simpl; auto. +- econstructor; split. EvalOp. simpl; auto. +- econstructor; split. EvalOp. simpl. + destruct v1; try discriminate. rewrite <- H; auto. +- econstructor; split. EvalOp. simpl. congruence. +- econstructor; split. EvalOp. simpl. congruence. +- econstructor; split. EvalOp. simpl. congruence. +- econstructor; split. EvalOp. simpl. rewrite H0. simpl. rewrite Ptrofs.add_zero; auto. +Qed. + +(** Builtins *) + +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. +- constructor. +- constructor. +- constructor. +- inv H. InvEval. simpl in H6. inv H6. constructor; auto. +- subst v. repeat constructor; auto. +- constructor; auto. +Qed. + +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + +End CMCONSTR. diff --git a/aarch64/Stacklayout.v b/aarch64/Stacklayout.v new file mode 100644 index 00000000..86ba9f45 --- /dev/null +++ b/aarch64/Stacklayout.v @@ -0,0 +1,140 @@ +(* *********************************************************************) +(* *) +(* 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 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 olink := align (4 * b.(bound_outgoing)) 8 in (* back link *) + let oretaddr := olink + 8 in (* return address *) + let ocs := oretaddr + 8 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 (olink := align (4 * b.(bound_outgoing)) 8). + set (oretaddr := olink + 8). + set (ocs := oretaddr + 8). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + change (size_chunk Mptr) with 8. + 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 + 8 <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + 8 <= 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 (olink := align (4 * b.(bound_outgoing)) 8). + set (oretaddr := olink + 8). + set (ocs := oretaddr + 8). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + 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 + 8 <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + 8 <= 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 (olink := align (4 * b.(bound_outgoing)) 8). + set (oretaddr := olink + 8). + set (ocs := oretaddr + 8). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + change (align_chunk Mptr) with 8. + 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/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml new file mode 100644 index 00000000..e54673dd --- /dev/null +++ b/aarch64/TargetPrinter.ml @@ -0,0 +1,592 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Printing AArch64 assembly code in asm syntax *) + +open Printf +open Camlcoq +open Sections +open AST +open Asm +open AisAnnot +open PrintAsmaux +open Fileinfo + +(* Recognition of FP numbers that are supported by the fmov #imm instructions: + "a normalized binary floating point encoding with 1 sign bit, + 4 bits of fraction and a 3-bit exponent" +*) + +let is_immediate_float64 bits = + let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in + let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in + exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant + +let is_immediate_float32 bits = + let exp = (Int32.(to_int (shift_right_logical bits 23)) land 0xFF) - 127 in + let mant = Int32.logand bits 0x7F_FFFFl in + exp >= -3 && exp <= 4 && Int32.logand mant 0x78_0000l = mant + +(* Module containing the printing functions *) + +module Target : TARGET = + struct + +(* Basic printing functions *) + + let comment = "//" + + let symbol = elf_symbol + let symbol_offset = elf_symbol_offset + let label = elf_label + + let print_label oc lbl = label oc (transl_label lbl) + + let intsz oc (sz, n) = + match sz with X -> coqint64 oc n | W -> coqint oc n + + let xreg_name = function + | X0 -> "x0" | X1 -> "x1" | X2 -> "x2" | X3 -> "x3" + | X4 -> "x4" | X5 -> "x5" | X6 -> "x6" | X7 -> "x7" + | X8 -> "x8" | X9 -> "x9" | X10 -> "x10" | X11 -> "x11" + | X12 -> "x12" | X13 -> "x13" | X14 -> "x14" | X15 -> "x15" + | X16 -> "x16" | X17 -> "x17" | X18 -> "x18" | X19 -> "x19" + | X20 -> "x20" | X21 -> "x21" | X22 -> "x22" | X23 -> "x23" + | X24 -> "x24" | X25 -> "x25" | X26 -> "x26" | X27 -> "x27" + | X28 -> "x28" | X29 -> "x29" | X30 -> "x30" + + let wreg_name = function + | X0 -> "w0" | X1 -> "w1" | X2 -> "w2" | X3 -> "w3" + | X4 -> "w4" | X5 -> "w5" | X6 -> "w6" | X7 -> "w7" + | X8 -> "w8" | X9 -> "w9" | X10 -> "w10" | X11 -> "w11" + | X12 -> "w12" | X13 -> "w13" | X14 -> "w14" | X15 -> "w15" + | X16 -> "w16" | X17 -> "w17" | X18 -> "w18" | X19 -> "w19" + | X20 -> "w20" | X21 -> "w21" | X22 -> "w22" | X23 -> "w23" + | X24 -> "w24" | X25 -> "w25" | X26 -> "w26" | X27 -> "w27" + | X28 -> "w28" | X29 -> "w29" | X30 -> "w30" + + let xreg0_name = function RR0 r -> xreg_name r | XZR -> "xzr" + let wreg0_name = function RR0 r -> wreg_name r | XZR -> "wzr" + + let xregsp_name = function RR1 r -> xreg_name r | XSP -> "sp" + let wregsp_name = function RR1 r -> wreg_name r | XSP -> "wsp" + + let dreg_name = function + | D0 -> "d0" | D1 -> "d1" | D2 -> "d2" | D3 -> "d3" + | D4 -> "d4" | D5 -> "d5" | D6 -> "d6" | D7 -> "d7" + | D8 -> "d8" | D9 -> "d9" | D10 -> "d10" | D11 -> "d11" + | D12 -> "d12" | D13 -> "d13" | D14 -> "d14" | D15 -> "d15" + | D16 -> "d16" | D17 -> "d17" | D18 -> "d18" | D19 -> "d19" + | D20 -> "d20" | D21 -> "d21" | D22 -> "d22" | D23 -> "d23" + | D24 -> "d24" | D25 -> "d25" | D26 -> "d26" | D27 -> "d27" + | D28 -> "d28" | D29 -> "d29" | D30 -> "d30" | D31 -> "d31" + + let sreg_name = function + | D0 -> "s0" | D1 -> "s1" | D2 -> "s2" | D3 -> "s3" + | D4 -> "s4" | D5 -> "s5" | D6 -> "s6" | D7 -> "s7" + | D8 -> "s8" | D9 -> "s9" | D10 -> "s10" | D11 -> "s11" + | D12 -> "s12" | D13 -> "s13" | D14 -> "s14" | D15 -> "s15" + | D16 -> "s16" | D17 -> "s17" | D18 -> "s18" | D19 -> "s19" + | D20 -> "s20" | D21 -> "s21" | D22 -> "s22" | D23 -> "s23" + | D24 -> "s24" | D25 -> "s25" | D26 -> "s26" | D27 -> "s27" + | D28 -> "s28" | D29 -> "s29" | D30 -> "s30" | D31 -> "s31" + + let xreg oc r = output_string oc (xreg_name r) + let wreg oc r = output_string oc (wreg_name r) + let ireg oc (sz, r) = + output_string oc (match sz with X -> xreg_name r | W -> wreg_name r) + + let xreg0 oc r = output_string oc (xreg0_name r) + let wreg0 oc r = output_string oc (wreg0_name r) + let ireg0 oc (sz, r) = + output_string oc (match sz with X -> xreg0_name r | W -> wreg0_name r) + + let xregsp oc r = output_string oc (xregsp_name r) + let iregsp oc (sz, r) = + output_string oc (match sz with X -> xregsp_name r | W -> wregsp_name r) + + let dreg oc r = output_string oc (dreg_name r) + let sreg oc r = output_string oc (sreg_name r) + let freg oc (sz, r) = + output_string oc (match sz with D -> dreg_name r | S -> sreg_name r) + + let preg_asm oc ty = function + | IR r -> if ty = Tint then wreg oc r else xreg oc r + | FR r -> if ty = Tsingle then sreg oc r else dreg oc r + | _ -> assert false + + let preg_annot = function + | IR r -> xreg_name r + | FR r -> dreg_name r + | _ -> assert false + +(* Names of sections *) + + let name_of_section = function + | Section_text -> ".text" + | Section_data i | Section_small_data i -> + if i then ".data" else common_section () + | Section_const i | Section_small_const i -> + if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" + | Section_string -> ".section .rodata" + | Section_literal -> ".section .rodata" + | Section_jumptable -> ".section .rodata" + | Section_debug_info _ -> ".section .debug_info,\"\",%progbits" + | Section_debug_loc -> ".section .debug_loc,\"\",%progbits" + | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits" + | Section_debug_line _ -> ".section .debug_line,\"\",%progbits" + | Section_debug_ranges -> ".section .debug_ranges,\"\",%progbits" + | Section_debug_str -> ".section .debug_str,\"MS\",%progbits,1" + | Section_user(s, wr, ex) -> + sprintf ".section \"%s\",\"a%s%s\",%%progbits" + s (if wr then "w" else "") (if ex then "x" else "") + | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" + + let section oc sec = + fprintf oc " %s\n" (name_of_section sec) + +(* Associate labels to floating-point constants and to symbols. *) + + let emit_constants oc lit = + if exists_constants () then begin + section oc lit; + if Hashtbl.length literal64_labels > 0 then + begin + fprintf oc " .balign 8\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 " .balign 4\n"; + Hashtbl.iter + (fun bf lbl -> + fprintf oc "%a: .long 0x%lx\n" label lbl bf) + literal32_labels + end; + reset_literals () + end + +(* Emit .file / .loc debugging directives *) + + let print_file_line oc file line = + print_file_line oc comment file line + +(* Name of testable condition *) + + let condition_name = function + | TCeq -> "eq" + | TCne -> "ne" + | TChs -> "hs" + | TClo -> "lo" + | TCmi -> "mi" + | TCpl -> "pl" + | TChi -> "hi" + | TCls -> "ls" + | TCge -> "ge" + | TClt -> "lt" + | TCgt -> "gt" + | TCle -> "le" + +(* Print an addressing mode *) + + let addressing oc = function + | ADimm(base, n) -> fprintf oc "[%a, #%a]" xregsp base coqint64 n + | ADreg(base, r) -> fprintf oc "[%a, %a]" xregsp base xreg r + | ADlsl(base, r, n) -> fprintf oc "[%a, %a, lsl #%a]" xregsp base xreg r coqint n + | ADsxt(base, r, n) -> fprintf oc "[%a, %a, sxtw #%a]" xregsp base wreg r coqint n + | ADuxt(base, r, n) -> fprintf oc "[%a, %a, uxtw #%a]" xregsp base wreg r coqint n + | ADadr(base, id, ofs) -> fprintf oc "[%a, #:lo12:%a]" xregsp base symbol_offset (id, ofs) + | ADpostincr(base, n) -> fprintf oc "[%a], #%a" xregsp base coqint64 n + +(* Print a shifted operand *) + let shiftop oc = function + | SOnone -> () + | SOlsl n -> fprintf oc ", lsl #%a" coqint n + | SOlsr n -> fprintf oc ", lsr #%a" coqint n + | SOasr n -> fprintf oc ", asr #%a" coqint n + | SOror n -> fprintf oc ", ror #%a" coqint n + +(* Print a sign- or zero-extended operand *) + let extendop oc = function + | EOsxtb n -> fprintf oc ", sxtb #%a" coqint n + | EOsxth n -> fprintf oc ", sxth #%a" coqint n + | EOsxtw n -> fprintf oc ", sxtw #%a" coqint n + | EOuxtb n -> fprintf oc ", uxtb #%a" coqint n + | EOuxth n -> fprintf oc ", uxth #%a" coqint n + | EOuxtw n -> fprintf oc ", uxtw #%a" coqint n + | EOuxtx n -> fprintf oc ", uxtx #%a" coqint n + +(* Printing of instructions *) + let print_instruction oc = function + (* Branches *) + | Pb lbl -> + fprintf oc " b %a\n" print_label lbl + | Pbc(c, lbl) -> + fprintf oc " b.%s %a\n" (condition_name c) print_label lbl + | Pbl(id, sg) -> + fprintf oc " bl %a\n" symbol id + | Pbs(id, sg) -> + fprintf oc " b %a\n" symbol id + | Pblr(r, sg) -> + fprintf oc " blr %a\n" xreg r + | Pbr(r, sg) -> + fprintf oc " br %a\n" xreg r + | Pret r -> + fprintf oc " ret %a\n" xreg r + | Pcbnz(sz, r, lbl) -> + fprintf oc " cbnz %a, %a\n" ireg (sz, r) print_label lbl + | Pcbz(sz, r, lbl) -> + fprintf oc " cbz %a, %a\n" ireg (sz, r) print_label lbl + | Ptbnz(sz, r, n, lbl) -> + fprintf oc " tbnz %a, #%a, %a\n" ireg (sz, r) coqint n print_label lbl + | Ptbz(sz, r, n, lbl) -> + fprintf oc " tbz %a, #%a, %a\n" ireg (sz, r) coqint n print_label lbl + (* Memory loads and stores *) + | Pldrw(rd, a) | Pldrw_a(rd, a) -> + fprintf oc " ldr %a, %a\n" wreg rd addressing a + | Pldrx(rd, a) | Pldrx_a(rd, a) -> + fprintf oc " ldr %a, %a\n" xreg rd addressing a + | Pldrb(sz, rd, a) -> + fprintf oc " ldrb %a, %a\n" wreg rd addressing a + | Pldrsb(sz, rd, a) -> + fprintf oc " ldrsb %a, %a\n" ireg (sz, rd) addressing a + | Pldrh(sz, rd, a) -> + fprintf oc " ldrh %a, %a\n" wreg rd addressing a + | Pldrsh(sz, rd, a) -> + fprintf oc " ldrsh %a, %a\n" ireg (sz, rd) addressing a + | Pldrzw(rd, a) -> + fprintf oc " ldr %a, %a\n" wreg rd addressing a + (* the upper 32 bits of Xrd are set to 0, performing zero-extension *) + | Pldrsw(rd, a) -> + fprintf oc " ldrsw %a, %a\n" xreg rd addressing a + | Pldp(rd1, rd2, a) -> + fprintf oc " ldp %a, %a, %a\n" xreg rd1 xreg rd2 addressing a + | Pstrw(rs, a) | Pstrw_a(rs, a) -> + fprintf oc " str %a, %a\n" wreg rs addressing a + | Pstrx(rs, a) | Pstrx_a(rs, a) -> + fprintf oc " str %a, %a\n" xreg rs addressing a + | Pstrb(rs, a) -> + fprintf oc " strb %a, %a\n" wreg rs addressing a + | Pstrh(rs, a) -> + fprintf oc " strh %a, %a\n" wreg rs addressing a + | Pstp(rs1, rs2, a) -> + fprintf oc " stp %a, %a, %a\n" xreg rs1 xreg rs2 addressing a + (* Integer arithmetic, immediate *) + | Paddimm(sz, rd, r1, n) -> + fprintf oc " add %a, %a, #%a\n" iregsp (sz, rd) iregsp (sz, r1) intsz (sz, n) + | Psubimm(sz, rd, r1, n) -> + fprintf oc " sub %a, %a, #%a\n" iregsp (sz, rd) iregsp (sz, r1) intsz (sz, n) + | Pcmpimm(sz, r1, n) -> + fprintf oc " cmp %a, #%a\n" ireg (sz, r1) intsz (sz, n) + | Pcmnimm(sz, r1, n) -> + fprintf oc " cmn %a, #%a\n" ireg (sz, r1) intsz (sz, n) + (* Move integer register *) + | Pmov(rd, r1) -> + fprintf oc " mov %a, %a\n" xregsp rd xregsp r1 + (* Logical, immediate *) + | Pandimm(sz, rd, r1, n) -> + fprintf oc " and %a, %a, #%a\n" ireg (sz, rd) ireg0 (sz, r1) intsz (sz, n) + | Peorimm(sz, rd, r1, n) -> + fprintf oc " eor %a, %a, #%a\n" ireg (sz, rd) ireg0 (sz, r1) intsz (sz, n) + | Porrimm(sz, rd, r1, n) -> + fprintf oc " orr %a, %a, #%a\n" ireg (sz, rd) ireg0 (sz, r1) intsz (sz, n) + | Ptstimm(sz, r1, n) -> + fprintf oc " tst %a, #%a\n" ireg (sz, r1) intsz (sz, n) + (* Move wide immediate *) + | Pmovz(sz, rd, n, pos) -> + fprintf oc " movz %a, #%d, lsl #%d\n" ireg (sz, rd) (Z.to_int n) (Z.to_int pos) + | Pmovn(sz, rd, n, pos) -> + fprintf oc " movn %a, #%d, lsl #%d\n" ireg (sz, rd) (Z.to_int n) (Z.to_int pos) + | Pmovk(sz, rd, n, pos) -> + fprintf oc " movk %a, #%d, lsl #%d\n" ireg (sz, rd) (Z.to_int n) (Z.to_int pos) + (* PC-relative addressing *) + | Padrp(rd, id, ofs) -> + fprintf oc " adrp %a, %a\n" xreg rd symbol_offset (id, ofs) + | Paddadr(rd, r1, id, ofs) -> + fprintf oc " add %a, %a, #:lo12:%a\n" xreg rd xreg r1 symbol_offset (id, ofs) + (* Bit-field operations *) + | Psbfiz(sz, rd, r1, r, s) -> + fprintf oc " sbfiz %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s) + | Psbfx(sz, rd, r1, r, s) -> + fprintf oc " sbfx %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s) + | Pubfiz(sz, rd, r1, r, s) -> + fprintf oc " ubfiz %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s) + | Pubfx(sz, rd, r1, r, s) -> + fprintf oc " ubfx %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s) + (* Integer arithmetic, shifted register *) + | Padd(sz, rd, r1, r2, s) -> + fprintf oc " add %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Psub(sz, rd, r1, r2, s) -> + fprintf oc " sub %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Pcmp(sz, r1, r2, s) -> + fprintf oc " cmp %a, %a%a\n" ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Pcmn(sz, r1, r2, s) -> + fprintf oc " cmn %a, %a%a\n" ireg0 (sz, r1) ireg (sz, r2) shiftop s + (* Integer arithmetic, extending register *) + | Paddext(rd, r1, r2, x) -> + fprintf oc " add %a, %a, %a%a\n" xregsp rd xregsp r1 wreg r2 extendop x + | Psubext(rd, r1, r2, x) -> + fprintf oc " sub %a, %a, %a%a\n" xregsp rd xregsp r1 wreg r2 extendop x + | Pcmpext(r1, r2, x) -> + fprintf oc " cmp %a, %a%a\n" xreg r1 wreg r2 extendop x + | Pcmnext(r1, r2, x) -> + fprintf oc " cmn %a, %a%a\n" xreg r1 wreg r2 extendop x + (* Logical, shifted register *) + | Pand(sz, rd, r1, r2, s) -> + fprintf oc " and %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Pbic(sz, rd, r1, r2, s) -> + fprintf oc " bic %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Peon(sz, rd, r1, r2, s) -> + fprintf oc " eon %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Peor(sz, rd, r1, r2, s) -> + fprintf oc " eor %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Porr(sz, rd, r1, r2, s) -> + fprintf oc " orr %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Porn(sz, rd, r1, r2, s) -> + fprintf oc " orn %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s + | Ptst(sz, r1, r2, s) -> + fprintf oc " tst %a, %a%a\n" ireg0 (sz, r1) ireg (sz, r2) shiftop s + (* Variable shifts *) + | Pasrv(sz, rd, r1, r2) -> + fprintf oc " asr %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) + | Plslv(sz, rd, r1, r2) -> + fprintf oc " lsl %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) + | Plsrv(sz, rd, r1, r2) -> + fprintf oc " lsr %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) + | Prorv(sz, rd, r1, r2) -> + fprintf oc " ror %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) + (* Bit operations *) + | Pcls(sz, rd, r1) -> + fprintf oc " cls %a, %a\n" ireg (sz, rd) ireg (sz, r1) + | Pclz(sz, rd, r1) -> + fprintf oc " clz %a, %a\n" ireg (sz, rd) ireg (sz, r1) + | Prev(sz, rd, r1) -> + fprintf oc " rev %a, %a\n" ireg (sz, rd) ireg (sz, r1) + | Prev16(sz, rd, r1) -> + fprintf oc " rev16 %a, %a\n" ireg (sz, rd) ireg (sz, r1) + (* Conditional data processing *) + | Pcsel(rd, r1, r2, c) -> + fprintf oc " csel %a, %a, %a, %s\n" xreg rd xreg r1 xreg r2 (condition_name c) + | Pcset(rd, c) -> + fprintf oc " cset %a, %s\n" xreg rd (condition_name c) + (* Integer multiply/divide *) + | Pmadd(sz, rd, r1, r2, r3) -> + fprintf oc " madd %a, %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) ireg0 (sz, r3) + | Pmsub(sz, rd, r1, r2, r3) -> + fprintf oc " msub %a, %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) ireg0 (sz, r3) + | Psmulh(rd, r1, r2) -> + fprintf oc " smulh %a, %a, %a\n" xreg rd xreg r1 xreg r2 + | Pumulh(rd, r1, r2) -> + fprintf oc " umulh %a, %a, %a\n" xreg rd xreg r1 xreg r2 + | Psdiv(sz, rd, r1, r2) -> + fprintf oc " sdiv %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) + | Pudiv(sz, rd, r1, r2) -> + fprintf oc " udiv %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) + (* Floating-point loads and stores *) + | Pldrs(rd, a) -> + fprintf oc " ldr %a, %a\n" sreg rd addressing a + | Pldrd(rd, a) | Pldrd_a(rd, a) -> + fprintf oc " ldr %a, %a\n" dreg rd addressing a + | Pstrs(rd, a) -> + fprintf oc " str %a, %a\n" sreg rd addressing a + | Pstrd(rd, a) | Pstrd_a(rd, a) -> + fprintf oc " str %a, %a\n" dreg rd addressing a + (* Floating-point move *) + | Pfmov(rd, r1) -> + fprintf oc " fmov %a, %a\n" dreg rd dreg r1 + | Pfmovimmd(rd, f) -> + let d = camlint64_of_coqint (Floats.Float.to_bits f) in + if is_immediate_float64 d then + fprintf oc " fmov %a, #%.7f\n" dreg rd (Int64.float_of_bits d) + else begin + let lbl = label_literal64 d in + fprintf oc " adrp x16, %a\n" label lbl; + fprintf oc " ldr %a, [x16, #:lo12:%a] %s %.18g\n" dreg rd label lbl comment (Int64.float_of_bits d) + end + | Pfmovimms(rd, f) -> + let d = camlint_of_coqint (Floats.Float32.to_bits f) in + if is_immediate_float32 d then + fprintf oc " fmov %a, #%.7f\n" sreg rd (Int32.float_of_bits d) + else begin + let lbl = label_literal32 d in + fprintf oc " adrp x16, %a\n" label lbl; + fprintf oc " ldr %a, [x16, #:lo12:%a] %s %.18g\n" sreg rd label lbl comment (Int32.float_of_bits d) + end + | Pfmovi(D, rd, r1) -> + fprintf oc " fmov %a, %a\n" dreg rd xreg0 r1 + | Pfmovi(S, rd, r1) -> + fprintf oc " fmov %a, %a\n" sreg rd wreg0 r1 + (* Floating-point conversions *) + | Pfcvtds(rd, r1) -> + fprintf oc " fcvt %a, %a\n" dreg rd sreg r1 + | Pfcvtsd(rd, r1) -> + fprintf oc " fcvt %a, %a\n" sreg rd dreg r1 + | Pfcvtzs(isz, fsz, rd, r1) -> + fprintf oc " fcvtzs %a, %a\n" ireg (isz, rd) freg (fsz, r1) + | Pfcvtzu(isz, fsz, rd, r1) -> + fprintf oc " fcvtzu %a, %a\n" ireg (isz, rd) freg (fsz, r1) + | Pscvtf(fsz, isz, rd, r1) -> + fprintf oc " scvtf %a, %a\n" freg (fsz, rd) ireg (isz, r1) + | Pucvtf(fsz, isz, rd, r1) -> + fprintf oc " ucvtf %a, %a\n" freg (fsz, rd) ireg (isz, r1) + (* Floating-point arithmetic *) + | Pfabs(sz, rd, r1) -> + fprintf oc " fabs %a, %a\n" freg (sz, rd) freg (sz, r1) + | Pfneg(sz, rd, r1) -> + fprintf oc " fneg %a, %a\n" freg (sz, rd) freg (sz, r1) + | Pfsqrt(sz, rd, r1) -> + fprintf oc " fsqrt %a, %a\n" freg (sz, rd) freg (sz, r1) + | Pfadd(sz, rd, r1, r2) -> + fprintf oc " fadd %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) + | Pfdiv(sz, rd, r1, r2) -> + fprintf oc " fdiv %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) + | Pfmul(sz, rd, r1, r2) -> + fprintf oc " fmul %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) + | Pfnmul(sz, rd, r1, r2) -> + fprintf oc " fnmul %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) + | Pfsub(sz, rd, r1, r2) -> + fprintf oc " fsub %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) + | Pfmadd(sz, rd, r1, r2, r3) -> + fprintf oc " fmadd %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3) + | Pfmsub(sz, rd, r1, r2, r3) -> + fprintf oc " fmsub %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3) + | Pfnmadd(sz, rd, r1, r2, r3) -> + fprintf oc " fnmadd %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3) + | Pfnmsub(sz, rd, r1, r2, r3) -> + fprintf oc " fnmsub %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3) + (* Floating-point comparison *) + | Pfcmp(sz, r1, r2) -> + fprintf oc " fcmp %a, %a\n" freg (sz, r1) freg (sz, r2) + | Pfcmp0(sz, r1) -> + fprintf oc " fcmp %a, #0.0\n" freg (sz, r1) + (* Floating-point conditional select *) + | Pfsel(rd, r1, r2, c) -> + fprintf oc " fcsel %a, %a, %a, %s\n" dreg rd dreg r1 dreg r2 (condition_name c) + (* No-op *) + | Pnop -> + fprintf oc " nop\n" + (* Pseudo-instructions expanded in Asmexpand *) + | Pallocframe(sz, linkofs) -> assert false + | Pfreeframe(sz, linkofs) -> assert false + | Pcvtx2w rd -> assert false + (* Pseudo-instructions not yet expanded *) + | Plabel lbl -> + fprintf oc "%a:\n" print_label lbl + | Ploadsymbol(rd, id) -> + fprintf oc " adrp %a, :got:%a\n" xreg rd symbol id; + fprintf oc " ldr %a, [%a, #:got_lo12:%a]\n" xreg rd xreg rd symbol id + | Pcvtsw2x(rd, r1) -> + fprintf oc " sxtw %a, %a\n" xreg rd wreg r1 + | Pcvtuw2x(rd, r1) -> + fprintf oc " uxtw %a, %a\n" xreg rd wreg r1 + | Pbtbl(r1, tbl) -> + let lbl = new_label() in + fprintf oc " adr x16, %a\n" label lbl; + fprintf oc " add x16, x16, %a, uxtw #2\n" wreg r1; + fprintf oc " br x16\n"; + fprintf oc "%a:" label lbl; + List.iter (fun l -> fprintf oc " b %a\n" print_label l) tbl + | Pcfi_adjust sz -> + cfi_adjust oc (camlint_of_coqint sz) + | Pcfi_rel_offset ofs -> + cfi_rel_offset oc "lr" (camlint_of_coqint 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 "sp" (camlstring_of_coqstring txt) args in + fprintf oc "%s annotation: %S\n" comment annot + | 2 -> let lbl = new_label () in + fprintf oc "%a:\n" label lbl; + add_ais_annot lbl preg_annot "sp" (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 + | _ -> + assert false + end + + let get_section_names name = + let (text, lit) = + match C2C.atom_sections name with + | t :: l :: _ -> (t, l) + | _ -> (Section_text, Section_literal) in + text,lit,Section_jumptable + + let print_align oc alignment = + fprintf oc " .balign %d\n" alignment + + let print_jumptable oc jmptbl = + let print_tbl oc (lbl, tbl) = + fprintf oc "%a:\n" label lbl; + List.iter + (fun l -> fprintf oc " .long %a - %a\n" + print_label l label lbl) + tbl in + if !jumptables <> [] then + begin + section oc jmptbl; + fprintf oc " .balign 4\n"; + List.iter (print_tbl oc) !jumptables; + jumptables := [] + end + + let print_fun_info = elf_print_fun_info + + let print_optional_fun_info _ = () + + let print_var_info = elf_print_var_info + + let print_comm_symb oc sz name align = + if C2C.atom_is_static name then + fprintf oc " .local %a\n" symbol name; + fprintf oc " .comm %a, %s, %d\n" + symbol name + (Z.to_string sz) + align + + let print_instructions oc fn = + current_function_sig := fn.fn_sig; + List.iter (print_instruction oc) fn.fn_code + +(* Data *) + + let address = ".quad" + + let print_prologue oc = + if !Clflags.option_g then begin + section oc Section_text; + end + + let print_epilogue oc = + if !Clflags.option_g then begin + Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); + section oc Section_text; + end + + let default_falignment = 2 + + let cfi_startproc oc = () + let cfi_endproc oc = () + + end + +let sel_target () = + (module Target:TARGET) diff --git a/aarch64/ValueAOp.v b/aarch64/ValueAOp.v new file mode 100644 index 00000000..e0d98c85 --- /dev/null +++ b/aarch64/ValueAOp.v @@ -0,0 +1,319 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Compopts. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op RTL ValueDomain. + +(** Value analysis for AArch64 operators *) + +Definition eval_static_shift (s: shift) (v: aval) (n: amount32) : aval := + match s with + | Slsl => shl v (I n) + | Slsr => shru v (I n) + | Sasr => shr v (I n) + | Sror => ror v (I n) + end. + +Definition eval_static_shiftl (s: shift) (v: aval) (n: amount64) : aval := + match s with + | Slsl => shll v (I n) + | Slsr => shrlu v (I n) + | Sasr => shrl v (I n) + | Sror => rorl v (I n) + end. + +Definition eval_static_extend (x: extension) (v: aval) (n: amount64) : aval := + shll (match x with Xsgn32 => longofint v | Xuns32 => longofintu v end) (I n). + +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) + | Ccompshift c s a, v1 :: v2 :: nil => cmp_bool c v1 (eval_static_shift s v2 a) + | Ccompushift c s a, v1 :: v2 :: nil => cmpu_bool c v1 (eval_static_shift s v2 a) + | Cmaskzero m, v1 :: nil => maskzero v1 m + | Cmasknotzero m, v1 :: nil => cnot (maskzero v1 m) + | 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) + | Ccomplshift c s a, v1 :: v2 :: nil => cmpl_bool c v1 (eval_static_shiftl s v2 a) + | Ccomplushift c s a, v1 :: v2 :: nil => cmplu_bool c v1 (eval_static_shiftl s v2 a) + | Cmasklzero m, v1 :: nil => cmpl_bool Ceq (andl v1 (L m)) (L Int64.zero) + | Cmasklnotzero m, v1 :: nil => cmpl_bool Cne (andl v1 (L m)) (L Int64.zero) + | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) + | Ccompfzero c, v1 :: nil => cmpf_bool c v1 (F Float.zero) + | Cnotcompfzero c, v1 :: nil => cnot (cmpf_bool c v1 (F Float.zero)) + | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 + | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) + | Ccompfszero c, v1 :: nil => cmpfs_bool c v1 (FS Float32.zero) + | Cnotcompfszero c, v1 :: nil => cnot (cmpfs_bool c v1 (FS Float32.zero)) + | _, _ => Bnone + end. + +Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := + match addr, vl with + | Aindexed n, v1 :: nil => addl v1 (L n) + | Aindexed2, v1 :: v2 :: nil => addl v1 v2 + | Aindexed2shift a, v1 :: v2 :: nil => addl v1 (shll v2 (I a)) + | Aindexed2ext x a, v1 :: v2 :: nil => addl v1 (eval_static_extend x v2 a) + | Aglobal s ofs, nil => Ptr (Gl s ofs) + | Ainstack ofs, nil => Ptr (Stk ofs) + | _, _ => Vbot + end. + +Definition eval_static_operation (op: operation) (vl: list aval): aval := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Olongconst n, nil => L n + | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop + | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop + | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs) + | Oaddrstack ofs, nil => Ptr (Stk ofs) + + | Oshift s a, v1::nil => eval_static_shift s v1 a + | Oadd, v1::v2::nil => add v1 v2 + | Oaddshift s a, v1::v2::nil => add v1 (eval_static_shift s v2 a) + | Oaddimm n, v1::nil => add v1 (I n) + | Oneg, v1::nil => neg v1 + | Onegshift s a, v1::nil => neg (eval_static_shift s v1 a) + | Osub, v1::v2::nil => sub v1 v2 + | Osubshift s a, v1::v2::nil => sub v1 (eval_static_shift s v2 a) + | Omul, v1::v2::nil => mul v1 v2 + | Omuladd, v1::v2::v3::nil => add v1 (mul v2 v3) + | Omulsub, v1::v2::v3::nil => sub v1 (mul v2 v3) + | Odiv, v1::v2::nil => divs v1 v2 + | Odivu, v1::v2::nil => divu v1 v2 + | Oand, v1::v2::nil => and v1 v2 + | Oandshift s a, v1::v2::nil => and v1 (eval_static_shift s v2 a) + | Oandimm n, v1::nil => and v1 (I n) + | Oor, v1::v2::nil => or v1 v2 + | Oorshift s a, v1::v2::nil => or v1 (eval_static_shift s v2 a) + | Oorimm n, v1::nil => or v1 (I n) + | Oxor, v1::v2::nil => xor v1 v2 + | Oxorshift s a, v1::v2::nil => xor v1 (eval_static_shift s v2 a) + | Oxorimm n, v1::nil => xor v1 (I n) + | Onot, v1::nil => notint v1 + | Onotshift s a, v1::nil => notint (eval_static_shift s v1 a) + | Obic, v1::v2::nil => and v1 (notint v2) + | Obicshift s a, v1::v2::nil => and v1 (notint (eval_static_shift s v2 a)) + | Oorn, v1::v2::nil => or v1 (notint v2) + | Oornshift s a, v1::v2::nil => or v1 (notint (eval_static_shift s v2 a)) + | Oeqv, v1::v2::nil => xor v1 (notint v2) + | Oeqvshift s a, v1::v2::nil => xor v1 (notint (eval_static_shift s v2 a)) + | Oshl, v1::v2::nil => shl v1 v2 + | Oshr, v1::v2::nil => shr v1 v2 + | Oshru, v1::v2::nil => shru v1 v2 + | Oshrximm n, v1::nil => shrx v1 (I n) + | Ozext s, v1::nil => zero_ext s v1 + | Osext s, v1::nil => sign_ext s v1 + | Oshlzext s a, v1::nil => shl (zero_ext s v1) (I a) + | Oshlsext s a, v1::nil => shl (sign_ext s v1) (I a) + | Ozextshr a s, v1::nil => zero_ext s (shru v1 (I a)) + | Osextshr a s, v1::nil => sign_ext s (shr v1 (I a)) + + | Oshiftl s a, v1::nil => eval_static_shiftl s v1 a + | Oextend x a, v1::nil => eval_static_extend x v1 a + | Omakelong, v1::v2::nil => longofwords v1 v2 + | Olowlong, v1::nil => loword v1 + | Ohighlong, v1::nil => hiword v1 + | Oaddl, v1::v2::nil => addl v1 v2 + | Oaddlshift s a, v1::v2::nil => addl v1 (eval_static_shiftl s v2 a) + | Oaddlext x a, v1::v2::nil => addl v1 (eval_static_extend x v2 a) + | Oaddlimm n, v1::nil => addl v1 (L n) + | Onegl, v1::nil => negl v1 + | Oneglshift s a, v1::nil => negl (eval_static_shiftl s v1 a) + | Osubl, v1::v2::nil => subl v1 v2 + | Osublshift s a, v1::v2::nil => subl v1 (eval_static_shiftl s v2 a) + | Osublext x a, v1::v2::nil => subl v1 (eval_static_extend x v2 a) + | Omull, v1::v2::nil => mull v1 v2 + | Omulladd, v1::v2::v3::nil => addl v1 (mull v2 v3) + | Omullsub, v1::v2::v3::nil => subl v1 (mull v2 v3) + | 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 + | Oandl, v1::v2::nil => andl v1 v2 + | Oandlshift s a, v1::v2::nil => andl v1 (eval_static_shiftl s v2 a) + | Oandlimm n, v1::nil => andl v1 (L n) + | Oorl, v1::v2::nil => orl v1 v2 + | Oorlshift s a, v1::v2::nil => orl v1 (eval_static_shiftl s v2 a) + | Oorlimm n, v1::nil => orl v1 (L n) + | Oxorl, v1::v2::nil => xorl v1 v2 + | Oxorlshift s a, v1::v2::nil => xorl v1 (eval_static_shiftl s v2 a) + | Oxorlimm n, v1::nil => xorl v1 (L n) + | Onotl, v1::nil => notl v1 + | Onotlshift s a, v1::nil => notl (eval_static_shiftl s v1 a) + | Obicl, v1::v2::nil => andl v1 (notl v2) + | Obiclshift s a, v1::v2::nil => andl v1 (notl (eval_static_shiftl s v2 a)) + | Oornl, v1::v2::nil => orl v1 (notl v2) + | Oornlshift s a, v1::v2::nil => orl v1 (notl (eval_static_shiftl s v2 a)) + | Oeqvl, v1::v2::nil => xorl v1 (notl v2) + | Oeqvlshift s a, v1::v2::nil => xorl v1 (notl (eval_static_shiftl s v2 a)) + | Oshll, v1::v2::nil => shll v1 v2 + | Oshrl, v1::v2::nil => shrl v1 v2 + | Oshrlu, v1::v2::nil => shrlu v1 v2 + | Oshrlximm n, v1::nil => shrxl v1 (I n) + | Ozextl s, v1::nil => zero_ext_l s v1 + | Osextl s, v1::nil => sign_ext_l s v1 + | Oshllzext s a, v1::nil => shll (zero_ext_l s v1) (I a) + | Oshllsext s a, v1::nil => shll (sign_ext_l s v1) (I a) + | Ozextshrl a s, v1::nil => zero_ext_l s (shrlu v1 (I a)) + | Osextshrl a s, v1::nil => sign_ext_l s (shrl v1 (I a)) + + | Onegf, v1::nil => negf v1 + | Oabsf, v1::nil => absf v1 + | Oaddf, v1::v2::nil => addf v1 v2 + | Osubf, v1::v2::nil => subf v1 v2 + | Omulf, v1::v2::nil => mulf v1 v2 + | Odivf, v1::v2::nil => divf v1 v2 + + | Onegfs, v1::nil => negfs v1 + | Oabsfs, v1::nil => absfs v1 + | Oaddfs, v1::v2::nil => addfs v1 v2 + | Osubfs, v1::v2::nil => subfs v1 v2 + | Omulfs, v1::v2::nil => mulfs v1 v2 + | Odivfs, v1::v2::nil => divfs v1 v2 + + | Osingleoffloat, v1::nil => singleoffloat v1 + | Ofloatofsingle, v1::nil => floatofsingle v1 + | Ointoffloat, v1::nil => intoffloat v1 + | Ointuoffloat, v1::nil => intuoffloat v1 + | Ofloatofint, v1::nil => floatofint v1 + | Ofloatofintu, v1::nil => floatofintu v1 + | Ointofsingle, v1::nil => intofsingle v1 + | Ointuofsingle, v1::nil => intuofsingle v1 + | Osingleofint, v1::nil => singleofint v1 + | Osingleofintu, v1::nil => singleofintu v1 + | Olongoffloat, v1::nil => longoffloat v1 + | Olonguoffloat, v1::nil => longuoffloat v1 + | Ofloatoflong, v1::nil => floatoflong v1 + | Ofloatoflongu, v1::nil => floatoflongu v1 + | Olongofsingle, v1::nil => longofsingle v1 + | Olonguofsingle, v1::nil => longuofsingle v1 + | Osingleoflong, v1::nil => singleoflong v1 + | Osingleoflongu, v1::nil => singleoflongu v1 + + | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2 + + | _, _ => 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. + +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 + | _ => idtac + end. + +Lemma eval_static_shift_sound: forall v av s n, + vmatch bc v av -> vmatch bc (eval_shift s v n) (eval_static_shift s av n). +Proof. + intros. unfold eval_shift, eval_static_shift; destruct s; auto with va. +Qed. + +Lemma eval_static_shiftl_sound: forall v av s n, + vmatch bc v av -> vmatch bc (eval_shiftl s v n) (eval_static_shiftl s av n). +Proof. + intros. unfold eval_shiftl, eval_static_shiftl; destruct s; auto with va. +Qed. + +Lemma eval_static_extend_sound: forall v av x n, + vmatch bc v av -> vmatch bc (eval_extend x v n) (eval_static_extend x av n). +Proof. + intros. unfold eval_extend, eval_static_extend; destruct x; auto with va. +Qed. + +Hint Resolve eval_static_shift_sound eval_static_shiftl_sound eval_static_extend_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. + replace (Val.cmp_bool Ceq (Val.and a1 (Vint n)) (Vint Int.zero)) + with (Val.maskzero_bool a1 n) by (destruct a1; auto). + eauto with va. + replace (Val.cmp_bool Cne (Val.and a1 (Vint n)) (Vint Int.zero)) + with (option_map negb (Val.maskzero_bool a1 n)) by (destruct a1; auto). + eauto with va. + inv H2. + destruct cond; simpl; eauto with va. + destruct cond; auto with va. +Qed. + +Lemma symbol_address_sound: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)). +Proof. + intros; apply symbol_address_sound; apply GENV. +Qed. + +Lemma symbol_address_sound_2: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F. + constructor. constructor. apply GENV; auto. + constructor. +Qed. + +Hint Resolve symbol_address_sound symbol_address_sound_2: va. + +Theorem eval_static_addressing_sound: + forall addr vargs vres aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_addressing addr aargs). +Proof. + unfold eval_addressing, eval_static_addressing; intros; + destruct addr; InvHyps; eauto with va. + rewrite Ptrofs.add_zero_l; eauto with va. +Qed. + +Theorem eval_static_operation_sound: + forall op vargs m vres aargs, + eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_operation op aargs). +Proof. + unfold eval_operation, eval_static_operation; intros; + destruct op; InvHyps; eauto with va. + destruct (propagate_float_constants tt); constructor. + destruct (propagate_float_constants tt); constructor. + rewrite Ptrofs.add_zero_l; eauto with va. + apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + apply select_sound; eauto using eval_static_condition_sound. +Qed. + +End SOUNDNESS. + diff --git a/aarch64/extractionMachdep.v b/aarch64/extractionMachdep.v new file mode 100644 index 00000000..a447d12f --- /dev/null +++ b/aarch64/extractionMachdep.v @@ -0,0 +1,23 @@ +(* *********************************************************************) +(* *) +(* 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 INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Additional extraction directives specific to the AArch64 port *) + +Require Archi Asm. + +(* Archi *) + +Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) + +(* Asm *) +Extract Constant Asm.symbol_low => "fun _ _ _ -> assert false". +Extract Constant Asm.symbol_high => "fun _ _ _ -> assert false". diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v index 111e435f..3638c465 100644 --- a/backend/Asmgenproof0.v +++ b/backend/Asmgenproof0.v @@ -899,30 +899,53 @@ Qed. (** A variant that supports zero steps of execution *) -Inductive exec_straight0: code -> regset -> mem -> - code -> regset -> mem -> Prop := - | exec_straight0_none: - forall c rs m, - exec_straight0 c rs m c rs m - | exec_straight0_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_instr ge fn i rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> - exec_straight0 c rs2 m2 c' rs3 m3 -> - exec_straight0 (i :: c) rs1 m1 c' rs3 m3. +Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop := + | exec_straight_opt_refl: forall c rs m, + exec_straight_opt c rs m c rs m + | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c1 rs1 m1 c2 rs2 m2. + +Lemma exec_straight_opt_left: + forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 2; intros. auto. eapply exec_straight_trans; eauto. +Qed. + +Lemma 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 c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 1; intros. auto. eapply exec_straight_trans; eauto. +Qed. -Lemma exec_straight_step': +Lemma exec_straight_opt_step: forall i c rs1 m1 rs2 m2 c' rs3 m3, exec_instr ge fn i rs1 m1 = Next rs2 m2 -> rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> - exec_straight0 c rs2 m2 c' rs3 m3 -> + exec_straight_opt c rs2 m2 c' rs3 m3 -> exec_straight (i :: c) rs1 m1 c' rs3 m3. Proof. - intros. revert i rs1 m1 H H0. revert H1. induction 1; intros. + intros. inv H1. - apply exec_straight_one; auto. - eapply exec_straight_step; eauto. Qed. +Lemma exec_straight_opt_step_opt: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_instr ge fn i rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> + exec_straight_opt c rs2 m2 c' rs3 m3 -> + exec_straight_opt (i :: c) rs1 m1 c' rs3 m3. +Proof. + intros. apply exec_straight_opt_intro. eapply exec_straight_opt_step; eauto. +Qed. + End STRAIGHTLINE. (** * Properties of the Mach call stack *) diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 55fa7a67..0e3b7c8e 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -321,7 +321,7 @@ Local Opaque mreg_type. + (* other ops *) destruct (type_of_operation op) as [ty_args ty_res] eqn:TYOP. InvBooleans. econstructor; eauto. - apply wt_setreg; auto. eapply Val.has_subtype; eauto. + apply wt_setreg. eapply Val.has_subtype; eauto. change ty_res with (snd (ty_args, ty_res)). rewrite <- TYOP. eapply type_of_operation_sound; eauto. red; intros; subst op. simpl in ISMOVE. destruct args; try discriminate. destruct args; discriminate. diff --git a/backend/NeedDomain.v b/backend/NeedDomain.v index b35c90b2..3c2d8e20 100644 --- a/backend/NeedDomain.v +++ b/backend/NeedDomain.v @@ -594,7 +594,8 @@ Proof. Qed. (** Modular arithmetic operations: add, mul, opposite. - (But not subtraction because of the pointer - pointer case. *) + Also subtraction, but only on 64-bit targets, otherwise + the pointer - pointer case does not fit. *) Definition modarith (x: nval) := match x with @@ -615,6 +616,19 @@ Proof. - inv H; auto. inv H0; auto. destruct w1; auto. Qed. +Lemma sub_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) -> + Archi.ptr64 = true -> + vagree (Val.sub v1 v2) (Val.sub w1 w2) x. +Proof. + unfold modarith; intros. destruct x; simpl in *. +- auto. +- unfold Val.sub; rewrite H1; InvAgree. + apply eqmod_iagree. apply eqmod_sub; apply iagree_eqmod; auto. +- inv H; auto. inv H0; auto. destruct w1; auto. +Qed. + Remark modarith_idem: forall nv, modarith (modarith nv) = modarith nv. Proof. destruct nv; simpl; auto. f_equal; apply complete_mask_idem. @@ -680,7 +694,7 @@ Definition sign_ext (n: Z) (x: nval) := Lemma sign_ext_sound: forall v w x n, vagree v w (sign_ext n x) -> - 0 < n < Int.zwordsize -> + 0 < n -> vagree (Val.sign_ext n v) (Val.sign_ext n w) x. Proof. unfold sign_ext; intros. destruct x; simpl in *. @@ -889,7 +903,8 @@ Lemma default_needs_of_operation_sound: eval_operation ge (Vptr sp Ptrofs.zero) op args1 m1 = Some v1 -> vagree_list args1 args2 nil \/ vagree_list args1 args2 (default nv :: nil) - \/ vagree_list args1 args2 (default nv :: default nv :: nil) -> + \/ vagree_list args1 args2 (default nv :: default nv :: nil) + \/ vagree_list args1 args2 (default nv :: default nv :: default nv :: nil) -> nv <> Nothing -> exists v2, eval_operation ge (Vptr sp Ptrofs.zero) op args2 m2 = Some v2 @@ -901,7 +916,8 @@ Proof. { destruct H0. auto with na. destruct H0. inv H0; constructor; auto with na. - inv H0; constructor; auto with na. inv H8; constructor; auto with na. + destruct H0. inv H0. constructor. inv H8; constructor; auto with na. + inv H0; constructor; auto with na. inv H8; constructor; auto with na. inv H9; constructor; auto with na. } exploit (@eval_operation_inj _ _ _ _ ge ge inject_id). eassumption. auto. auto. auto. diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v index f4ff2c86..334bedf6 100644 --- a/backend/SelectDivproof.v +++ b/backend/SelectDivproof.v @@ -763,8 +763,8 @@ Lemma eval_divlu_mull: Proof. intros. unfold divlu_mull. exploit (divlu_mul_shift x); eauto. intros [A B]. assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto). - exploit eval_mullhu. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). - exploit eval_shrluimm. eauto. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2). + exploit eval_mullhu. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). + exploit eval_shrluimm. try apply HELPERS. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2). simpl in B1; inv B1. simpl in B2. replace (Int.ltu (Int.repr p) Int64.iwordsize') with true in B2. inv B2. rewrite B. assumption. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto. @@ -834,17 +834,17 @@ Proof. intros. unfold divls_mull. assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)). { constructor; auto. } - exploit eval_mullhs. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). - exploit eval_addl; auto; try apply HELPERS. eexact A1. eexact A0. intros (v2 & A2 & B2). - exploit eval_shrluimm. eauto. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3). + exploit eval_mullhs. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). + exploit eval_addl. try apply HELPERS. eexact A1. eexact A0. intros (v2 & A2 & B2). + exploit eval_shrluimm. try apply HELPERS. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3). set (a4 := if zlt M Int64.half_modulus then mullhs (Eletvar 0) (Int64.repr M) else addl (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)). set (v4 := if zlt M Int64.half_modulus then v1 else v2). assert (A4: eval_expr ge sp e m le a4 v4). { unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. } - exploit eval_shrlimm. eauto. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5). - exploit eval_addl; auto; try apply HELPERS. eexact A5. eexact A3. intros (v6 & A6 & B6). + exploit eval_shrlimm. try apply HELPERS. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5). + exploit eval_addl. try apply HELPERS. eexact A5. eexact A3. intros (v6 & A6 & B6). assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true). { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto. assert (64 < Int.max_unsigned) by (compute; auto). omega. } @@ -948,8 +948,7 @@ Proof. intros until y. unfold divf. destruct (divf_match b); intros. - unfold divfimm. destruct (Float.exact_inverse n2) as [n2' | ] eqn:EINV. + inv H0. inv H4. simpl in H6. inv H6. econstructor; split. - EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. - simpl; eauto. + repeat (econstructor; eauto). destruct x; simpl; auto. erewrite Float.div_mul_inverse; eauto. + TrivialExists. - TrivialExists. @@ -964,8 +963,7 @@ Proof. intros until y. unfold divfs. destruct (divfs_match b); intros. - unfold divfsimm. destruct (Float32.exact_inverse n2) as [n2' | ] eqn:EINV. + inv H0. inv H4. simpl in H6. inv H6. econstructor; split. - EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. - simpl; eauto. + repeat (econstructor; eauto). destruct x; simpl; auto. erewrite Float32.div_mul_inverse; eauto. + TrivialExists. - TrivialExists. diff --git a/backend/Selectionaux.ml b/backend/Selectionaux.ml index 4ca7dd21..8acae8f2 100644 --- a/backend/Selectionaux.ml +++ b/backend/Selectionaux.ml @@ -68,6 +68,8 @@ let rec cost_expr = function let fast_cmove ty = match Configuration.arch, Configuration.model with + | "aarch64", _ -> + (match ty with Tint | Tlong | Tfloat | Tsingle -> true | _ -> false) | "arm", _ -> (match ty with Tint | Tfloat | Tsingle -> true | _ -> false) | "powerpc", "e5500" -> diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index ee3ed358..8a3aaae6 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -1257,8 +1257,8 @@ Proof. econstructor; eauto. econstructor; eauto. apply set_var_lessdef; auto. - (* store *) - exploit sel_expr_correct. eauto. eauto. eexact H. eauto. eauto. intros [vaddr' [A B]]. - exploit sel_expr_correct. eauto. eauto. eexact H0. eauto. eauto. intros [v' [C D]]. + exploit sel_expr_correct. try apply LINK. try apply HF. eexact H. eauto. eauto. intros [vaddr' [A B]]. + exploit sel_expr_correct. try apply LINK. try apply HF. eexact H0. eauto. eauto. intros [v' [C D]]. exploit Mem.storev_extends; eauto. intros [m2' [P Q]]. left; econstructor; split. eapply eval_store; eauto. diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index fd3bd5ae..c132ce7c 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -2093,6 +2093,7 @@ Proof. Qed. Definition sign_ext (nbits: Z) (v: aval) := + if zle nbits 0 then Uns (provenance v) 0 else match v with | I i => I (Int.sign_ext nbits i) | Uns p n => if zlt n nbits then Uns p n else sgn p nbits @@ -2101,20 +2102,39 @@ Definition sign_ext (nbits: Z) (v: aval) := end. Lemma sign_ext_sound: - forall nbits v x, 0 < nbits -> vmatch v x -> vmatch (Val.sign_ext nbits v) (sign_ext nbits x). + forall nbits v x, vmatch v x -> vmatch (Val.sign_ext nbits v) (sign_ext nbits x). Proof. assert (DFL: forall p nbits i, 0 < nbits -> vmatch (Vint (Int.sign_ext nbits i)) (sgn p nbits)). { intros. apply vmatch_sgn. apply is_sign_ext_sgn; auto with va. } - intros. inv H0; simpl; auto with va. -- destruct (zlt n nbits); eauto with va. + intros. unfold sign_ext. destruct (zle nbits 0). +- destruct v; simpl; auto with va. constructor. omega. + rewrite Int.sign_ext_below by auto. red; intros; apply Int.bits_zero. +- inv H; simpl; auto with va. ++ destruct (zlt n nbits); eauto with va. constructor; auto. eapply is_sign_ext_uns; eauto with va. -- destruct (zlt n nbits); auto with va. -- apply vmatch_sgn. apply is_sign_ext_sgn; auto with va. ++ destruct (zlt n nbits); auto with va. ++ apply vmatch_sgn. apply is_sign_ext_sgn; auto with va. apply Z.min_case; auto with va. Qed. +Definition zero_ext_l (s: Z) := unop_long (Int64.zero_ext s). + +Lemma zero_ext_l_sound: + forall s v x, vmatch v x -> vmatch (Val.zero_ext_l s v) (zero_ext_l s x). +Proof. + intros s. exact (unop_long_sound (Int64.zero_ext s)). +Qed. + +Definition sign_ext_l (s: Z) := unop_long (Int64.sign_ext s). + +Lemma sign_ext_l_sound: + forall s v x, vmatch v x -> vmatch (Val.sign_ext_l s v) (sign_ext_l s x). +Proof. + intros s. exact (unop_long_sound (Int64.sign_ext s)). +Qed. + Definition longofint (v: aval) := match v with | I i => L (Int64.repr (Int.signed i)) @@ -4712,6 +4732,7 @@ Hint Resolve cnot_sound symbol_address_sound negfs_sound absfs_sound addfs_sound subfs_sound mulfs_sound divfs_sound zero_ext_sound sign_ext_sound longofint_sound longofintu_sound + zero_ext_l_sound sign_ext_l_sound singleoffloat_sound floatofsingle_sound intoffloat_sound intuoffloat_sound floatofint_sound floatofintu_sound intofsingle_sound intuofsingle_sound singleofint_sound singleofintu_sound diff --git a/configure b/configure index 9a2db366..dccf6d14 100755 --- a/configure +++ b/configure @@ -55,10 +55,12 @@ Supported targets: x86_64-macosx (x86 64 bits, MacOS X) rv32-linux (RISC-V 32 bits, Linux) rv64-linux (RISC-V 64 bits, Linux) + aarch64-linux (AArch64, i.e. ARMv8 in 64-bit mode, Linux) manual (edit configuration file by hand) For x86 targets, the "x86_32-" prefix can also be written "ia32-" or "i386-". For x86 targets, the "x86_64-" prefix can also be written "amd64-". +For AArch64 targets, the "aarch64-" prefix can also be written "arm64-". For PowerPC targets, the "ppc-" prefix can be refined into: ppc64- PowerPC 64 bits @@ -175,6 +177,8 @@ case "$target" in arch="riscV"; model="32"; endianness="little"; bitsize=32;; rv64-*) arch="riscV"; model="64"; endianness="little"; bitsize=64;; + aarch64-*|arm64-*) + arch="aarch64"; model="default"; endianness="little"; bitsize=64;; manual) ;; "") @@ -428,6 +432,29 @@ if test "$arch" = "riscV"; then system="linux" fi +# +# AArch64 (ARMv8 64 bits) Target Configuration +# +if test "$arch" = "aarch64"; then + case "$target" in + linux) + abi="standard" + casm="${toolprefix}gcc" + casm_options="-c" + cc="${toolprefix}gcc" + clinker="${toolprefix}gcc" + clinker_options="" + cprepro="${toolprefix}gcc" + cprepro_options="-std=c99 -U__GNUC__ -E" + libmath="-lm" + system="linux";; + *) + echo "Error: invalid eabi/system '$target' for architecture AArch64." 1>&2 + echo "$usage" 1>&2 + exit 2;; + esac +fi + # # Finalize Target Configuration @@ -690,6 +717,8 @@ cat >> Makefile.config <<'EOF' # ARCH=powerpc # ARCH=arm # ARCH=x86 +# ARCH=riscV +# ARCH=aarch6 ARCH= # Hardware variant @@ -703,23 +732,24 @@ ARCH= # MODEL=armv7m # for ARM # MODEL=32sse2 # for x86 in 32-bit mode # MODEL=64 # for x86 in 64-bit mode +# MODEL=default # for others MODEL= # Target ABI # ABI=eabi # for PowerPC / Linux and other SVR4 or EABI platforms # ABI=eabi # for ARM # ABI=hardfloat # for ARM -# ABI=standard # for x86 +# ABI=standard # for others ABI= # Target bit width -# BITSIZE=64 # for x86 in 64-bit mode +# BITSIZE=64 # for x86 in 64-bit mode, RiscV in 64-bit mode, AArch64 # BITSIZE=32 # otherwise BITSIZE= # Target endianness # ENDIANNESS=big # for ARM or PowerPC -# ENDIANNESS=little # for ARM or x86 +# ENDIANNESS=little # for ARM or x86 or RiscV or AArch64 ENDIANNESS= # Target operating system and development environment @@ -728,7 +758,7 @@ ENDIANNESS= # SYSTEM=linux # SYSTEM=diab # -# Possible choices for ARM: +# Possible choices for ARM, AArch64, RiscV: # SYSTEM=linux # # Possible choices for x86: diff --git a/cparser/Machine.ml b/cparser/Machine.ml index 089f2483..97bedb3b 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -237,6 +237,11 @@ let rv64 = struct_passing_style = SP_ref_callee; (* Wrong *) struct_return_style = SR_ref } (* to check *) +let aarch64 = + { i32lpll64 with name = "aarch64"; + struct_passing_style = SP_ref_callee; (* Wrong *) + struct_return_style = SR_ref } (* Wrong *) + (* Add GCC extensions re: sizeof and alignof *) let gcc_extensions c = diff --git a/cparser/Machine.mli b/cparser/Machine.mli index 8971e2a3..ca7de17b 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -86,6 +86,7 @@ val arm_littleendian : t val arm_bigendian : t val rv32 : t val rv64 : t +val aarch64 : t val gcc_extensions : t -> t val compcert_interpreter : t -> t diff --git a/driver/Configuration.ml b/driver/Configuration.ml index 68531701..2188acf0 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" as a -> a + | "powerpc"|"arm"|"x86"|"riscV"|"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 bfb3542b..74791247 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -116,6 +116,7 @@ let init () = | "riscV" -> if Configuration.model = "64" then Machine.rv64 else Machine.rv32 + | "aarch64" -> Machine.aarch64 | _ -> assert false end; Env.set_builtins C2C.builtins; diff --git a/lib/Integers.v b/lib/Integers.v index 066e6b04..3b6c35eb 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -2689,42 +2689,93 @@ Proof. rewrite <- (sign_ext_zero_ext n y H). congruence. Qed. -Theorem zero_ext_shru_shl: +Theorem shru_shl: + forall x y z, ltu y iwordsize = true -> ltu z iwordsize = true -> + shru (shl x y) z = + if ltu z y then shl (zero_ext (zwordsize - unsigned y) x) (sub y z) + else zero_ext (zwordsize - unsigned z) (shru x (sub z y)). +Proof. + intros. apply ltu_iwordsize_inv in H; apply ltu_iwordsize_inv in H0. + unfold ltu. set (Y := unsigned y) in *; set (Z := unsigned z) in *. + apply same_bits_eq; intros. rewrite bits_shru by auto. fold Z. + destruct (zlt Z Y). +- assert (A: unsigned (sub y z) = Y - Z). + { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } + symmetry; rewrite bits_shl, A by omega. + destruct (zlt (i + Z) zwordsize). ++ rewrite bits_shl by omega. fold Y. + destruct (zlt i (Y - Z)); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. + rewrite bits_zero_ext by omega. rewrite zlt_true by omega. f_equal; omega. ++ rewrite bits_zero_ext by omega. rewrite ! zlt_false by omega. auto. +- assert (A: unsigned (sub z y) = Z - Y). + { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } + rewrite bits_zero_ext, bits_shru, A by omega. + destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. + rewrite bits_shl by omega. fold Y. + destruct (zlt (i + Z) Y). ++ rewrite zlt_false by omega. auto. ++ rewrite zlt_true by omega. f_equal; omega. +Qed. + +Corollary zero_ext_shru_shl: forall n x, 0 < n < zwordsize -> let y := repr (zwordsize - n) in zero_ext n x = shru (shl x y) y. Proof. intros. - assert (unsigned y = zwordsize - n). - unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. - apply same_bits_eq; intros. - rewrite bits_zero_ext. - rewrite bits_shru; auto. - destruct (zlt i n). - rewrite zlt_true. rewrite bits_shl. rewrite zlt_false. f_equal. omega. - omega. omega. omega. - rewrite zlt_false. auto. omega. - omega. -Qed. - -Theorem sign_ext_shr_shl: + assert (A: unsigned y = zwordsize - n). + { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. } + assert (B: ltu y iwordsize = true). + { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; omega. } + rewrite shru_shl by auto. unfold ltu; rewrite zlt_false by omega. + rewrite sub_idem, shru_zero. f_equal. rewrite A; omega. +Qed. + +Theorem shr_shl: + forall x y z, ltu y iwordsize = true -> ltu z iwordsize = true -> + shr (shl x y) z = + if ltu z y then shl (sign_ext (zwordsize - unsigned y) x) (sub y z) + else sign_ext (zwordsize - unsigned z) (shr x (sub z y)). +Proof. + intros. apply ltu_iwordsize_inv in H; apply ltu_iwordsize_inv in H0. + unfold ltu. set (Y := unsigned y) in *; set (Z := unsigned z) in *. + apply same_bits_eq; intros. rewrite bits_shr by auto. fold Z. + rewrite bits_shl by (destruct (zlt (i + Z) zwordsize); omega). fold Y. + destruct (zlt Z Y). +- assert (A: unsigned (sub y z) = Y - Z). + { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } + rewrite bits_shl, A by omega. + destruct (zlt i (Y - Z)). ++ apply zlt_true. destruct (zlt (i + Z) zwordsize); omega. ++ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). + rewrite bits_sign_ext by omega. f_equal. + destruct (zlt (i + Z) zwordsize). + rewrite zlt_true by omega. omega. + rewrite zlt_false by omega. omega. +- assert (A: unsigned (sub z y) = Z - Y). + { apply unsigned_repr. generalize wordsize_max_unsigned; omega. } + rewrite bits_sign_ext by omega. + rewrite bits_shr by (destruct (zlt i (zwordsize - Z)); omega). + rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). + f_equal. destruct (zlt i (zwordsize - Z)). ++ rewrite ! zlt_true by omega. omega. ++ rewrite ! zlt_false by omega. rewrite zlt_true by omega. omega. +Qed. + +Corollary sign_ext_shr_shl: forall n x, 0 < n < zwordsize -> let y := repr (zwordsize - n) in sign_ext n x = shr (shl x y) y. Proof. intros. - assert (unsigned y = zwordsize - n). - unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. - apply same_bits_eq; intros. - rewrite bits_sign_ext. - rewrite bits_shr; auto. - destruct (zlt i n). - rewrite zlt_true. rewrite bits_shl. rewrite zlt_false. f_equal. omega. - omega. omega. omega. - rewrite zlt_false. rewrite bits_shl. rewrite zlt_false. f_equal. omega. - omega. omega. omega. omega. + assert (A: unsigned y = zwordsize - n). + { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. } + assert (B: ltu y iwordsize = true). + { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; omega. } + rewrite shr_shl by auto. unfold ltu; rewrite zlt_false by omega. + rewrite sub_idem, shr_zero. f_equal. rewrite A; omega. Qed. (** [zero_ext n x] is the unique integer congruent to [x] modulo [2^n] @@ -3643,6 +3694,67 @@ Proof. unfold shr, shr'; rewrite <- A; auto. Qed. +Theorem shru'_shl': + forall x y z, Int.ltu y iwordsize' = true -> Int.ltu z iwordsize' = true -> + shru' (shl' x y) z = + if Int.ltu z y then shl' (zero_ext (zwordsize - Int.unsigned y) x) (Int.sub y z) + else zero_ext (zwordsize - Int.unsigned z) (shru' x (Int.sub z y)). +Proof. + intros. apply Int.ltu_inv in H; apply Int.ltu_inv in H0. + change (Int.unsigned iwordsize') with zwordsize in *. + unfold Int.ltu. set (Y := Int.unsigned y) in *; set (Z := Int.unsigned z) in *. + apply same_bits_eq; intros. rewrite bits_shru' by auto. fold Z. + destruct (zlt Z Y). +- assert (A: Int.unsigned (Int.sub y z) = Y - Z). + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } + symmetry; rewrite bits_shl', A by omega. + destruct (zlt (i + Z) zwordsize). ++ rewrite bits_shl' by omega. fold Y. + destruct (zlt i (Y - Z)); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. + rewrite bits_zero_ext by omega. rewrite zlt_true by omega. f_equal; omega. ++ rewrite bits_zero_ext by omega. rewrite ! zlt_false by omega. auto. +- assert (A: Int.unsigned (Int.sub z y) = Z - Y). + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } + rewrite bits_zero_ext, bits_shru', A by omega. + destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto. + rewrite bits_shl' by omega. fold Y. + destruct (zlt (i + Z) Y). ++ rewrite zlt_false by omega. auto. ++ rewrite zlt_true by omega. f_equal; omega. +Qed. + +Theorem shr'_shl': + forall x y z, Int.ltu y iwordsize' = true -> Int.ltu z iwordsize' = true -> + shr' (shl' x y) z = + if Int.ltu z y then shl' (sign_ext (zwordsize - Int.unsigned y) x) (Int.sub y z) + else sign_ext (zwordsize - Int.unsigned z) (shr' x (Int.sub z y)). +Proof. + intros. apply Int.ltu_inv in H; apply Int.ltu_inv in H0. + change (Int.unsigned iwordsize') with zwordsize in *. + unfold Int.ltu. set (Y := Int.unsigned y) in *; set (Z := Int.unsigned z) in *. + apply same_bits_eq; intros. rewrite bits_shr' by auto. fold Z. + rewrite bits_shl' by (destruct (zlt (i + Z) zwordsize); omega). fold Y. + destruct (zlt Z Y). +- assert (A: Int.unsigned (Int.sub y z) = Y - Z). + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } + rewrite bits_shl', A by omega. + destruct (zlt i (Y - Z)). ++ apply zlt_true. destruct (zlt (i + Z) zwordsize); omega. ++ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). + rewrite bits_sign_ext by omega. f_equal. + destruct (zlt (i + Z) zwordsize). + rewrite zlt_true by omega. omega. + rewrite zlt_false by omega. omega. +- assert (A: Int.unsigned (Int.sub z y) = Z - Y). + { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. } + rewrite bits_sign_ext by omega. + rewrite bits_shr' by (destruct (zlt i (zwordsize - Z)); omega). + rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega). + f_equal. destruct (zlt i (zwordsize - Z)). ++ rewrite ! zlt_true by omega. omega. ++ rewrite ! zlt_false by omega. rewrite zlt_true by omega. omega. +Qed. + Lemma shl'_zero_ext: forall n m x, 0 <= n -> shl' (zero_ext n x) m = zero_ext (n + Int.unsigned m) (shl' x m). diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 98d5bd33..b4d6b831 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -400,22 +400,6 @@ Ltac ArgsInv := | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * end). -Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop := - | exec_straight_opt_refl: forall c rs m, - exec_straight_opt c rs m c rs m - | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, - exec_straight ge fn c1 rs1 m1 c2 rs2 m2 -> - exec_straight_opt c1 rs1 m1 c2 rs2 m2. - -Remark exec_straight_opt_right: - forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, - exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> - exec_straight ge fn c2 rs2 m2 c3 rs3 m3 -> - exec_straight ge fn c1 rs1 m1 c3 rs3 m3. -Proof. - destruct 1; intros. auto. eapply exec_straight_trans; eauto. -Qed. - Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', transl_cbranch cond args lbl k = OK c -> diff --git a/runtime/Makefile b/runtime/Makefile index 8fe00934..6777995d 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -22,6 +22,8 @@ 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),aarch64) +OBJS=vararg.o else OBJS=i64_dtos.o i64_dtou.o i64_sar.o i64_sdiv.o i64_shl.o \ i64_shr.o i64_smod.o i64_stod.o i64_stof.o \ diff --git a/runtime/aarch64/sysdeps.h b/runtime/aarch64/sysdeps.h new file mode 100644 index 00000000..0cee9ae3 --- /dev/null +++ b/runtime/aarch64/sysdeps.h @@ -0,0 +1,45 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, Collège de France and INRIA Paris +// +// Copyright (c) Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// System dependencies + +#define FUNCTION(f) \ + .text; \ + .balign 16; \ + .globl f; \ +f: + +#define ENDFUNCTION(f) \ + .type f, @function; .size f, . - f + diff --git a/runtime/aarch64/vararg.S b/runtime/aarch64/vararg.S new file mode 100644 index 00000000..b7347d65 --- /dev/null +++ b/runtime/aarch64/vararg.S @@ -0,0 +1,109 @@ +// ***************************************************************** +// +// The Compcert verified compiler +// +// Xavier Leroy, Collège de France and INRIA Paris +// +// Copyright (c) Institut National de Recherche en Informatique et +// en Automatique. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the nor the +// names of its contributors may be used to endorse or promote products +// derived from this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// ********************************************************************* + +// Helper functions for variadic functions . AArch64 version. + +#include "sysdeps.h" + +// typedef struct __va_list { +// void *__stack; // next stack parameter +// void *__gr_top; // top of the save area for int regs +// void *__vr_top; // top of the save area for float regs +// int__gr_offs; // offset from gr_top to next int reg +// int__vr_offs; // offset from gr_top to next FP reg +// } +// typedef struct __va_list va_list; // struct passed by reference +// unsigned int __compcert_va_int32(va_list * ap); +// unsigned long long __compcert_va_int64(va_list * ap); +// double __compcert_va_float64(va_list * ap); + +FUNCTION(__compcert_va_int32) + ldr w1, [x0, #24] // w1 = gr_offs + cbz w1, 1f + // gr_offs is not zero: load from int save area and update gr_offs + ldr x2, [x0, #8] // x2 = gr_top + ldr w2, [x2, w1, sxtw] // w2 = the next integer + add w1, w1, #8 + str w1, [x0, #24] // update gr_offs + mov w0, w2 + ret + // gr_offs is zero: load from stack save area and update stack pointer +1: ldr x1, [x0, #0] // x1 = stack + ldr w2, [x1, #0] // w2 = the next integer + add x1, x1, #8 + str x1, [x0, #0] // update stack + mov w0, w2 + ret +ENDFUNCTION(__compcert_va_int32) + +FUNCTION(__compcert_va_int64) + ldr w1, [x0, #24] // w1 = gr_offs + cbz w1, 1f + // gr_offs is not zero: load from int save area and update gr_offs + ldr x2, [x0, #8] // x2 = gr_top + ldr x2, [x2, w1, sxtw] // w2 = the next long integer + add w1, w1, #8 + str w1, [x0, #24] // update gr_offs + mov x0, x2 + ret + // gr_offs is zero: load from stack save area and update stack pointer +1: ldr x1, [x0, #0] // x1 = stack + ldr x2, [x1, #0] // w2 = the next long integer + add x1, x1, #8 + str x1, [x0, #0] // update stack + mov x0, x2 + ret +ENDFUNCTION(__compcert_va_int64) + +FUNCTION(__compcert_va_float64) + ldr w1, [x0, #28] // w1 = vr_offs + cbz w1, 1f + // vr_offs is not zero: load from float save area and update vr_offs + ldr x2, [x0, #16] // x2 = vr_top + ldr d0, [x2, w1, sxtw] // d0 = the next float + add w1, w1, #16 + str w1, [x0, #28] // update vr_offs + ret + // gr_offs is zero: load from stack save area and update stack pointer +1: ldr x1, [x0, #0] // x1 = stack + ldr d0, [x1, #0] // d0 = the next float + add x1, x1, #8 + str x1, [x0, #0] // update stack + ret +ENDFUNCTION(__compcert_va_float64) + +// Right now we pass structs by reference. This is not ABI conformant. +FUNCTION(__compcert_va_composite) + b __compcert_va_int64 +ENDFUNCTION(__compcert_va_composite) diff --git a/test/regression/Results/builtins-aarch64 b/test/regression/Results/builtins-aarch64 new file mode 100644 index 00000000..c70432d8 --- /dev/null +++ b/test/regression/Results/builtins-aarch64 @@ -0,0 +1,15 @@ +bswap(12345678) = 78563412 +bswap16(1234) = 3412 +bswap64(123456789abcdef0) = f0debc9a78563412 +clz(12345678) = 3 +clzll(12345678) = 35 +clzll(1234567812345678) = 3 +cls(1234567) = 10 +cls(-9999) = 17 +clsll(1234567) = 42 +clsll(-9999) = 49 +fsqrt(3.141590) = 1.772453 +fmadd(3.141590, 2.718000, 1.414000) = 9.952842 +fmsub(3.141590, 2.718000, 1.414000) = -7.124842 +fnmadd(3.141590, 2.718000, 1.414000) = -9.952842 +fnmsub(3.141590, 2.718000, 1.414000) = 7.124842 diff --git a/test/regression/builtins-aarch64.c b/test/regression/builtins-aarch64.c new file mode 100644 index 00000000..2cfa2d09 --- /dev/null +++ b/test/regression/builtins-aarch64.c @@ -0,0 +1,47 @@ +/* Fun with builtin functions */ + +#include + +int main(int argc, char ** argv) +{ + unsigned int x = 0x12345678; + unsigned int y = 0xDEADBEEF; + unsigned long long xx = 0x1234567812345678ULL; + unsigned long long yy = 0x1234567800000000ULL; + unsigned long long zz = 0x123456789ABCDEF0ULL; + unsigned z; + double a = 3.14159; + double b = 2.718; + double c = 1.414; + unsigned short s = 0x1234; + signed int u = 1234567; + signed int v = -9999; + + printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); + printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); + printf("bswap64(%llx) = %llx\n", zz, __builtin_bswap64(zz)); + 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)); + printf("cls(%d) = %d\n", u, __builtin_cls(u)); + printf("cls(%d) = %d\n", v, __builtin_cls(v)); + printf("clsll(%lld) = %d\n", (signed long long) u, __builtin_clsll(u)); + printf("clsll(%lld) = %d\n", (signed long long) v, __builtin_clsll(v)); + + printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); + 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("fnmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmadd(a, b, c)); + printf("fnmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmsub(a, b, c)); + + /* 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/extasm.c b/test/regression/extasm.c index 83a07a05..297178d1 100644 --- a/test/regression/extasm.c +++ b/test/regression/extasm.c @@ -5,14 +5,16 @@ int clobbers(int x, int z) { int y; asm("TEST0 out:%0 in:%1" : "=r"(y) : "r"(x) : "cc" -#if defined(__x86_64__) +#if defined(ARCH_x86) && defined(MODEL_64) , "rax", "rdx", "rbx" -#elif defined(__i386__) +#elif defined(ARCH_x86) && !defined(MODEL_64) , "eax", "edx", "ebx" -#elif defined(__arm__) +#elif defined(ARCH_arm) , "r0", "r1", "r4" -#elif defined(__PPC__) +#elif defined(ARCH_powerpc) , "r0", "r3", "r4", "r31" +#elif defined(ARCH_aarch64) + , "x0", "x1", "x16", "x29", "x30" #endif ); return y + z; @@ -21,7 +23,8 @@ int clobbers(int x, int z) #if (defined(ARCH_x86) && defined(MODEL_64)) \ || (defined(ARCH_riscV) && defined(MODEL_64)) \ || (defined(ARCH_powerpc) && defined(MODEL_ppc64)) \ - || (defined(ARCH_powerpc) && defined(MODEL_e5500)) + || (defined(ARCH_powerpc) && defined(MODEL_e5500)) \ + || defined(ARCH_aarch64) #define SIXTYFOUR #else #undef SIXTYFOUR -- cgit From 27167c6226bbdd2856b8bb6c290b31b5e8534ba9 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 8 Aug 2019 11:19:15 +0200 Subject: Test for the compilation of floating-point literals With special emphasis on the use of the AArch64 fmov #imm instruction. --- test/regression/Makefile | 2 +- test/regression/Results/floats-lit | 2 + test/regression/floats-lit.c | 559 +++++++++++++++++++++++++++++++++++++ 3 files changed, 562 insertions(+), 1 deletion(-) create mode 100644 test/regression/Results/floats-lit create mode 100644 test/regression/floats-lit.c diff --git a/test/regression/Makefile b/test/regression/Makefile index e5b0655e..8e8d8762 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -10,7 +10,7 @@ LIBS=$(LIBMATH) # Can run, both in compiled mode and in interpreter mode, # and have reference output in Results -TESTS=int32 int64 floats floats-basics \ +TESTS=int32 int64 floats floats-basics floats-lit \ expr1 expr6 funptr2 initializers initializers2 initializers3 \ volatile1 volatile2 volatile3 volatile4 \ funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \ diff --git a/test/regression/Results/floats-lit b/test/regression/Results/floats-lit new file mode 100644 index 00000000..6cde72fb --- /dev/null +++ b/test/regression/Results/floats-lit @@ -0,0 +1,2 @@ +--- Double-precision test +--- Single-precision test diff --git a/test/regression/floats-lit.c b/test/regression/floats-lit.c new file mode 100644 index 00000000..a1098faf --- /dev/null +++ b/test/regression/floats-lit.c @@ -0,0 +1,559 @@ +#include + +int error = 0; + +void dbl(double x, unsigned long long bits) +{ + union { double d; unsigned long long i; } u; + u.d = x; + if (u.i != bits) { + printf("Error: expected 0x%016llx, got 0x%016llx\n", bits, u.i); + error = 1; + } +} + +void sng(float x, unsigned int bits) +{ + union { float f; unsigned int i; } u; + u.f = x; + if (u.i != bits) { + printf("Error: expected 0x%08x, got 0x%08x\n", bits, u.i); + error = 1; + } +} + +void testdbl(void) +{ + printf("--- Double-precision test\n"); + dbl(0.0, 0ULL); + dbl((-0.0), 0x8000000000000000ULL); + // The following are the "fmov immediate" of aarch64 + // They include +1.0 and -1.0 + dbl(0x1p-3, 0x3fc0000000000000ULL); + dbl(0x1.1p-3, 0x3fc1000000000000ULL); + dbl(0x1.2p-3, 0x3fc2000000000000ULL); + dbl(0x1.3p-3, 0x3fc3000000000000ULL); + dbl(0x1.4p-3, 0x3fc4000000000000ULL); + dbl(0x1.5p-3, 0x3fc5000000000000ULL); + dbl(0x1.6p-3, 0x3fc6000000000000ULL); + dbl(0x1.7p-3, 0x3fc7000000000000ULL); + dbl(0x1.8p-3, 0x3fc8000000000000ULL); + dbl(0x1.9p-3, 0x3fc9000000000000ULL); + dbl(0x1.ap-3, 0x3fca000000000000ULL); + dbl(0x1.bp-3, 0x3fcb000000000000ULL); + dbl(0x1.cp-3, 0x3fcc000000000000ULL); + dbl(0x1.dp-3, 0x3fcd000000000000ULL); + dbl(0x1.ep-3, 0x3fce000000000000ULL); + dbl(0x1.fp-3, 0x3fcf000000000000ULL); + dbl(0x1p-2, 0x3fd0000000000000ULL); + dbl(0x1.1p-2, 0x3fd1000000000000ULL); + dbl(0x1.2p-2, 0x3fd2000000000000ULL); + dbl(0x1.3p-2, 0x3fd3000000000000ULL); + dbl(0x1.4p-2, 0x3fd4000000000000ULL); + dbl(0x1.5p-2, 0x3fd5000000000000ULL); + dbl(0x1.6p-2, 0x3fd6000000000000ULL); + dbl(0x1.7p-2, 0x3fd7000000000000ULL); + dbl(0x1.8p-2, 0x3fd8000000000000ULL); + dbl(0x1.9p-2, 0x3fd9000000000000ULL); + dbl(0x1.ap-2, 0x3fda000000000000ULL); + dbl(0x1.bp-2, 0x3fdb000000000000ULL); + dbl(0x1.cp-2, 0x3fdc000000000000ULL); + dbl(0x1.dp-2, 0x3fdd000000000000ULL); + dbl(0x1.ep-2, 0x3fde000000000000ULL); + dbl(0x1.fp-2, 0x3fdf000000000000ULL); + dbl(0x1p-1, 0x3fe0000000000000ULL); + dbl(0x1.1p-1, 0x3fe1000000000000ULL); + dbl(0x1.2p-1, 0x3fe2000000000000ULL); + dbl(0x1.3p-1, 0x3fe3000000000000ULL); + dbl(0x1.4p-1, 0x3fe4000000000000ULL); + dbl(0x1.5p-1, 0x3fe5000000000000ULL); + dbl(0x1.6p-1, 0x3fe6000000000000ULL); + dbl(0x1.7p-1, 0x3fe7000000000000ULL); + dbl(0x1.8p-1, 0x3fe8000000000000ULL); + dbl(0x1.9p-1, 0x3fe9000000000000ULL); + dbl(0x1.ap-1, 0x3fea000000000000ULL); + dbl(0x1.bp-1, 0x3feb000000000000ULL); + dbl(0x1.cp-1, 0x3fec000000000000ULL); + dbl(0x1.dp-1, 0x3fed000000000000ULL); + dbl(0x1.ep-1, 0x3fee000000000000ULL); + dbl(0x1.fp-1, 0x3fef000000000000ULL); + dbl(0x1p+0, 0x3ff0000000000000ULL); + dbl(0x1.1p+0, 0x3ff1000000000000ULL); + dbl(0x1.2p+0, 0x3ff2000000000000ULL); + dbl(0x1.3p+0, 0x3ff3000000000000ULL); + dbl(0x1.4p+0, 0x3ff4000000000000ULL); + dbl(0x1.5p+0, 0x3ff5000000000000ULL); + dbl(0x1.6p+0, 0x3ff6000000000000ULL); + dbl(0x1.7p+0, 0x3ff7000000000000ULL); + dbl(0x1.8p+0, 0x3ff8000000000000ULL); + dbl(0x1.9p+0, 0x3ff9000000000000ULL); + dbl(0x1.ap+0, 0x3ffa000000000000ULL); + dbl(0x1.bp+0, 0x3ffb000000000000ULL); + dbl(0x1.cp+0, 0x3ffc000000000000ULL); + dbl(0x1.dp+0, 0x3ffd000000000000ULL); + dbl(0x1.ep+0, 0x3ffe000000000000ULL); + dbl(0x1.fp+0, 0x3fff000000000000ULL); + dbl(0x1p+1, 0x4000000000000000ULL); + dbl(0x1.1p+1, 0x4001000000000000ULL); + dbl(0x1.2p+1, 0x4002000000000000ULL); + dbl(0x1.3p+1, 0x4003000000000000ULL); + dbl(0x1.4p+1, 0x4004000000000000ULL); + dbl(0x1.5p+1, 0x4005000000000000ULL); + dbl(0x1.6p+1, 0x4006000000000000ULL); + dbl(0x1.7p+1, 0x4007000000000000ULL); + dbl(0x1.8p+1, 0x4008000000000000ULL); + dbl(0x1.9p+1, 0x4009000000000000ULL); + dbl(0x1.ap+1, 0x400a000000000000ULL); + dbl(0x1.bp+1, 0x400b000000000000ULL); + dbl(0x1.cp+1, 0x400c000000000000ULL); + dbl(0x1.dp+1, 0x400d000000000000ULL); + dbl(0x1.ep+1, 0x400e000000000000ULL); + dbl(0x1.fp+1, 0x400f000000000000ULL); + dbl(0x1p+2, 0x4010000000000000ULL); + dbl(0x1.1p+2, 0x4011000000000000ULL); + dbl(0x1.2p+2, 0x4012000000000000ULL); + dbl(0x1.3p+2, 0x4013000000000000ULL); + dbl(0x1.4p+2, 0x4014000000000000ULL); + dbl(0x1.5p+2, 0x4015000000000000ULL); + dbl(0x1.6p+2, 0x4016000000000000ULL); + dbl(0x1.7p+2, 0x4017000000000000ULL); + dbl(0x1.8p+2, 0x4018000000000000ULL); + dbl(0x1.9p+2, 0x4019000000000000ULL); + dbl(0x1.ap+2, 0x401a000000000000ULL); + dbl(0x1.bp+2, 0x401b000000000000ULL); + dbl(0x1.cp+2, 0x401c000000000000ULL); + dbl(0x1.dp+2, 0x401d000000000000ULL); + dbl(0x1.ep+2, 0x401e000000000000ULL); + dbl(0x1.fp+2, 0x401f000000000000ULL); + dbl(0x1p+3, 0x4020000000000000ULL); + dbl(0x1.1p+3, 0x4021000000000000ULL); + dbl(0x1.2p+3, 0x4022000000000000ULL); + dbl(0x1.3p+3, 0x4023000000000000ULL); + dbl(0x1.4p+3, 0x4024000000000000ULL); + dbl(0x1.5p+3, 0x4025000000000000ULL); + dbl(0x1.6p+3, 0x4026000000000000ULL); + dbl(0x1.7p+3, 0x4027000000000000ULL); + dbl(0x1.8p+3, 0x4028000000000000ULL); + dbl(0x1.9p+3, 0x4029000000000000ULL); + dbl(0x1.ap+3, 0x402a000000000000ULL); + dbl(0x1.bp+3, 0x402b000000000000ULL); + dbl(0x1.cp+3, 0x402c000000000000ULL); + dbl(0x1.dp+3, 0x402d000000000000ULL); + dbl(0x1.ep+3, 0x402e000000000000ULL); + dbl(0x1.fp+3, 0x402f000000000000ULL); + dbl(0x1p+4, 0x4030000000000000ULL); + dbl(0x1.1p+4, 0x4031000000000000ULL); + dbl(0x1.2p+4, 0x4032000000000000ULL); + dbl(0x1.3p+4, 0x4033000000000000ULL); + dbl(0x1.4p+4, 0x4034000000000000ULL); + dbl(0x1.5p+4, 0x4035000000000000ULL); + dbl(0x1.6p+4, 0x4036000000000000ULL); + dbl(0x1.7p+4, 0x4037000000000000ULL); + dbl(0x1.8p+4, 0x4038000000000000ULL); + dbl(0x1.9p+4, 0x4039000000000000ULL); + dbl(0x1.ap+4, 0x403a000000000000ULL); + dbl(0x1.bp+4, 0x403b000000000000ULL); + dbl(0x1.cp+4, 0x403c000000000000ULL); + dbl(0x1.dp+4, 0x403d000000000000ULL); + dbl(0x1.ep+4, 0x403e000000000000ULL); + dbl(0x1.fp+4, 0x403f000000000000ULL); + dbl((-0x1p-3), 0xbfc0000000000000ULL); + dbl((-0x1.1p-3), 0xbfc1000000000000ULL); + dbl((-0x1.2p-3), 0xbfc2000000000000ULL); + dbl((-0x1.3p-3), 0xbfc3000000000000ULL); + dbl((-0x1.4p-3), 0xbfc4000000000000ULL); + dbl((-0x1.5p-3), 0xbfc5000000000000ULL); + dbl((-0x1.6p-3), 0xbfc6000000000000ULL); + dbl((-0x1.7p-3), 0xbfc7000000000000ULL); + dbl((-0x1.8p-3), 0xbfc8000000000000ULL); + dbl((-0x1.9p-3), 0xbfc9000000000000ULL); + dbl((-0x1.ap-3), 0xbfca000000000000ULL); + dbl((-0x1.bp-3), 0xbfcb000000000000ULL); + dbl((-0x1.cp-3), 0xbfcc000000000000ULL); + dbl((-0x1.dp-3), 0xbfcd000000000000ULL); + dbl((-0x1.ep-3), 0xbfce000000000000ULL); + dbl((-0x1.fp-3), 0xbfcf000000000000ULL); + dbl((-0x1p-2), 0xbfd0000000000000ULL); + dbl((-0x1.1p-2), 0xbfd1000000000000ULL); + dbl((-0x1.2p-2), 0xbfd2000000000000ULL); + dbl((-0x1.3p-2), 0xbfd3000000000000ULL); + dbl((-0x1.4p-2), 0xbfd4000000000000ULL); + dbl((-0x1.5p-2), 0xbfd5000000000000ULL); + dbl((-0x1.6p-2), 0xbfd6000000000000ULL); + dbl((-0x1.7p-2), 0xbfd7000000000000ULL); + dbl((-0x1.8p-2), 0xbfd8000000000000ULL); + dbl((-0x1.9p-2), 0xbfd9000000000000ULL); + dbl((-0x1.ap-2), 0xbfda000000000000ULL); + dbl((-0x1.bp-2), 0xbfdb000000000000ULL); + dbl((-0x1.cp-2), 0xbfdc000000000000ULL); + dbl((-0x1.dp-2), 0xbfdd000000000000ULL); + dbl((-0x1.ep-2), 0xbfde000000000000ULL); + dbl((-0x1.fp-2), 0xbfdf000000000000ULL); + dbl((-0x1p-1), 0xbfe0000000000000ULL); + dbl((-0x1.1p-1), 0xbfe1000000000000ULL); + dbl((-0x1.2p-1), 0xbfe2000000000000ULL); + dbl((-0x1.3p-1), 0xbfe3000000000000ULL); + dbl((-0x1.4p-1), 0xbfe4000000000000ULL); + dbl((-0x1.5p-1), 0xbfe5000000000000ULL); + dbl((-0x1.6p-1), 0xbfe6000000000000ULL); + dbl((-0x1.7p-1), 0xbfe7000000000000ULL); + dbl((-0x1.8p-1), 0xbfe8000000000000ULL); + dbl((-0x1.9p-1), 0xbfe9000000000000ULL); + dbl((-0x1.ap-1), 0xbfea000000000000ULL); + dbl((-0x1.bp-1), 0xbfeb000000000000ULL); + dbl((-0x1.cp-1), 0xbfec000000000000ULL); + dbl((-0x1.dp-1), 0xbfed000000000000ULL); + dbl((-0x1.ep-1), 0xbfee000000000000ULL); + dbl((-0x1.fp-1), 0xbfef000000000000ULL); + dbl((-0x1p+0), 0xbff0000000000000ULL); + dbl((-0x1.1p+0), 0xbff1000000000000ULL); + dbl((-0x1.2p+0), 0xbff2000000000000ULL); + dbl((-0x1.3p+0), 0xbff3000000000000ULL); + dbl((-0x1.4p+0), 0xbff4000000000000ULL); + dbl((-0x1.5p+0), 0xbff5000000000000ULL); + dbl((-0x1.6p+0), 0xbff6000000000000ULL); + dbl((-0x1.7p+0), 0xbff7000000000000ULL); + dbl((-0x1.8p+0), 0xbff8000000000000ULL); + dbl((-0x1.9p+0), 0xbff9000000000000ULL); + dbl((-0x1.ap+0), 0xbffa000000000000ULL); + dbl((-0x1.bp+0), 0xbffb000000000000ULL); + dbl((-0x1.cp+0), 0xbffc000000000000ULL); + dbl((-0x1.dp+0), 0xbffd000000000000ULL); + dbl((-0x1.ep+0), 0xbffe000000000000ULL); + dbl((-0x1.fp+0), 0xbfff000000000000ULL); + dbl((-0x1p+1), 0xc000000000000000ULL); + dbl((-0x1.1p+1), 0xc001000000000000ULL); + dbl((-0x1.2p+1), 0xc002000000000000ULL); + dbl((-0x1.3p+1), 0xc003000000000000ULL); + dbl((-0x1.4p+1), 0xc004000000000000ULL); + dbl((-0x1.5p+1), 0xc005000000000000ULL); + dbl((-0x1.6p+1), 0xc006000000000000ULL); + dbl((-0x1.7p+1), 0xc007000000000000ULL); + dbl((-0x1.8p+1), 0xc008000000000000ULL); + dbl((-0x1.9p+1), 0xc009000000000000ULL); + dbl((-0x1.ap+1), 0xc00a000000000000ULL); + dbl((-0x1.bp+1), 0xc00b000000000000ULL); + dbl((-0x1.cp+1), 0xc00c000000000000ULL); + dbl((-0x1.dp+1), 0xc00d000000000000ULL); + dbl((-0x1.ep+1), 0xc00e000000000000ULL); + dbl((-0x1.fp+1), 0xc00f000000000000ULL); + dbl((-0x1p+2), 0xc010000000000000ULL); + dbl((-0x1.1p+2), 0xc011000000000000ULL); + dbl((-0x1.2p+2), 0xc012000000000000ULL); + dbl((-0x1.3p+2), 0xc013000000000000ULL); + dbl((-0x1.4p+2), 0xc014000000000000ULL); + dbl((-0x1.5p+2), 0xc015000000000000ULL); + dbl((-0x1.6p+2), 0xc016000000000000ULL); + dbl((-0x1.7p+2), 0xc017000000000000ULL); + dbl((-0x1.8p+2), 0xc018000000000000ULL); + dbl((-0x1.9p+2), 0xc019000000000000ULL); + dbl((-0x1.ap+2), 0xc01a000000000000ULL); + dbl((-0x1.bp+2), 0xc01b000000000000ULL); + dbl((-0x1.cp+2), 0xc01c000000000000ULL); + dbl((-0x1.dp+2), 0xc01d000000000000ULL); + dbl((-0x1.ep+2), 0xc01e000000000000ULL); + dbl((-0x1.fp+2), 0xc01f000000000000ULL); + dbl((-0x1p+3), 0xc020000000000000ULL); + dbl((-0x1.1p+3), 0xc021000000000000ULL); + dbl((-0x1.2p+3), 0xc022000000000000ULL); + dbl((-0x1.3p+3), 0xc023000000000000ULL); + dbl((-0x1.4p+3), 0xc024000000000000ULL); + dbl((-0x1.5p+3), 0xc025000000000000ULL); + dbl((-0x1.6p+3), 0xc026000000000000ULL); + dbl((-0x1.7p+3), 0xc027000000000000ULL); + dbl((-0x1.8p+3), 0xc028000000000000ULL); + dbl((-0x1.9p+3), 0xc029000000000000ULL); + dbl((-0x1.ap+3), 0xc02a000000000000ULL); + dbl((-0x1.bp+3), 0xc02b000000000000ULL); + dbl((-0x1.cp+3), 0xc02c000000000000ULL); + dbl((-0x1.dp+3), 0xc02d000000000000ULL); + dbl((-0x1.ep+3), 0xc02e000000000000ULL); + dbl((-0x1.fp+3), 0xc02f000000000000ULL); + dbl((-0x1p+4), 0xc030000000000000ULL); + dbl((-0x1.1p+4), 0xc031000000000000ULL); + dbl((-0x1.2p+4), 0xc032000000000000ULL); + dbl((-0x1.3p+4), 0xc033000000000000ULL); + dbl((-0x1.4p+4), 0xc034000000000000ULL); + dbl((-0x1.5p+4), 0xc035000000000000ULL); + dbl((-0x1.6p+4), 0xc036000000000000ULL); + dbl((-0x1.7p+4), 0xc037000000000000ULL); + dbl((-0x1.8p+4), 0xc038000000000000ULL); + dbl((-0x1.9p+4), 0xc039000000000000ULL); + dbl((-0x1.ap+4), 0xc03a000000000000ULL); + dbl((-0x1.bp+4), 0xc03b000000000000ULL); + dbl((-0x1.cp+4), 0xc03c000000000000ULL); + dbl((-0x1.dp+4), 0xc03d000000000000ULL); + dbl((-0x1.ep+4), 0xc03e000000000000ULL); + dbl((-0x1.fp+4), 0xc03f000000000000ULL); +} + +void testsng(void) +{ + printf("--- Single-precision test\n"); + sng(0x0p+0, 0x0U); + sng(-0x0p+0, 0x80000000U); + sng(0x1p-3, 0x3e000000U); + sng(0x1.1p-3, 0x3e080000U); + sng(0x1.2p-3, 0x3e100000U); + sng(0x1.3p-3, 0x3e180000U); + sng(0x1.4p-3, 0x3e200000U); + sng(0x1.5p-3, 0x3e280000U); + sng(0x1.6p-3, 0x3e300000U); + sng(0x1.7p-3, 0x3e380000U); + sng(0x1.8p-3, 0x3e400000U); + sng(0x1.9p-3, 0x3e480000U); + sng(0x1.ap-3, 0x3e500000U); + sng(0x1.bp-3, 0x3e580000U); + sng(0x1.cp-3, 0x3e600000U); + sng(0x1.dp-3, 0x3e680000U); + sng(0x1.ep-3, 0x3e700000U); + sng(0x1.fp-3, 0x3e780000U); + sng(0x1p-2, 0x3e800000U); + sng(0x1.1p-2, 0x3e880000U); + sng(0x1.2p-2, 0x3e900000U); + sng(0x1.3p-2, 0x3e980000U); + sng(0x1.4p-2, 0x3ea00000U); + sng(0x1.5p-2, 0x3ea80000U); + sng(0x1.6p-2, 0x3eb00000U); + sng(0x1.7p-2, 0x3eb80000U); + sng(0x1.8p-2, 0x3ec00000U); + sng(0x1.9p-2, 0x3ec80000U); + sng(0x1.ap-2, 0x3ed00000U); + sng(0x1.bp-2, 0x3ed80000U); + sng(0x1.cp-2, 0x3ee00000U); + sng(0x1.dp-2, 0x3ee80000U); + sng(0x1.ep-2, 0x3ef00000U); + sng(0x1.fp-2, 0x3ef80000U); + sng(0x1p-1, 0x3f000000U); + sng(0x1.1p-1, 0x3f080000U); + sng(0x1.2p-1, 0x3f100000U); + sng(0x1.3p-1, 0x3f180000U); + sng(0x1.4p-1, 0x3f200000U); + sng(0x1.5p-1, 0x3f280000U); + sng(0x1.6p-1, 0x3f300000U); + sng(0x1.7p-1, 0x3f380000U); + sng(0x1.8p-1, 0x3f400000U); + sng(0x1.9p-1, 0x3f480000U); + sng(0x1.ap-1, 0x3f500000U); + sng(0x1.bp-1, 0x3f580000U); + sng(0x1.cp-1, 0x3f600000U); + sng(0x1.dp-1, 0x3f680000U); + sng(0x1.ep-1, 0x3f700000U); + sng(0x1.fp-1, 0x3f780000U); + sng(0x1p+0, 0x3f800000U); + sng(0x1.1p+0, 0x3f880000U); + sng(0x1.2p+0, 0x3f900000U); + sng(0x1.3p+0, 0x3f980000U); + sng(0x1.4p+0, 0x3fa00000U); + sng(0x1.5p+0, 0x3fa80000U); + sng(0x1.6p+0, 0x3fb00000U); + sng(0x1.7p+0, 0x3fb80000U); + sng(0x1.8p+0, 0x3fc00000U); + sng(0x1.9p+0, 0x3fc80000U); + sng(0x1.ap+0, 0x3fd00000U); + sng(0x1.bp+0, 0x3fd80000U); + sng(0x1.cp+0, 0x3fe00000U); + sng(0x1.dp+0, 0x3fe80000U); + sng(0x1.ep+0, 0x3ff00000U); + sng(0x1.fp+0, 0x3ff80000U); + sng(0x1p+1, 0x40000000U); + sng(0x1.1p+1, 0x40080000U); + sng(0x1.2p+1, 0x40100000U); + sng(0x1.3p+1, 0x40180000U); + sng(0x1.4p+1, 0x40200000U); + sng(0x1.5p+1, 0x40280000U); + sng(0x1.6p+1, 0x40300000U); + sng(0x1.7p+1, 0x40380000U); + sng(0x1.8p+1, 0x40400000U); + sng(0x1.9p+1, 0x40480000U); + sng(0x1.ap+1, 0x40500000U); + sng(0x1.bp+1, 0x40580000U); + sng(0x1.cp+1, 0x40600000U); + sng(0x1.dp+1, 0x40680000U); + sng(0x1.ep+1, 0x40700000U); + sng(0x1.fp+1, 0x40780000U); + sng(0x1p+2, 0x40800000U); + sng(0x1.1p+2, 0x40880000U); + sng(0x1.2p+2, 0x40900000U); + sng(0x1.3p+2, 0x40980000U); + sng(0x1.4p+2, 0x40a00000U); + sng(0x1.5p+2, 0x40a80000U); + sng(0x1.6p+2, 0x40b00000U); + sng(0x1.7p+2, 0x40b80000U); + sng(0x1.8p+2, 0x40c00000U); + sng(0x1.9p+2, 0x40c80000U); + sng(0x1.ap+2, 0x40d00000U); + sng(0x1.bp+2, 0x40d80000U); + sng(0x1.cp+2, 0x40e00000U); + sng(0x1.dp+2, 0x40e80000U); + sng(0x1.ep+2, 0x40f00000U); + sng(0x1.fp+2, 0x40f80000U); + sng(0x1p+3, 0x41000000U); + sng(0x1.1p+3, 0x41080000U); + sng(0x1.2p+3, 0x41100000U); + sng(0x1.3p+3, 0x41180000U); + sng(0x1.4p+3, 0x41200000U); + sng(0x1.5p+3, 0x41280000U); + sng(0x1.6p+3, 0x41300000U); + sng(0x1.7p+3, 0x41380000U); + sng(0x1.8p+3, 0x41400000U); + sng(0x1.9p+3, 0x41480000U); + sng(0x1.ap+3, 0x41500000U); + sng(0x1.bp+3, 0x41580000U); + sng(0x1.cp+3, 0x41600000U); + sng(0x1.dp+3, 0x41680000U); + sng(0x1.ep+3, 0x41700000U); + sng(0x1.fp+3, 0x41780000U); + sng(0x1p+4, 0x41800000U); + sng(0x1.1p+4, 0x41880000U); + sng(0x1.2p+4, 0x41900000U); + sng(0x1.3p+4, 0x41980000U); + sng(0x1.4p+4, 0x41a00000U); + sng(0x1.5p+4, 0x41a80000U); + sng(0x1.6p+4, 0x41b00000U); + sng(0x1.7p+4, 0x41b80000U); + sng(0x1.8p+4, 0x41c00000U); + sng(0x1.9p+4, 0x41c80000U); + sng(0x1.ap+4, 0x41d00000U); + sng(0x1.bp+4, 0x41d80000U); + sng(0x1.cp+4, 0x41e00000U); + sng(0x1.dp+4, 0x41e80000U); + sng(0x1.ep+4, 0x41f00000U); + sng(0x1.fp+4, 0x41f80000U); + sng(-0x1p-3, 0xbe000000U); + sng(-0x1.1p-3, 0xbe080000U); + sng(-0x1.2p-3, 0xbe100000U); + sng(-0x1.3p-3, 0xbe180000U); + sng(-0x1.4p-3, 0xbe200000U); + sng(-0x1.5p-3, 0xbe280000U); + sng(-0x1.6p-3, 0xbe300000U); + sng(-0x1.7p-3, 0xbe380000U); + sng(-0x1.8p-3, 0xbe400000U); + sng(-0x1.9p-3, 0xbe480000U); + sng(-0x1.ap-3, 0xbe500000U); + sng(-0x1.bp-3, 0xbe580000U); + sng(-0x1.cp-3, 0xbe600000U); + sng(-0x1.dp-3, 0xbe680000U); + sng(-0x1.ep-3, 0xbe700000U); + sng(-0x1.fp-3, 0xbe780000U); + sng(-0x1p-2, 0xbe800000U); + sng(-0x1.1p-2, 0xbe880000U); + sng(-0x1.2p-2, 0xbe900000U); + sng(-0x1.3p-2, 0xbe980000U); + sng(-0x1.4p-2, 0xbea00000U); + sng(-0x1.5p-2, 0xbea80000U); + sng(-0x1.6p-2, 0xbeb00000U); + sng(-0x1.7p-2, 0xbeb80000U); + sng(-0x1.8p-2, 0xbec00000U); + sng(-0x1.9p-2, 0xbec80000U); + sng(-0x1.ap-2, 0xbed00000U); + sng(-0x1.bp-2, 0xbed80000U); + sng(-0x1.cp-2, 0xbee00000U); + sng(-0x1.dp-2, 0xbee80000U); + sng(-0x1.ep-2, 0xbef00000U); + sng(-0x1.fp-2, 0xbef80000U); + sng(-0x1p-1, 0xbf000000U); + sng(-0x1.1p-1, 0xbf080000U); + sng(-0x1.2p-1, 0xbf100000U); + sng(-0x1.3p-1, 0xbf180000U); + sng(-0x1.4p-1, 0xbf200000U); + sng(-0x1.5p-1, 0xbf280000U); + sng(-0x1.6p-1, 0xbf300000U); + sng(-0x1.7p-1, 0xbf380000U); + sng(-0x1.8p-1, 0xbf400000U); + sng(-0x1.9p-1, 0xbf480000U); + sng(-0x1.ap-1, 0xbf500000U); + sng(-0x1.bp-1, 0xbf580000U); + sng(-0x1.cp-1, 0xbf600000U); + sng(-0x1.dp-1, 0xbf680000U); + sng(-0x1.ep-1, 0xbf700000U); + sng(-0x1.fp-1, 0xbf780000U); + sng(-0x1p+0, 0xbf800000U); + sng(-0x1.1p+0, 0xbf880000U); + sng(-0x1.2p+0, 0xbf900000U); + sng(-0x1.3p+0, 0xbf980000U); + sng(-0x1.4p+0, 0xbfa00000U); + sng(-0x1.5p+0, 0xbfa80000U); + sng(-0x1.6p+0, 0xbfb00000U); + sng(-0x1.7p+0, 0xbfb80000U); + sng(-0x1.8p+0, 0xbfc00000U); + sng(-0x1.9p+0, 0xbfc80000U); + sng(-0x1.ap+0, 0xbfd00000U); + sng(-0x1.bp+0, 0xbfd80000U); + sng(-0x1.cp+0, 0xbfe00000U); + sng(-0x1.dp+0, 0xbfe80000U); + sng(-0x1.ep+0, 0xbff00000U); + sng(-0x1.fp+0, 0xbff80000U); + sng(-0x1p+1, 0xc0000000U); + sng(-0x1.1p+1, 0xc0080000U); + sng(-0x1.2p+1, 0xc0100000U); + sng(-0x1.3p+1, 0xc0180000U); + sng(-0x1.4p+1, 0xc0200000U); + sng(-0x1.5p+1, 0xc0280000U); + sng(-0x1.6p+1, 0xc0300000U); + sng(-0x1.7p+1, 0xc0380000U); + sng(-0x1.8p+1, 0xc0400000U); + sng(-0x1.9p+1, 0xc0480000U); + sng(-0x1.ap+1, 0xc0500000U); + sng(-0x1.bp+1, 0xc0580000U); + sng(-0x1.cp+1, 0xc0600000U); + sng(-0x1.dp+1, 0xc0680000U); + sng(-0x1.ep+1, 0xc0700000U); + sng(-0x1.fp+1, 0xc0780000U); + sng(-0x1p+2, 0xc0800000U); + sng(-0x1.1p+2, 0xc0880000U); + sng(-0x1.2p+2, 0xc0900000U); + sng(-0x1.3p+2, 0xc0980000U); + sng(-0x1.4p+2, 0xc0a00000U); + sng(-0x1.5p+2, 0xc0a80000U); + sng(-0x1.6p+2, 0xc0b00000U); + sng(-0x1.7p+2, 0xc0b80000U); + sng(-0x1.8p+2, 0xc0c00000U); + sng(-0x1.9p+2, 0xc0c80000U); + sng(-0x1.ap+2, 0xc0d00000U); + sng(-0x1.bp+2, 0xc0d80000U); + sng(-0x1.cp+2, 0xc0e00000U); + sng(-0x1.dp+2, 0xc0e80000U); + sng(-0x1.ep+2, 0xc0f00000U); + sng(-0x1.fp+2, 0xc0f80000U); + sng(-0x1p+3, 0xc1000000U); + sng(-0x1.1p+3, 0xc1080000U); + sng(-0x1.2p+3, 0xc1100000U); + sng(-0x1.3p+3, 0xc1180000U); + sng(-0x1.4p+3, 0xc1200000U); + sng(-0x1.5p+3, 0xc1280000U); + sng(-0x1.6p+3, 0xc1300000U); + sng(-0x1.7p+3, 0xc1380000U); + sng(-0x1.8p+3, 0xc1400000U); + sng(-0x1.9p+3, 0xc1480000U); + sng(-0x1.ap+3, 0xc1500000U); + sng(-0x1.bp+3, 0xc1580000U); + sng(-0x1.cp+3, 0xc1600000U); + sng(-0x1.dp+3, 0xc1680000U); + sng(-0x1.ep+3, 0xc1700000U); + sng(-0x1.fp+3, 0xc1780000U); + sng(-0x1p+4, 0xc1800000U); + sng(-0x1.1p+4, 0xc1880000U); + sng(-0x1.2p+4, 0xc1900000U); + sng(-0x1.3p+4, 0xc1980000U); + sng(-0x1.4p+4, 0xc1a00000U); + sng(-0x1.5p+4, 0xc1a80000U); + sng(-0x1.6p+4, 0xc1b00000U); + sng(-0x1.7p+4, 0xc1b80000U); + sng(-0x1.8p+4, 0xc1c00000U); + sng(-0x1.9p+4, 0xc1c80000U); + sng(-0x1.ap+4, 0xc1d00000U); + sng(-0x1.bp+4, 0xc1d80000U); + sng(-0x1.cp+4, 0xc1e00000U); + sng(-0x1.dp+4, 0xc1e80000U); + sng(-0x1.ep+4, 0xc1f00000U); + sng(-0x1.fp+4, 0xc1f80000U); +} + + +int main() +{ + testdbl(); + testsng(); + return error; +} -- cgit From 7d5db993033ce049776fa290ae1ebc6051dea0f3 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sat, 17 Aug 2019 10:10:42 +0200 Subject: Fix compile for architectures other than AArch64 (#192) Some changes were not correctly propagated to all architectures. --- arm/SelectOpproof.v | 4 ++-- backend/SelectDivproof.v | 4 ++-- powerpc/SelectOpproof.v | 4 ++-- riscV/Asmgenproof1.v | 8 ++++---- riscV/SelectOpproof.v | 4 ++-- x86/SelectOpproof.v | 8 ++++---- 6 files changed, 16 insertions(+), 16 deletions(-) diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index 5d54d94f..70f8f191 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -754,7 +754,7 @@ 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. + rewrite Val.zero_ext_and. apply eval_andimm. omega. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). @@ -767,7 +767,7 @@ 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. + rewrite Val.zero_ext_and. apply eval_andimm. omega. Qed. Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v index 334bedf6..c57d3652 100644 --- a/backend/SelectDivproof.v +++ b/backend/SelectDivproof.v @@ -835,7 +835,7 @@ Proof. assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)). { constructor; auto. } exploit eval_mullhs. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1). - exploit eval_addl. try apply HELPERS. eexact A1. eexact A0. intros (v2 & A2 & B2). + exploit eval_addl. auto. eexact A1. eexact A0. intros (v2 & A2 & B2). exploit eval_shrluimm. try apply HELPERS. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3). set (a4 := if zlt M Int64.half_modulus then mullhs (Eletvar 0) (Int64.repr M) @@ -844,7 +844,7 @@ Proof. assert (A4: eval_expr ge sp e m le a4 v4). { unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. } exploit eval_shrlimm. try apply HELPERS. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5). - exploit eval_addl. try apply HELPERS. eexact A5. eexact A3. intros (v6 & A6 & B6). + exploit eval_addl. auto. eexact A5. eexact A3. intros (v6 & A6 & B6). assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true). { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto. assert (64 < Int.max_unsigned) by (compute; auto). omega. } diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index 1f23f4bd..c3eda068 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -805,7 +805,7 @@ Qed. Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. red; intros. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm; auto. compute; auto. + rewrite Val.zero_ext_and. apply eval_andimm; auto. omega. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). @@ -818,7 +818,7 @@ Qed. Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). Proof. red; intros. unfold cast16unsigned. - rewrite Val.zero_ext_and. apply eval_andimm; auto. compute; auto. + rewrite Val.zero_ext_and. apply eval_andimm; auto. omega. Qed. Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index b4d6b831..c20c4e49 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -407,7 +407,7 @@ Lemma transl_cbranch_correct_1: agree ms sp rs -> Mem.extends m m' -> exists rs', exists insn, - exec_straight_opt c rs m' (insn :: k) rs' m' + exec_straight_opt ge fn c rs m' (insn :: k) rs' m' /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. Proof. @@ -502,7 +502,7 @@ Lemma transl_cbranch_correct_true: agree ms sp rs -> Mem.extends m m' -> exists rs', exists insn, - exec_straight_opt c rs m' (insn :: k) rs' m' + exec_straight_opt ge fn c rs m' (insn :: k) rs' m' /\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m' /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. Proof. @@ -1092,7 +1092,7 @@ Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, base <> X31 -> exists base' ofs' rs', - exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m + exec_straight_opt ge fn (indexed_memory_access mk_instr base ofs k) rs m (mk_instr base' ofs' :: k) rs' m /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. @@ -1242,7 +1242,7 @@ Lemma transl_memory_access_correct: transl_memory_access mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> exists base ofs rs', - exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m + exec_straight_opt ge fn c rs m (mk_instr base ofs :: k) rs' m /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. Proof. diff --git a/riscV/SelectOpproof.v b/riscV/SelectOpproof.v index 18bc5dfe..593be1ed 100644 --- a/riscV/SelectOpproof.v +++ b/riscV/SelectOpproof.v @@ -763,7 +763,7 @@ 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. + rewrite Val.zero_ext_and. apply eval_andimm. omega. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). @@ -776,7 +776,7 @@ 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. + rewrite Val.zero_ext_and. apply eval_andimm. omega. Qed. Theorem eval_intoffloat: diff --git a/x86/SelectOpproof.v b/x86/SelectOpproof.v index a1bb0703..961f602c 100644 --- a/x86/SelectOpproof.v +++ b/x86/SelectOpproof.v @@ -381,9 +381,9 @@ Proof. - TrivialExists. simpl. rewrite Int.and_commut; auto. - TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. - rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. compute; auto. + rewrite Int.and_commut. auto. omega. - rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. compute; auto. + rewrite Int.and_commut. auto. omega. - TrivialExists. Qed. @@ -743,7 +743,7 @@ Proof. red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval. TrivialExists. subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. compute; auto. + rewrite Int.and_commut. apply eval_andimm; auto. omega. TrivialExists. Qed. @@ -759,7 +759,7 @@ Proof. red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval. TrivialExists. subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. compute; auto. + rewrite Int.and_commut. apply eval_andimm; auto. omega. TrivialExists. Qed. -- cgit From 25a39ae6be7a4b65e01d9bb6b1fd94688aa674b0 Mon Sep 17 00:00:00 2001 From: "xavier.leroy" Date: Fri, 23 Aug 2019 08:18:27 +0200 Subject: Offset out of range for ldp/stp instructions These instructions are generated by __builtin_memcpy. --- aarch64/Asmexpand.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index 71bd0042..ab155e9c 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -146,7 +146,9 @@ let expand_annot_val kind txt targ args res = Temporary registers used: x15 x16 x17 x29 x30. *) let offset_in_range ofs = - let ofs = Z.to_int64 ofs in 0L <= ofs && ofs < 0x1000L + (* The 512 upper bound comes from ldp/stp. Single-register load/store + instructions support bigger offsets. *) + let ofs = Z.to_int64 ofs in 0L <= ofs && ofs < 512L let memcpy_small_arg sz arg tmp = match arg with -- cgit From c243b565ab0744086e10efcfee16768f6c3cf880 Mon Sep 17 00:00:00 2001 From: "xavier.leroy" Date: Sat, 31 Aug 2019 17:00:24 +0200 Subject: AArch64: wrong expected type for arguments of Cmaskl{zero,notzero} The argument is of type Tlong, not Tint. This caused spurious errors in RTLtyping. Also: in AArch64/PrintOp.ml, print Cmaskl{zero,notzero} with "&l" to distinguish them from Cmask{zero,notzero}. --- aarch64/Op.v | 4 ++-- aarch64/PrintOp.ml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/aarch64/Op.v b/aarch64/Op.v index 34c03c77..a7483d56 100644 --- a/aarch64/Op.v +++ b/aarch64/Op.v @@ -564,8 +564,8 @@ Definition type_of_condition (c: condition) : list typ := | Ccompluimm _ _ => Tlong :: nil | Ccomplshift _ _ _ => Tlong :: Tlong :: nil | Ccomplushift _ _ _ => Tlong :: Tlong :: nil - | Cmasklzero _ => Tint :: nil - | Cmasklnotzero _ => Tint :: nil + | Cmasklzero _ => Tlong :: nil + | Cmasklnotzero _ => Tlong :: nil | Ccompf _ => Tfloat :: Tfloat :: nil | Cnotcompf _ => Tfloat :: Tfloat :: nil | Ccompfzero _ => Tfloat :: nil diff --git a/aarch64/PrintOp.ml b/aarch64/PrintOp.ml index 1780104c..2d45e446 100644 --- a/aarch64/PrintOp.ml +++ b/aarch64/PrintOp.ml @@ -73,9 +73,9 @@ let print_condition reg pp = function | (Ccomplushift(c, s, a), [r1;r2]) -> fprintf pp "%a %slu %a %a" reg r1 (comparison_name c) reg r2 shift (s, a) | (Cmasklzero n, [r1]) -> - fprintf pp "%a & 0x%Lx == 0" reg r1 (camlint64_of_coqint n) + fprintf pp "%a &l 0x%Lx == 0" reg r1 (camlint64_of_coqint n) | (Cmasklnotzero n, [r1]) -> - fprintf pp "%a & 0x%Lx != 0" reg r1 (camlint64_of_coqint n) + fprintf pp "%a &l 0x%Lx != 0" reg r1 (camlint64_of_coqint n) | (Ccompf c, [r1;r2]) -> fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 | (Cnotcompf c, [r1;r2]) -> -- cgit From 71c58a8d494eafd847776446b0c246229b2bc9cf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Sep 2019 18:30:25 +0200 Subject: avancement (il faut utiliser Vundef visiblement) --- backend/Allocation.v | 2 +- backend/Allocproof.v | 8 ++++---- backend/CSE.v | 6 +++--- backend/Constprop.v | 4 ++-- backend/Deadcode.v | 4 ++-- backend/Inlining.v | 4 ++-- backend/Inliningspec.v | 6 +++--- backend/Liveness.v | 2 +- backend/RTL.v | 40 +++++++++++++++++++++++++++++----------- backend/RTLgen.v | 2 +- backend/RTLgenspec.v | 2 +- backend/RTLtyping.v | 12 ++++++------ backend/Renumber.v | 2 +- backend/Renumberproof.v | 12 ++++++++++++ backend/Tailcallproof.v | 13 +++++++++++++ backend/Unusedglob.v | 2 +- backend/Unusedglobproof.v | 32 +++++++++++++++++++++++++++++++- backend/ValueAnalysis.v | 2 +- mppa_k1c/Op.v | 39 +++++++++++++++++++++++++++++++++++++++ 19 files changed, 153 insertions(+), 41 deletions(-) diff --git a/backend/Allocation.v b/backend/Allocation.v index 13e14530..c2e80f1c 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -226,7 +226,7 @@ Definition pair_instr_block | operation_other _ _ => pair_Iop_block op args res s b end - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => let (mv1, b1) := extract_moves nil b in match b1 with | Lload chunk' addr' args' dst' :: b2 => diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 1804f46b..ac4122bc 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -96,10 +96,10 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr expand_block_shape (BSopdead op args res mv s) (Iop op args res s) (expand_moves mv (Lbranch s :: k)) - | ebs_load: forall chunk addr args dst mv1 args' dst' mv2 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 chunk addr args dst mv1 args' dst' mv2 s) - (Iload chunk addr args dst s) + (Iload trap chunk addr args dst s) (expand_moves mv1 (Lload 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, @@ -130,10 +130,10 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (expand_moves mv1 (Lload Mint32 addr2 args' dst' :: expand_moves mv2 (Lbranch s :: k))) - | ebs_load_dead: forall chunk addr args dst mv 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 chunk addr args dst 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 -> diff --git a/backend/CSE.v b/backend/CSE.v index 6d3f6f33..aaaf492c 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -459,7 +459,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb before | Iop op args res s => add_op before res op args - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => add_load before dst chunk addr args | Istore chunk addr args src s => let app := approx!!pc in @@ -529,14 +529,14 @@ Definition transf_instr (n: numbering) (instr: instruction) := let (op', args') := reduce _ combine_op n1 op args vl in Iop op' args' res s end - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => let (n1, vl) := valnum_regs n args in match find_rhs n1 (Load chunk addr vl) with | Some r => Iop Omove (r :: nil) dst s | None => let (addr', args') := reduce _ combine_addr n1 addr args vl in - Iload chunk addr' args' dst s + Iload trap chunk addr' args' dst s end | Istore chunk addr args src s => let (n1, vl) := valnum_regs n args in diff --git a/backend/Constprop.v b/backend/Constprop.v index d8211ffe..b68f4cae 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -157,7 +157,7 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) let (op', args') := op_strength_reduction op args aargs in Iop op' args' res s' end - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => let aargs := aregs ae args in let a := ValueDomain.loadv chunk rm am (eval_static_addressing addr aargs) in match const_for_result a with @@ -165,7 +165,7 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) Iop cop nil dst s | None => let (addr', args') := addr_strength_reduction addr args aargs in - Iload chunk addr' args' dst s + Iload trap chunk addr' args' dst s end | Istore chunk addr args src s => let aargs := aregs ae args in diff --git a/backend/Deadcode.v b/backend/Deadcode.v index 2286876e..1f208a91 100644 --- a/backend/Deadcode.v +++ b/backend/Deadcode.v @@ -123,7 +123,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) if is_dead nres then after else if is_int_zero nres then (kill res ne, nm) else (add_needs args (needs_of_operation op nres) (kill res ne), nm) - | Some (Iload chunk addr args dst s) => + | Some (Iload trap chunk addr args dst s) => let ndst := nreg ne dst in if is_dead ndst then after else if is_int_zero ndst then (kill dst ne, nm) @@ -175,7 +175,7 @@ Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t) end else instr - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => let ndst := nreg (fst an!!pc) dst in if is_dead ndst then Inop s diff --git a/backend/Inlining.v b/backend/Inlining.v index f7ee4166..9cf535b9 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -364,9 +364,9 @@ Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit := | Iop op args res s => set_instr (spc ctx pc) (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => set_instr (spc ctx pc) - (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s)) + (Iload trap chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s)) | Istore chunk addr args src s => set_instr (spc ctx pc) (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v index c345c942..e20fb373 100644 --- a/backend/Inliningspec.v +++ b/backend/Inliningspec.v @@ -270,10 +270,10 @@ Inductive tr_instr: context -> node -> instruction -> code -> Prop := Ple res ctx.(mreg) -> c!(spc ctx pc) = Some (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) -> tr_instr ctx pc (Iop op args res s) c - | tr_load: forall ctx pc c chunk addr args res s, + | tr_load: forall ctx pc c trap chunk addr args res s, Ple res ctx.(mreg) -> - c!(spc ctx pc) = Some (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) -> - tr_instr ctx pc (Iload chunk addr args res s) c + c!(spc ctx pc) = Some (Iload trap chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) -> + tr_instr ctx pc (Iload trap chunk addr args res s) c | tr_store: forall ctx pc c chunk addr args src s, c!(spc ctx pc) = Some (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) -> tr_instr ctx pc (Istore chunk addr args src s) c diff --git a/backend/Liveness.v b/backend/Liveness.v index 16533158..afe11ae6 100644 --- a/backend/Liveness.v +++ b/backend/Liveness.v @@ -79,7 +79,7 @@ Definition transfer reg_list_live args (reg_dead res after) else after - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => if Regset.mem dst after then reg_list_live args (reg_dead dst after) else diff --git a/backend/RTL.v b/backend/RTL.v index 9599a24a..d09cca77 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -36,6 +36,8 @@ Require Import Op Registers. Definition node := positive. +Inductive trapping_mode : Type := TRAP | NOTRAP. + Inductive instruction: Type := | Inop: node -> instruction (** No operation -- just branch to the successor. *) @@ -43,11 +45,12 @@ Inductive instruction: Type := (** [Iop op args dest succ] performs the arithmetic operation [op] over the values of registers [args], stores the result in [dest], and branches to [succ]. *) - | Iload: memory_chunk -> addressing -> list reg -> reg -> node -> instruction - (** [Iload chunk addr args dest succ] loads a [chunk] quantity from + | Iload: trapping_mode -> memory_chunk -> addressing -> list reg -> reg -> node -> instruction + (** [Iload trap chunk addr args dest succ] loads a [chunk] quantity from the address determined by the addressing mode [addr] and the values of the [args] registers, stores the quantity just read - into [dest], and branches to [succ]. *) + into [dest], and branches to [succ]. + If trap=NOTRAP, then failures lead to a default value written to [dest]. *) | Istore: memory_chunk -> addressing -> list reg -> reg -> node -> instruction (** [Istore chunk addr args src succ] stores the value of register [src] in the [chunk] quantity at the @@ -194,6 +197,8 @@ Definition find_function end end. +Definition default_notrap_load_value (chunk : memory_chunk) := Vundef. + (** The transitions are presented as an inductive predicate [step ge st1 t st2], where [ge] is the global environment, [st1] the initial state, [st2] the final state, and [t] the trace @@ -212,12 +217,25 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp pc rs m) E0 (State s f sp pc' (rs#res <- v) m) | exec_Iload: - forall s f sp pc rs m chunk addr args dst pc' a v, - (fn_code f)!pc = Some(Iload chunk addr args dst pc') -> + forall s f sp pc rs m trap chunk addr args dst pc' a v, + (fn_code f)!pc = Some(Iload trap chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> step (State s f sp pc rs m) E0 (State s f sp pc' (rs#dst <- v) m) + | exec_Iload_notrap1: + forall s f sp pc rs m chunk addr args dst pc', + (fn_code f)!pc = Some(Iload NOTRAP chunk addr args dst pc') -> + eval_addressing ge sp addr rs##args = None -> + step (State s f sp pc rs m) + E0 (State s f sp pc' (rs#dst <- (default_notrap_load_value chunk)) m) + | exec_Iload_notrap2: + forall s f sp pc rs m chunk addr args dst pc' a, + (fn_code f)!pc = Some(Iload NOTRAP chunk addr args dst pc') -> + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = None-> + step (State s f sp pc rs m) + E0 (State s f sp pc' (rs#dst <- (default_notrap_load_value chunk)) m) | exec_Istore: forall s f sp pc rs m chunk addr args src pc' a m', (fn_code f)!pc = Some(Istore chunk addr args src pc') -> @@ -299,8 +317,8 @@ Proof. Qed. Lemma exec_Iload': - forall s f sp pc rs m chunk addr args dst pc' rs' a v, - (fn_code f)!pc = Some(Iload chunk addr args dst pc') -> + forall s f sp pc rs m trap chunk addr args dst pc' rs' a v, + (fn_code f)!pc = Some(Iload trap chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> rs' = (rs#dst <- v) -> @@ -384,7 +402,7 @@ Definition successors_instr (i: instruction) : list node := match i with | Inop s => s :: nil | Iop op args res s => s :: nil - | Iload chunk addr args dst s => s :: nil + | Iload trap chunk addr args dst s => s :: nil | Istore chunk addr args src s => s :: nil | Icall sig ros args res s => s :: nil | Itailcall sig ros args => nil @@ -403,7 +421,7 @@ Definition instr_uses (i: instruction) : list reg := match i with | Inop s => nil | Iop op args res s => args - | Iload chunk addr args dst s => args + | Iload trap chunk addr args dst s => args | Istore chunk addr args src s => src :: args | Icall sig (inl r) args res s => r :: args | Icall sig (inr id) args res s => args @@ -422,7 +440,7 @@ Definition instr_defs (i: instruction) : option reg := match i with | Inop s => None | Iop op args res s => Some res - | Iload chunk addr args dst s => Some dst + | Iload trap chunk addr args dst s => Some dst | Istore chunk addr args src s => None | Icall sig ros args res s => Some res | Itailcall sig ros args => None @@ -462,7 +480,7 @@ Definition max_reg_instr (m: positive) (pc: node) (i: instruction) := match i with | Inop s => m | Iop op args res s => fold_left Pos.max args (Pos.max res m) - | Iload chunk addr args dst s => fold_left Pos.max args (Pos.max dst m) + | Iload trap chunk addr args dst s => fold_left Pos.max args (Pos.max dst m) | Istore chunk addr args src s => fold_left Pos.max args (Pos.max src m) | Icall sig (inl r) args res s => fold_left Pos.max args (Pos.max r (Pos.max res m)) | Icall sig (inr id) args res s => fold_left Pos.max args (Pos.max res m) diff --git a/backend/RTLgen.v b/backend/RTLgen.v index 9d7a8506..a0ca0f17 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -436,7 +436,7 @@ Fixpoint transl_expr (map: mapping) (a: expr) (rd: reg) (nd: node) transl_exprlist map al rl no | Eload chunk addr al => do rl <- alloc_regs map al; - do no <- add_instr (Iload chunk addr rl rd nd); + do no <- add_instr (Iload TRAP chunk addr rl rd nd); transl_exprlist map al rl no | Econdition a b c => do nfalse <- transl_expr map c rd nd; diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 17022a7d..aa83da6d 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -707,7 +707,7 @@ Inductive tr_expr (c: code): tr_expr c map pr (Eop op al) ns nd rd dst | tr_Eload: forall map pr chunk addr al ns nd rd n1 rl dst, tr_exprlist c map pr al ns n1 rl -> - c!n1 = Some (Iload chunk addr rl rd nd) -> + c!n1 = Some (Iload TRAP chunk addr rl rd nd) -> reg_map_ok map rd dst -> ~In rd pr -> tr_expr c map pr (Eload chunk addr al) ns nd rd dst | tr_Econdition: forall map pr a ifso ifnot ns nd rd ntrue nfalse dst, diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 8336d1bf..6d27df28 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -104,11 +104,11 @@ Inductive wt_instr : instruction -> Prop := valid_successor s -> wt_instr (Iop op args res s) | wt_Iload: - forall chunk addr args dst s, + forall trap chunk addr args dst s, map env args = type_of_addressing addr -> env dst = type_of_chunk chunk -> valid_successor s -> - wt_instr (Iload chunk addr args dst s) + wt_instr (Iload trap chunk addr args dst s) | wt_Istore: forall chunk addr args src s, map env args = type_of_addressing addr -> @@ -282,7 +282,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv := else (let (targs, tres) := type_of_operation op in do e1 <- S.set_list e args targs; S.set e1 res tres) - | Iload chunk addr args dst s => + | Iload trap chunk addr args dst s => do x <- check_successor s; do e1 <- S.set_list e args (type_of_addressing addr); S.set e1 dst (type_of_chunk chunk) @@ -841,14 +841,14 @@ Proof. Qed. Lemma wt_exec_Iload: - forall env f chunk addr args dst s m a v rs, - wt_instr f env (Iload chunk addr args dst s) -> + forall env f trap chunk addr args dst s m a v rs, + wt_instr f env (Iload trap chunk addr args dst s) -> Mem.loadv chunk m a = Some v -> wt_regset env rs -> wt_regset env (rs#dst <- v). Proof. intros. destruct a; simpl in H0; try discriminate. inv H. - eapply wt_regset_assign; eauto. rewrite H8; eapply Mem.load_type; eauto. + eapply wt_regset_assign; eauto. rewrite H9; eapply Mem.load_type; eauto. Qed. Lemma wt_exec_Ibuiltin: diff --git a/backend/Renumber.v b/backend/Renumber.v index 10f58251..7ba16658 100644 --- a/backend/Renumber.v +++ b/backend/Renumber.v @@ -43,7 +43,7 @@ Definition renum_instr (i: instruction) : instruction := match i with | Inop s => Inop (renum_pc s) | Iop op args res s => Iop op args res (renum_pc s) - | Iload chunk addr args res s => Iload chunk addr args res (renum_pc s) + | Iload trap chunk addr args res s => Iload trap chunk addr args res (renum_pc s) | Istore chunk addr args src s => Istore chunk addr args src (renum_pc s) | Icall sg ros args res s => Icall sg ros args res (renum_pc s) | Itailcall sg ros args => i diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v index 7cda9425..2e161965 100644 --- a/backend/Renumberproof.v +++ b/backend/Renumberproof.v @@ -175,6 +175,18 @@ Proof. rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. eapply exec_Iload; eauto. constructor; auto. eapply reach_succ; eauto. simpl; 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. eapply reach_succ; eauto. simpl; 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. eapply reach_succ; eauto. simpl; auto. (* store *) econstructor; split. assert (eval_addressing tge sp addr rs ## args = Some a). diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 06e314f3..4a5e83a1 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -438,6 +438,19 @@ Proof. apply eval_addressing_preserved. exact symbols_preserved. eauto. econstructor; eauto. apply set_reg_lessdef; auto. + (* TODO *) +- (* load notrap1 *) + TransfInstr. + assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. + + intros [a' [ADDR' ALD]]. + exploit Mem.loadv_extends; eauto. + intros [v' [LOAD' VLD]]. + left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- v') m'); split. + eapply exec_Iload with (a := a'). eauto. rewrite <- ADDR'. + apply eval_addressing_preserved. exact symbols_preserved. eauto. + econstructor; eauto. apply set_reg_lessdef; auto. + - (* store *) TransfInstr. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 8ac7c4ce..1b5f2547 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -46,7 +46,7 @@ Definition ref_instruction (i: instruction) : list ident := match i with | Inop _ => nil | Iop op _ _ _ => globals_operation op - | Iload _ addr _ _ _ => globals_addressing addr + | Iload _ _ addr _ _ _ => globals_addressing addr | Istore _ addr _ _ _ => globals_addressing addr | Icall _ (inl r) _ _ _ => nil | Icall _ (inr id) _ _ _ => id :: nil diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 680daba7..fa120b6d 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -915,7 +915,7 @@ Proof. /\ Val.inject j a ta). { apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Ptrofs.zero) (vl1 := rs##args). intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto. - apply KEPT. red. exists pc, (Iload chunk addr args dst pc'); auto. + apply KEPT. red. exists pc, (Iload trap chunk addr args dst pc'); auto. econstructor; eauto. apply regs_inject; auto. assumption. } @@ -924,6 +924,36 @@ Proof. econstructor; split. eapply exec_Iload; eauto. econstructor; eauto. apply set_reg_inject; auto. +- (* load notrap1 *) + assert (eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = None). + { eapply eval_addressing_inj_none. + intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto. + apply KEPT. red. exists pc, (Iload NOTRAP chunk addr args dst pc'); auto. + econstructor; eauto. + rewrite Ptrofs.add_zero; reflexivity. + apply regs_inject; auto. + eassumption. + assumption. } + + econstructor; split. eapply exec_Iload_notrap1; eauto. + econstructor; eauto. apply set_reg_inject; auto. + +- (* load notrap2 *) + assert (A: exists ta, + eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = Some ta + /\ Val.inject j a ta). + { apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Ptrofs.zero) (vl1 := rs##args). + intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto. + apply KEPT. red. exists pc, (Iload NOTRAP chunk addr args dst pc'); auto. + econstructor; eauto. + apply regs_inject; auto. + assumption. } + destruct A as (ta & B & C). + destruct (Mem.loadv chunk tm ta) eqn:Echunk2. + + econstructor; split. eapply exec_Iload; eauto. + econstructor; eauto. apply set_reg_inject; auto. + + econstructor; split. eapply exec_Iload_notrap2; eauto. + econstructor; eauto. apply set_reg_inject; auto. - (* store *) assert (A: exists ta, eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = Some ta diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 1f80c293..605d7e90 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -121,7 +121,7 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : | Some(Iop op args res s) => let a := eval_static_operation op (aregs ae args) in VA.State (AE.set res a ae) am - | Some(Iload chunk addr args dst s) => + | Some(Iload trap chunk addr args dst s) => let a := loadv chunk rm am (eval_static_addressing addr (aregs ae args)) in VA.State (AE.set dst a ae) am | Some(Istore chunk addr args src s) => diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 815d3958..f3ee0577 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1649,6 +1649,27 @@ Proof. - apply Val.offset_ptr_inject; auto. Qed. +Lemma eval_addressing_inj_none: + forall addr sp1 vl1 sp2 vl2, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = None -> + eval_addressing ge2 sp2 addr vl2 = None. +Proof. + intros until vl2. intros Hglobal Hinjsp Hinjvl. + destruct addr; simpl in *. + 1,2: inv Hinjvl; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + 2,3: inv Hinjvl; trivial; discriminate. + inv Hinjvl; trivial; inv H0; trivial; + inv H; trivial; discriminate. +Qed. + End EVAL_COMPAT. (** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) @@ -1755,6 +1776,24 @@ Proof. destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. + +Lemma eval_addressing_lessdef_none: + forall sp addr vl1 vl2, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = None -> + eval_addressing genv sp addr vl2 = None. +Proof. + intros until vl2. intros Hlessdef Heval1. + destruct addr; simpl in *. + 1, 2, 4, 5: inv Hlessdef; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + inv Hlessdef; trivial. + inv H0; trivial. + discriminate. +Qed. + End EVAL_LESSDEF. (** Compatibility of the evaluation functions with memory injections. *) -- cgit From 5710342ba44a451639a6c28aeb61d0fc24d7ee58 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Sep 2019 20:23:29 +0200 Subject: progress on non trapping loads --- backend/Tailcallproof.v | 40 ++++++++++++++++++++++++++++++++-------- 1 file changed, 32 insertions(+), 8 deletions(-) diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 4a5e83a1..5cb1b980 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -438,19 +438,43 @@ Proof. apply eval_addressing_preserved. exact symbols_preserved. eauto. econstructor; eauto. apply set_reg_lessdef; auto. - (* TODO *) - (* load notrap1 *) TransfInstr. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. - - intros [a' [ADDR' ALD]]. - exploit Mem.loadv_extends; eauto. - intros [v' [LOAD' VLD]]. - left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- v') m'); split. - eapply exec_Iload with (a := a'). eauto. rewrite <- ADDR'. - apply eval_addressing_preserved. exact symbols_preserved. eauto. + left. + exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- (default_notrap_load_value chunk)) m'); split. + eapply exec_Iload_notrap1. + eassumption. + eapply eval_addressing_lessdef_none. eassumption. + erewrite eval_addressing_preserved. + eassumption. exact symbols_preserved. + econstructor; eauto. apply set_reg_lessdef; auto. +- (* load notrap2 *) + TransfInstr. + assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. + left. + + exploit eval_addressing_lessdef; eauto. + intros [a' [ADDR' ALD]]. + + destruct (Mem.loadv chunk m' a') eqn:Echunk2. + + exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- v) m'); split. + eapply exec_Iload with (a:=a'). eassumption. + erewrite eval_addressing_preserved. + eassumption. + exact symbols_preserved. + assumption. + econstructor; eauto. apply set_reg_lessdef; auto. + + exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- (default_notrap_load_value chunk)) m'); split. + eapply exec_Iload_notrap2. eassumption. + erewrite eval_addressing_preserved. + eassumption. + exact symbols_preserved. + assumption. + econstructor; eauto. apply set_reg_lessdef; auto. + - (* store *) TransfInstr. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. -- cgit From b70d80e7259873ac941830e02b022ca8e92541a6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 10:05:26 +0200 Subject: progress on non trapping loads --- backend/Inliningproof.v | 54 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 181f40bf..588d7165 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -929,6 +929,15 @@ Proof. intros. inv H. eauto. Qed. +Lemma eval_addressing_none: + forall sp' ctx addr rs, + eval_addressing ge (Vptr sp' (Ptrofs.repr (dstk ctx))) addr rs = None -> + eval_addressing ge (Vptr sp' Ptrofs.zero) (saddr ctx addr) rs = None. +Proof. + intros until rs; intro Heval. + destruct addr; destruct rs as [| r0 rs1]; simpl in *; trivial; discriminate. +Qed. + Theorem step_simulation: forall S1 t S2, step ge S1 t S2 -> @@ -976,6 +985,51 @@ Proof. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. +- (* load notrap1 *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + left; econstructor; split. + eapply plus_one. eapply exec_Iload_notrap1. eassumption. + rewrite eval_addressing_preserved with (ge1:=ge) (ge2:=tge). + exploit eval_addressing_inj_none. + 4: eassumption. + intros. eapply symbol_address_inject. + eapply match_stacks_inside_globals; eauto. + eauto. + instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto. + rewrite Ptrofs.add_zero_l. + apply eval_addressing_none. + exact symbols_preserved. + econstructor; eauto. + apply match_stacks_inside_set_reg; auto. + apply agree_set_reg; auto. + +- (* load notrap2 *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + + exploit eval_addressing_inject. + eapply match_stacks_inside_globals; eauto. + eexact SP. + instantiate (2 := rs##args). instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto. + eauto. + fold (saddr ctx addr). intros [a' [P Q]]. + + destruct (Mem.loadv chunk m' a') eqn:Hload'. + + left; econstructor; split. + eapply plus_one. + eapply exec_Iload; eauto. + rewrite <- P. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto. + apply match_stacks_inside_set_reg; auto. + apply agree_set_reg; auto. + + + left; econstructor; split. + eapply plus_one. + eapply exec_Iload_notrap2; eauto. + rewrite <- P. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto. + apply match_stacks_inside_set_reg; auto. + apply agree_set_reg; auto. + - (* store *) exploit tr_funbody_inv; eauto. intros TR; inv TR. exploit eval_addressing_inject. -- cgit From 863b65cc49fb49ad203694cac36e3cbd4f45dab7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Sep 2019 17:34:02 +0200 Subject: Stubs for Duplicate pass --- Makefile | 1 + backend/Duplicate.v | 31 +++++++++++++++++++++++ backend/Duplicateaux.ml | 3 +++ backend/Duplicateproof.v | 29 ++++++++++++++++++++++ driver/Compiler.v | 64 +++++++++++++++++++++++++++--------------------- 5 files changed, 100 insertions(+), 28 deletions(-) create mode 100644 backend/Duplicate.v create mode 100644 backend/Duplicateaux.ml create mode 100644 backend/Duplicateproof.v diff --git a/Makefile b/Makefile index aa99786b..299f5ffe 100644 --- a/Makefile +++ b/Makefile @@ -80,6 +80,7 @@ BACKEND=\ Tailcall.v Tailcallproof.v \ Inlining.v Inliningspec.v Inliningproof.v \ Renumber.v Renumberproof.v \ + Duplicate.v Duplicateproof.v \ RTLtyping.v \ Kildall.v Liveness.v \ ValueDomain.v ValueAOp.v ValueAnalysis.v \ diff --git a/backend/Duplicate.v b/backend/Duplicate.v new file mode 100644 index 00000000..cb52ec04 --- /dev/null +++ b/backend/Duplicate.v @@ -0,0 +1,31 @@ +(** RTL node duplication using external oracle. Used to form superblock + structures *) + +Require Import AST RTL Maps. +Require Import Coqlib Errors. + +Local Open Scope error_monad_scope. + +(** External oracle returning the new RTL function, along with a mapping + of new nodes to old nodes *) +Axiom duplicate_aux: RTL.function -> RTL.function * (PTree.t nat). + +Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux". + +(** * Verification of node duplications *) + +(** Verifies that the mapping [mp] is giving correct information *) +Definition verify_mapping (f tf: function) (mp: PTree.t nat) : res unit := OK tt. (* TODO *) + +(** * Entry points *) + +Definition transf_function (f: function) : res function := + let (tf, mp) := duplicate_aux f in + do u <- verify_mapping f tf mp; + OK tf. + +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. \ No newline at end of file diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml new file mode 100644 index 00000000..8a57f364 --- /dev/null +++ b/backend/Duplicateaux.ml @@ -0,0 +1,3 @@ +open Maps + +let duplicate_aux f = (f, PTree.empty) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v new file mode 100644 index 00000000..5cf6b368 --- /dev/null +++ b/backend/Duplicateproof.v @@ -0,0 +1,29 @@ +(** Correctness proof for code duplication *) +Require Import AST Linking Errors. +Require Import RTL Globalenvs Smallstep. +Require Import Duplicate. + +Definition match_prog (p tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +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. + +Section PRESERVATION. + +Variable prog: program. +Variable tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics tprog). +Proof. + (* TODO *) +Admitted. + +End PRESERVATION. \ No newline at end of file diff --git a/driver/Compiler.v b/driver/Compiler.v index 6d398327..49fa2e86 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -38,6 +38,7 @@ Require RTLgen. Require Tailcall. Require Inlining. Require Renumber. +Require Duplicate. Require Constprop. Require CSE. Require Deadcode. @@ -59,6 +60,7 @@ Require RTLgenproof. Require Tailcallproof. Require Inliningproof. Require Renumberproof. +Require Duplicateproof. Require Constpropproof. Require CSEproof. Require Deadcodeproof. @@ -126,16 +128,18 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 2) @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 3) - @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) + @@@ time "Duplicating" Duplicate.transf_program @@ print (print_RTL 4) - @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) + @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 5) - @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) + @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) @@ print (print_RTL 6) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) @@ print (print_RTL 7) - @@@ time "Unused globals" Unusedglob.transform_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 8) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 9) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -238,6 +242,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog ::: mkpass Renumberproof.match_prog + ::: mkpass Duplicateproof.match_prog ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) ::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) @@ -281,17 +286,18 @@ 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 (p9 := Renumber.transf_program p8) in *. - set (p10 := total_if optim_constprop Constprop.transf_program p9) in *. - set (p11 := total_if optim_constprop Renumber.transf_program p10) in *. - destruct (partial_if optim_CSE CSE.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate. - destruct (partial_if optim_redundancy Deadcode.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. - destruct (Unusedglob.transform_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. - destruct (Allocation.transf_program p14) as [p15|e] eqn:P15; simpl in T; try discriminate. - set (p16 := Tunneling.tunnel_program p15) in *. - destruct (Linearize.transf_program p16) as [p17|e] eqn:P17; simpl in T; try discriminate. - set (p18 := CleanupLabels.transf_program p17) in *. - destruct (partial_if debug Debugvar.transf_program p18) as [p19|e] eqn:P19; simpl in T; try discriminate. - destruct (Stacking.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. + destruct (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 *. + destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. + destruct (partial_if optim_redundancy Deadcode.transf_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. + destruct (Unusedglob.transform_program p14) 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. @@ -302,17 +308,18 @@ Proof. 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 p10; split. apply total_if_match. apply Constpropproof.transf_program_match. - exists p11; split. apply total_if_match. apply Renumberproof.transf_program_match. - exists p12; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. - exists p13; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. - exists p14; split. apply Unusedglobproof.transf_program_match; auto. - exists p15; split. apply Allocproof.transf_program_match; auto. - exists p16; split. apply Tunnelingproof.transf_program_match. - exists p17; split. apply Linearizeproof.transf_program_match; auto. - exists p18; split. apply CleanupLabelsproof.transf_program_match; auto. - exists p19; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match. - exists p20; split. apply Stackingproof.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. + exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. + exists p14; split. eapply partial_if_match; eauto. apply Deadcodeproof.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. @@ -364,7 +371,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 p21)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p22)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -383,6 +390,7 @@ Ltac DestructM := eapply compose_forward_simulations. eapply Inliningproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. eapply Duplicateproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. eapply compose_forward_simulations. -- cgit From 6ab78d3c9db7e2d6acea33572a9e1faa598c43b8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Sep 2019 17:58:34 +0200 Subject: Start of match_states --- backend/Duplicateproof.v | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 5cf6b368..a727155e 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -1,7 +1,7 @@ (** Correctness proof for code duplication *) -Require Import AST Linking Errors. -Require Import RTL Globalenvs Smallstep. -Require Import Duplicate. +Require Import AST Linking Errors Globalenvs Smallstep. +Require Import Coqlib. +Require Import RTL Duplicate. Definition match_prog (p tp: program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -20,6 +20,26 @@ Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. +Inductive match_nodes: node -> node -> Prop := + | match_node_intro: forall n, match_nodes n n + (* TODO - fill out the rest *) +. + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + | match_stackframe_intro: + forall res f sp pc rs f' pc' + (TRANSF: transf_function f = OK f') + (DUPLIC: match_nodes pc pc'), + match_stackframes (Stackframe res f sp pc rs) (Stackframe res f' sp pc' rs). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall st f sp pc rs m st' f' pc' + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: transf_function f = OK f') + (DUPLIC: match_nodes pc pc'), + match_states (State st f sp pc rs m) (State st' f' sp pc' rs m). + Theorem transf_program_correct: forward_simulation (RTL.semantics prog) (RTL.semantics tprog). Proof. -- cgit From 853d2e0ef514281f6e6459212dc2142d5d3a90a0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Sep 2019 18:19:55 +0200 Subject: Duplicate: match_nodes --- backend/Duplicateproof.v | 65 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 57 insertions(+), 8 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index a727155e..65c07b45 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -1,6 +1,6 @@ (** Correctness proof for code duplication *) Require Import AST Linking Errors Globalenvs Smallstep. -Require Import Coqlib. +Require Import Coqlib Maps. Require Import RTL Duplicate. Definition match_prog (p tp: program) := @@ -20,16 +20,64 @@ Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Inductive match_nodes: node -> node -> Prop := - | match_node_intro: forall n, match_nodes n n - (* TODO - fill out the rest *) +Inductive match_nodes (f: function): node -> node -> Prop := + | match_node_intro: forall n, match_nodes f n n + | match_node_nop: forall n n' n1 n1', + (fn_code f)!n = Some (Inop n1) -> + (fn_code f)!n' = Some (Inop n1') -> + match_nodes f n1 n1' -> + match_nodes f n n' + | match_node_op: forall n n' n1 n1' op lr r, + (fn_code f)!n = Some (Iop op lr r n1) -> + (fn_code f)!n' = Some (Iop op lr r n1') -> + match_nodes f n1 n1' -> + match_nodes f n n' + | match_node_load: forall n n' n1 n1' m a lr r, + (fn_code f)!n = Some (Iload m a lr r n1) -> + (fn_code f)!n' = Some (Iload m a lr r n1') -> + match_nodes f n1 n1' -> + match_nodes f n n' + | match_node_store: forall n n' n1 n1' m a lr r, + (fn_code f)!n = Some (Istore m a lr r n1) -> + (fn_code f)!n' = Some (Istore m a lr r n1') -> + match_nodes f n1 n1' -> + match_nodes f n n' + | match_node_call: forall n n' n1 n1' s ri lr r, + (fn_code f)!n = Some (Icall s ri lr r n1) -> + (fn_code f)!n' = Some (Icall s ri lr r n1') -> + match_nodes f n1 n1' -> + match_nodes f n n' + | match_node_tailcall: forall n n' s ri lr, + (fn_code f)!n = Some (Itailcall s ri lr) -> + (fn_code f)!n' = Some (Itailcall s ri lr) -> + match_nodes f n n' + | match_node_builtin: forall n n' n1 n1' ef la br, + (fn_code f)!n = Some (Ibuiltin ef la br n1) -> + (fn_code f)!n' = Some (Ibuiltin ef la br n1') -> + match_nodes f n1 n1' -> + match_nodes f n n' + | match_node_cond: forall n n' n1 n1' n2 n2' c lr, + (fn_code f)!n = Some (Icond c lr n1 n2) -> + (fn_code f)!n' = Some (Icond c lr n1' n2') -> + match_nodes f n1 n1' -> + match_nodes f n2 n2' -> + match_nodes f n n' + | match_node_jumptable: forall n n' ln ln' r, + (fn_code f)!n = Some (Ijumptable r ln) -> + (fn_code f)!n' = Some (Ijumptable r ln') -> + list_forall2 (match_nodes f) ln ln' -> + match_nodes f n n' + | match_node_return: forall n n' or, + (fn_code f)!n = Some (Ireturn or) -> + (fn_code f)!n = Some (Ireturn or) -> + match_nodes f n n' . Inductive match_stackframes: stackframe -> stackframe -> Prop := | match_stackframe_intro: forall res f sp pc rs f' pc' (TRANSF: transf_function f = OK f') - (DUPLIC: match_nodes pc pc'), + (DUPLIC: match_nodes f pc pc'), match_stackframes (Stackframe res f sp pc rs) (Stackframe res f' sp pc' rs). Inductive match_states: state -> state -> Prop := @@ -37,8 +85,9 @@ Inductive match_states: state -> state -> Prop := forall st f sp pc rs m st' f' pc' (STACKS: list_forall2 match_stackframes st st') (TRANSF: transf_function f = OK f') - (DUPLIC: match_nodes pc pc'), - match_states (State st f sp pc rs m) (State st' f' sp pc' rs m). + (DUPLIC: match_nodes f pc pc'), + match_states (State st f sp pc rs m) (State st' f' sp pc' rs m) + (* TODO - fill the rest *). Theorem transf_program_correct: forward_simulation (RTL.semantics prog) (RTL.semantics tprog). @@ -46,4 +95,4 @@ Proof. (* TODO *) Admitted. -End PRESERVATION. \ No newline at end of file +End PRESERVATION. -- cgit From 98004b386dcc3e57e6a939a33fb7db903910d02d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Sep 2019 18:24:18 +0200 Subject: Duplicate: match_states --- backend/Duplicateproof.v | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 65c07b45..264b7dff 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -84,10 +84,18 @@ Inductive match_states: state -> state -> Prop := | match_states_intro: forall st f sp pc rs m st' f' pc' (STACKS: list_forall2 match_stackframes st st') - (TRANSF: transf_function f = OK f') + (TRANSL: transf_function f = OK f') (DUPLIC: match_nodes f pc pc'), match_states (State st f sp pc rs m) (State st' f' sp pc' rs m) - (* TODO - fill the rest *). + | match_states_call: + forall st st' f f' args m + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: transf_fundef f = OK f'), + match_states (Callstate st f args m) (Callstate st' f' args m) + | match_states_return: + forall st st' v m + (STACKS: list_forall2 match_stackframes st st'), + match_states (Returnstate st v m) (Returnstate st' v m). Theorem transf_program_correct: forward_simulation (RTL.semantics prog) (RTL.semantics tprog). -- cgit From 5177f34535a70e4335dbab3a66c916c976405df7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 18:27:40 +0200 Subject: Value analysis for non trapping loads --- backend/RTLtyping.v | 14 ++++++++++++++ backend/ValueAnalysis.v | 28 ++++++++++++++++++++++++---- mppa_k1c/ValueAOp.v | 20 ++++++++++++++++++++ 3 files changed, 58 insertions(+), 4 deletions(-) diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 6d27df28..74bfa582 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -851,6 +851,16 @@ Proof. eapply wt_regset_assign; eauto. rewrite H9; eapply Mem.load_type; eauto. Qed. +Lemma wt_exec_Iload_notrap: + forall env f chunk addr args dst s rs, + wt_instr f env (Iload NOTRAP chunk addr args dst s) -> + wt_regset env rs -> + wt_regset env (rs#dst <- (default_notrap_load_value chunk)). +Proof. + intros. + eapply wt_regset_assign; eauto. simpl. trivial. +Qed. + Lemma wt_exec_Ibuiltin: forall env f ef (ge: genv) args res s vargs m t vres m' rs, wt_instr f env (Ibuiltin ef args res s) -> @@ -930,6 +940,10 @@ Proof. econstructor; eauto. eapply wt_exec_Iop; eauto. (* Iload *) econstructor; eauto. eapply wt_exec_Iload; eauto. + (* Iload notrap1*) + econstructor; eauto. eapply wt_exec_Iload_notrap; eauto. + (* Iload notrap2*) + econstructor; eauto. eapply wt_exec_Iload_notrap; eauto. (* Istore *) econstructor; eauto. (* Icall *) diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 5072448a..21dd2c35 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -139,9 +139,11 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : | Some(Iop op args res s) => let a := eval_static_operation op (aregs ae args) in VA.State (AE.set res a ae) am - | Some(Iload trap chunk addr args dst s) => + | Some(Iload TRAP chunk addr args dst s) => let a := loadv chunk rm am (eval_static_addressing addr (aregs ae args)) in VA.State (AE.set dst a ae) am + | Some(Iload NOTRAP chunk addr args dst s) => + VA.State (AE.set dst Vtop ae) am | Some(Istore chunk addr args src s) => let am' := storev chunk am (eval_static_addressing addr (aregs ae args)) (areg ae src) in VA.State ae am' @@ -1268,11 +1270,29 @@ Proof. apply ematch_update; auto. eapply eval_static_operation_sound; eauto with va. - (* load *) + destruct trap. + + eapply sound_succ_state; eauto. simpl; auto. + unfold transfer; rewrite H. eauto. + apply ematch_update; auto. eapply loadv_sound; eauto with va. + eapply eval_static_addressing_sound; eauto with va. + + eapply sound_succ_state; eauto. simpl; auto. + unfold transfer; rewrite H. eauto. + apply ematch_update; auto. + eapply vmatch_top. + eapply loadv_sound; try eassumption. + eapply eval_static_addressing_sound; eauto with va. +- (* load notrap1 *) eapply sound_succ_state; eauto. simpl; auto. unfold transfer; rewrite H. eauto. - apply ematch_update; auto. eapply loadv_sound; eauto with va. - eapply eval_static_addressing_sound; eauto with va. - + apply ematch_update; auto. + unfold default_notrap_load_value. + constructor. +- (* load notrap2 *) + eapply sound_succ_state; eauto. simpl; auto. + unfold transfer; rewrite H. eauto. + apply ematch_update; auto. + unfold default_notrap_load_value. + constructor. - (* store *) exploit eval_static_addressing_sound; eauto with va. intros VMADDR. eapply sound_succ_state; eauto. simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 2c9bdf3e..5e9eb455 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -472,6 +472,26 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. +(* not needed +Theorem eval_static_addressing_sound_none: + forall addr vargs aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> + list_forall2 (vmatch bc) vargs aargs -> + (eval_static_addressing addr aargs) = Vbot. +Proof. + unfold eval_addressing, eval_static_addressing. + intros until aargs. intros Heval_none Hlist. + inv Hlist. + destruct addr; trivial; discriminate. + inv H0. + destruct addr; trivial; discriminate. + inv H2. + destruct addr; trivial; discriminate. + inv H3; + destruct addr; trivial; discriminate. +Qed. + *) + Theorem eval_static_operation_sound: forall op vargs m vres aargs, eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> -- cgit From dbdc40aede7a71596ee2412289df0169215d26d1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 20:12:42 +0200 Subject: advancing in constant propagation --- backend/Constprop.v | 4 ++-- backend/Constpropproof.v | 20 ++++++++++++++++++++ 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/backend/Constprop.v b/backend/Constprop.v index cf1a9171..eda41b39 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -181,7 +181,7 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) let (op', args') := op_strength_reduction op args aargs in Iop op' args' res s' end - | Iload trap chunk addr args dst s => + | Iload TRAP chunk addr args dst s => let aargs := aregs ae args in let a := ValueDomain.loadv chunk rm am (eval_static_addressing addr aargs) in match const_for_result a with @@ -189,7 +189,7 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) Iop cop nil dst s | None => let (addr', args') := addr_strength_reduction addr args aargs in - Iload trap chunk addr' args' dst s + Iload TRAP chunk addr' args' dst s end | Istore chunk addr args src s => let aargs := aregs ae args in diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index a5d08a0f..eb1faa2d 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -406,6 +406,8 @@ Proof. assert (VM1: vmatch bc a aa) by (eapply eval_static_addressing_sound; eauto with va). set (av := loadv chunk (romem_for cu) am aa). assert (VM2: vmatch bc v av) by (eapply loadv_sound; eauto). + destruct trap. + { destruct (const_for_result av) as [cop|] eqn:?; intros. + (* constant-propagated *) exploit const_for_result_correct; eauto. intros (v' & A & B). @@ -431,7 +433,25 @@ Proof. left; econstructor; econstructor; split. eapply exec_Iload; eauto. eapply match_states_succ; eauto. apply set_reg_lessdef; auto. + } + { + assert (exists v2 : val, + eval_addressing ge (Vptr sp0 Ptrofs.zero) addr (rs' ## args) = Some v2 /\ Val.lessdef a v2) as Hexist2. + apply eval_addressing_lessdef with (vl1 := rs ## args). + apply regs_lessdef_regs; assumption. + assumption. + destruct Hexist2 as [v2 [Heval2 Hlessdef2]]. + destruct (Mem.loadv_extends chunk m m' a v2 v MEM H1 Hlessdef2) as [vX [Hvx1 Hvx2]]. + left; econstructor; econstructor; split. + eapply exec_Iload with (a := v2); eauto. + erewrite eval_addressing_preserved with (ge1:=ge); auto. + exact symbols_preserved. + eapply match_states_succ; eauto. apply set_reg_lessdef; auto. + + } +- (* Iload notrap2 *) + (* TODO *) - (* Istore *) rename pc'0 into pc. TransfInstr. assert (ADDR: -- cgit From 11fbb6994667de03623640842d08f1b5ee02aac1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 21:19:07 +0200 Subject: finished Constopproof for non trapping loads --- backend/Constpropproof.v | 42 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index eb1faa2d..eb4b6f17 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -450,8 +450,48 @@ Proof. } +- (* Iload notrap1 *) + rename pc'0 into pc. TransfInstr. + assert (eval_static_addressing addr (aregs ae args) = Vbot) as Hbot by (eapply eval_static_addressing_sound_none; eauto with va). + assert (eval_addressing tge (Vptr sp0 Ptrofs.zero) addr rs' ## args = None) as Hnone. + rewrite eval_addressing_preserved with (ge1 := ge). + apply eval_addressing_lessdef_none with (vl1 := rs ## args). + apply regs_lessdef_regs; assumption. + assumption. + exact symbols_preserved. + + left; econstructor; econstructor; split. + eapply exec_Iload_notrap1; eauto. + eapply match_states_succ; eauto. apply set_reg_lessdef; auto. + - (* Iload notrap2 *) - (* TODO *) + rename pc'0 into pc. TransfInstr. + assert (exists v2 : val, + eval_addressing ge (Vptr sp0 Ptrofs.zero) addr (rs' ## args) = Some v2 /\ Val.lessdef a v2) as Hexist2. + apply eval_addressing_lessdef with (vl1 := rs ## args). + apply regs_lessdef_regs; assumption. + assumption. + destruct Hexist2 as [a' [Heval' Hlessdef']]. + destruct (Mem.loadv chunk m' a') eqn:Hload'. + { + left; econstructor; econstructor; split. + eapply exec_Iload; eauto. + + rewrite eval_addressing_preserved with (ge1 := ge). + exact Heval'. + exact symbols_preserved. + eapply match_states_succ; eauto. apply set_reg_lessdef; auto. + } + { + left; econstructor; econstructor; split. + eapply exec_Iload_notrap2; eauto. + + rewrite eval_addressing_preserved with (ge1 := ge). + exact Heval'. + exact symbols_preserved. + eapply match_states_succ; eauto. apply set_reg_lessdef; auto. + } + - (* Istore *) rename pc'0 into pc. TransfInstr. assert (ADDR: -- cgit From e8676a19cf20cf65eb3c57b6621919d3d7ffc065 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 21:22:13 +0200 Subject: forgot this function --- mppa_k1c/ValueAOp.v | 2 -- 1 file changed, 2 deletions(-) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 5e9eb455..7d84447e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -472,7 +472,6 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. -(* not needed Theorem eval_static_addressing_sound_none: forall addr vargs aargs, eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> @@ -490,7 +489,6 @@ Proof. inv H3; destruct addr; trivial; discriminate. Qed. - *) Theorem eval_static_operation_sound: forall op vargs m vres aargs, -- cgit From 2fe044ba1dbaa3fce00a221d988e06c6907cfaf2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 22:02:38 +0200 Subject: Dead code proof for non trapping loads --- backend/Deadcodeproof.v | 77 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index 2edc0395..6919fe78 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -829,6 +829,83 @@ Ltac UseTransfer := apply eagree_update; eauto 2 with na. eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto. +- (* load notrap1 *) + TransfInstr; UseTransfer. + destruct (is_dead (nreg ne dst)) eqn:DEAD; + [idtac|destruct (is_int_zero (nreg ne dst)) eqn:INTZERO]; + simpl in *. ++ (* dead instruction, turned into a nop *) + econstructor; split. + eapply exec_Inop; eauto. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_update_dead; auto with na. ++ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *) + econstructor; split. + eapply exec_Iop with (v := Vint Int.zero); eauto. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_update; auto. + rewrite is_int_zero_sound by auto. + unfold default_notrap_load_value. + constructor. ++ (* preserved *) + exploit eval_addressing_lessdef_none. eapply add_needs_all_lessdef; eauto. eassumption. + intro Hnone'. + assert (eval_addressing tge (Vptr sp0 Ptrofs.zero) addr te ## args = None) as Hnone2'. + erewrite eval_addressing_preserved with (ge1 := ge). + assumption. + exact symbols_preserved. + + econstructor; split. + eapply exec_Iload_notrap1; eauto. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_update; eauto 2 with na. + eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto. + +- (* load notrap2 *) + TransfInstr; UseTransfer. + + destruct (is_dead (nreg ne dst)) eqn:DEAD; + [idtac|destruct (is_int_zero (nreg ne dst)) eqn:INTZERO]; + simpl in *. ++ (* dead instruction, turned into a nop *) + econstructor; split. + eapply exec_Inop; eauto. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_update_dead; auto with na. ++ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *) + econstructor; split. + eapply exec_Iop with (v := Vint Int.zero); eauto. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_update; auto. + rewrite is_int_zero_sound by auto. + unfold default_notrap_load_value. + constructor. ++ (* preserved *) + exploit eval_addressing_lessdef. eapply add_needs_all_lessdef; eauto. eauto. + intros (ta & U & V). + destruct (Mem.loadv chunk tm ta) eqn:Hchunk2. + { + econstructor; split. + eapply exec_Iload. eauto. + erewrite eval_addressing_preserved with (ge1 := ge). + eassumption. + exact symbols_preserved. + eassumption. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_update; eauto 2 with na. + eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto. + } + { + econstructor; split. + eapply exec_Iload_notrap2. eauto. + erewrite eval_addressing_preserved with (ge1 := ge). + eassumption. + exact symbols_preserved. + eassumption. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_update; eauto 2 with na. + eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto. + } - (* store *) TransfInstr; UseTransfer. destruct (nmem_contains nm (aaddressing (vanalyze cu f) # pc addr args) -- cgit From 1d90fa730df7d1cb2ee726d3b41b9915ae4e4e2e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 23:02:06 +0200 Subject: moved trapping_mode to a more appropriate place --- backend/RTL.v | 2 -- common/AST.v | 9 +++++++++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/backend/RTL.v b/backend/RTL.v index d09cca77..95fa1f82 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -36,8 +36,6 @@ Require Import Op Registers. Definition node := positive. -Inductive trapping_mode : Type := TRAP | NOTRAP. - Inductive instruction: Type := | Inop: node -> instruction (** No operation -- just branch to the successor. *) diff --git a/common/AST.v b/common/AST.v index a91138c9..d98f954a 100644 --- a/common/AST.v +++ b/common/AST.v @@ -193,6 +193,15 @@ Definition chunk_of_type (ty: typ) := Lemma chunk_of_Tptr: chunk_of_type Tptr = Mptr. Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed. +(** Trapping mode: does undefined behavior result in a trap or an undefined value (e.g. for loads) *) +Inductive trapping_mode : Type := TRAP | NOTRAP. + +Definition trapping_mode_eq : forall x y : trapping_mode, + { x=y } + { x <> y}. +Proof. + decide equality. +Defined. + (** Initialization data for global variables. *) Inductive init_data: Type := -- cgit From 686f0aaff7a4c37e13bfbe823b4dd2a879556f0a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 4 Sep 2019 06:55:27 +0200 Subject: begin CSE --- backend/CSE.v | 18 +++++++++--------- backend/CSEdomain.v | 10 +++++----- backend/CSEproof.v | 10 ++++++---- backend/ValueAnalysis.v | 3 +++ 4 files changed, 23 insertions(+), 18 deletions(-) diff --git a/backend/CSE.v b/backend/CSE.v index 9da30f50..1c884cf0 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -202,10 +202,10 @@ Definition add_op (n: numbering) (rd: reg) (op: operation) (rs: list reg) := and added to [n] as described in [add_rhs]. *) Definition add_load (n: numbering) (rd: reg) - (chunk: memory_chunk) (addr: addressing) + (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (rs: list reg) := let (n1, vs) := valnum_regs n rs in - add_rhs n1 rd (Load chunk addr vs). + add_rhs n1 rd (Load trap chunk addr vs). (** [set_unknown n rd] returns a numbering where [rd] is mapped to no value number, and no equations are added. This is useful @@ -246,7 +246,7 @@ Definition kill_equations (pred: rhs -> bool) (n: numbering) : numbering := Definition filter_loads (r: rhs) : bool := match r with | Op op _ => op_depends_on_memory op - | Load _ _ _ => true + | Load _ _ _ _ => true end. Definition kill_all_loads (n: numbering) : numbering := @@ -262,7 +262,7 @@ Definition filter_after_store (app: VA.t) (n: numbering) (p: aptr) (sz: Z) (r: r match r with | Op op vl => op_depends_on_memory op - | Load chunk addr vl => + | Load trap chunk addr vl => match regs_valnums n vl with | None => true | Some rl => @@ -297,7 +297,7 @@ Definition add_store_result (app: VA.t) (n: numbering) (chunk: memory_chunk) (ad let (n1, vsrc) := valnum_reg n rsrc in let (n2, vargs) := valnum_regs n1 rargs in {| num_next := n2.(num_next); - num_eqs := Eq vsrc false (Load chunk addr vargs) :: n2.(num_eqs); + num_eqs := Eq vsrc false (Load TRAP chunk addr vargs) :: n2.(num_eqs); num_reg := n2.(num_reg); num_val := n2.(num_val) |} else n. @@ -326,7 +326,7 @@ Definition kill_loads_after_storebytes Definition shift_memcpy_eq (src sz delta: Z) (e: equation) := match e with - | Eq l strict (Load chunk (Ainstack i) _) => + | Eq l strict (Load trap chunk (Ainstack i) _) => let i := Ptrofs.unsigned i in let j := i + delta in if zle src i @@ -334,7 +334,7 @@ Definition shift_memcpy_eq (src sz delta: Z) (e: equation) := && zeq (Z.modulo delta (align_chunk chunk)) 0 && zle 0 j && zle j Ptrofs.max_unsigned - then Some(Eq l strict (Load chunk (Ainstack (Ptrofs.repr j)) nil)) + then Some(Eq l strict (Load trap chunk (Ainstack (Ptrofs.repr j)) nil)) else None | _ => None end. @@ -460,7 +460,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb | Iop op args res s => add_op before res op args | Iload trap chunk addr args dst s => - add_load before dst chunk addr args + add_load before dst trap chunk addr args | Istore chunk addr args src s => let app := approx!!pc in let n := kill_loads_after_store app before chunk addr args in @@ -536,7 +536,7 @@ Definition transf_instr (n: numbering) (instr: instruction) := end | Iload trap chunk addr args dst s => let (n1, vl) := valnum_regs n args in - match find_rhs n1 (Load chunk addr vl) with + match find_rhs n1 (Load trap chunk addr vl) with | Some r => Iop Omove (r :: nil) dst s | None => diff --git a/backend/CSEdomain.v b/backend/CSEdomain.v index 9b1243c8..aa0b9fb1 100644 --- a/backend/CSEdomain.v +++ b/backend/CSEdomain.v @@ -32,7 +32,7 @@ Definition valnum := positive. Inductive rhs : Type := | Op: operation -> list valnum -> rhs - | Load: memory_chunk -> addressing -> list valnum -> rhs. + | Load: trapping_mode -> memory_chunk -> addressing -> list valnum -> rhs. Inductive equation : Type := | Eq (v: valnum) (strict: bool) (r: rhs). @@ -43,7 +43,7 @@ Definition eq_list_valnum: forall (x y: list valnum), {x=y}+{x<>y} := list_eq_de Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}. Proof. - generalize chunk_eq eq_operation eq_addressing eq_valnum eq_list_valnum. + generalize trapping_mode_eq chunk_eq eq_operation eq_addressing eq_valnum eq_list_valnum. decide equality. Defined. @@ -74,7 +74,7 @@ Definition empty_numbering := Definition valnums_rhs (r: rhs): list valnum := match r with | Op op vl => vl - | Load chunk addr vl => vl + | Load trap chunk addr vl => vl end. Definition wf_rhs (next: valnum) (r: rhs) : Prop := @@ -106,10 +106,10 @@ Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem): | op_eval_to: forall op vl v, eval_operation ge sp op (map valu vl) m = Some v -> rhs_eval_to valu ge sp m (Op op vl) v - | load_eval_to: forall chunk addr vl a v, + | load_eval_to: forall trap chunk addr vl a v, eval_addressing ge sp addr (map valu vl) = Some a -> Mem.loadv chunk m a = Some v -> - rhs_eval_to valu ge sp m (Load chunk addr vl) v. + rhs_eval_to valu ge sp m (Load trap chunk addr vl) v. Inductive equation_holds (valu: valuation) (ge: genv) (sp: val) (m: mem): equation -> Prop := diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 03c7ecfc..c0464ab8 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -378,11 +378,11 @@ Proof. Qed. Lemma add_load_holds: - forall valu1 ge sp rs m n addr (args: list reg) a chunk v dst, + forall valu1 ge sp rs m n addr (args: list reg) a trap chunk v dst, numbering_holds valu1 ge sp rs m n -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> - exists valu2, numbering_holds valu2 ge sp (rs#dst <- v) m (add_load n dst chunk addr args). + exists valu2, numbering_holds valu2 ge sp (rs#dst <- v) m (add_load n dst trap chunk addr args). Proof. unfold add_load; intros. destruct (valnum_regs n args) as [n1 vl] eqn:VN. @@ -641,7 +641,7 @@ Lemma shift_memcpy_eq_holds: Proof with (try discriminate). intros. set (delta := dst - src) in *. unfold shift_memcpy_eq in H. destruct e as [l strict rhs] eqn:E. - destruct rhs as [op vl | chunk addr vl]... + destruct rhs as [op vl | trap chunk addr vl]... destruct addr... try (rename i into ofs). set (i1 := Ptrofs.unsigned ofs) in *. set (j := i1 + delta) in *. @@ -1034,7 +1034,7 @@ Proof. destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. destruct SAT as [valu1 NH1]. exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q). - destruct (find_rhs n1 (Load chunk addr vl)) as [r|] eqn:?. + destruct (find_rhs n1 (Load trap chunk addr vl)) as [r|] eqn:?. + (* replaced by move *) exploit find_rhs_sound; eauto. intros (v' & EV & LD). assert (v' = v) by (inv EV; congruence). subst v'. @@ -1064,6 +1064,8 @@ Proof. eapply add_load_holds; eauto. apply set_reg_lessdef; auto. + (* TODO *) + - (* Istore *) destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. destruct SAT as [valu1 NH1]. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 21dd2c35..084a4548 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -142,6 +142,9 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : | Some(Iload TRAP chunk addr args dst s) => let a := loadv chunk rm am (eval_static_addressing addr (aregs ae args)) in VA.State (AE.set dst a ae) am + + (* TODO: maybe a case analysis on the results of loadv? *) + | Some(Iload NOTRAP chunk addr args dst s) => VA.State (AE.set dst Vtop ae) am | Some(Istore chunk addr args src s) => -- cgit From 44f4bea5d16273b834b1bcc8624c8f00aefaf018 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 4 Sep 2019 10:23:03 +0200 Subject: begin CSE proof for notrap load --- backend/CSEproof.v | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 85 insertions(+), 3 deletions(-) diff --git a/backend/CSEproof.v b/backend/CSEproof.v index c0464ab8..def8003c 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -71,7 +71,9 @@ Lemma rhs_eval_to_exten: Proof. intros. inv H; simpl in *. - constructor. rewrite valnums_val_exten by assumption. auto. -- econstructor; eauto. rewrite valnums_val_exten by assumption. auto. +- eapply load_eval_to; eauto. rewrite valnums_val_exten by assumption. auto. +- apply load_notrap1_eval_to; auto. rewrite valnums_val_exten by assumption. assumption. +- eapply load_notrap2_eval_to; eauto. rewrite valnums_val_exten by assumption. assumption. Qed. Lemma equation_holds_exten: @@ -393,6 +395,38 @@ Proof. + intros. apply Regmap.gso; auto. Qed. + +Lemma add_load_holds_none1: + forall valu1 ge sp rs m n addr (args: list reg) chunk dst, + numbering_holds valu1 ge sp rs m n -> + eval_addressing ge sp addr rs##args = None -> + exists valu2, numbering_holds valu2 ge sp (rs#dst <- (default_notrap_load_value chunk)) m (add_load n dst NOTRAP chunk addr args). +Proof. + unfold add_load; intros. + destruct (valnum_regs n args) as [n1 vl] eqn:VN. + exploit valnum_regs_holds; eauto. + intros (valu2 & A & B & C & D & E). + eapply add_rhs_holds; eauto. ++ rewrite Regmap.gss; auto. eapply load_notrap1_eval_to. rewrite <- B; eauto. ++ intros. apply Regmap.gso; auto. +Qed. + +Lemma add_load_holds_none2: + forall valu1 ge sp rs m n addr (args: list reg) a chunk dst, + numbering_holds valu1 ge sp rs m n -> + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = None -> + exists valu2, numbering_holds valu2 ge sp (rs#dst <- (default_notrap_load_value chunk)) m (add_load n dst NOTRAP chunk addr args). +Proof. + unfold add_load; intros. + destruct (valnum_regs n args) as [n1 vl] eqn:VN. + exploit valnum_regs_holds; eauto. + intros (valu2 & A & B & C & D & E). + eapply add_rhs_holds; eauto. ++ rewrite Regmap.gss; auto. eapply load_notrap2_eval_to. rewrite <- B; eauto. assumption. ++ intros. apply Regmap.gso; auto. +Qed. + Lemma set_unknown_holds: forall valu ge sp rs m n r v, numbering_holds valu ge sp rs m n -> @@ -456,8 +490,8 @@ Lemma kill_all_loads_hold: Proof. intros. eapply kill_equations_hold; eauto. unfold filter_loads; intros. inv H1. - constructor. rewrite <- H2. apply op_depends_on_memory_correct; auto. - discriminate. + 1: constructor; rewrite <- H2; apply op_depends_on_memory_correct; auto. + all: discriminate. Qed. Lemma kill_loads_after_store_holds: @@ -486,6 +520,18 @@ Proof. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va. +- eapply load_notrap1_eval_to; assumption. +- destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate. + eapply load_notrap2_eval_to; eauto. + rewrite <- H9. + destruct a; simpl in H1; try discriminate. + destruct a0; simpl in H9; try discriminate; simpl; trivial. + rewrite negb_false_iff in H6. unfold aaddressing in H6. + eapply Mem.load_store_other. eauto. + eapply pdisjoint_sound; eauto. + apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. + erewrite <- regs_valnums_sound by eauto. eauto with va. + apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va. Qed. Lemma store_normalized_range_sound: @@ -562,6 +608,8 @@ Proof. unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. auto. + +(* TODO *) Qed. Lemma load_memcpy: @@ -1064,6 +1112,40 @@ Proof. eapply add_load_holds; eauto. apply set_reg_lessdef; auto. +- (* Iload notrap1 *) + destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. + destruct SAT as [valu1 NH1]. + exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q). + destruct (find_rhs n1 (Load NOTRAP chunk addr vl)) as [r|] eqn:?. ++ (* replaced by move *) + exploit find_rhs_sound; eauto. intros (v' & EV & LD). + assert (v' = Vundef) by (inv EV; congruence). subst v'. + econstructor; split. + eapply exec_Iop; eauto. simpl; eauto. + econstructor; eauto. + eapply analysis_correct_1; eauto. simpl; auto. + unfold transfer; rewrite H. + eapply add_load_holds; eauto. + apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto. ++ (* load is preserved, but addressing is possibly simplified *) + destruct (reduce addressing combine_addr n1 addr args vl) as [addr' args'] eqn:?. + assert (ADDR: eval_addressing ge sp addr' rs##args' = Some a). + { eapply reduce_sound with (sem := fun addr vl => eval_addressing ge sp addr vl); eauto. + intros; eapply combine_addr_sound; eauto. } + exploit eval_addressing_lessdef. apply regs_lessdef_regs; eauto. eexact ADDR. + intros [a' [A B]]. + assert (ADDR': eval_addressing tge sp addr' rs'##args' = Some a'). + { rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. } + exploit Mem.loadv_extends; eauto. + intros [v' [X Y]]. + econstructor; split. + eapply exec_Iload; eauto. + econstructor; eauto. + eapply analysis_correct_1; eauto. simpl; auto. + unfold transfer; rewrite H. + eapply add_load_holds; eauto. + apply set_reg_lessdef; auto. + (* TODO *) - (* Istore *) -- cgit From f91f8296b6d2f663878223d473cd9e887403f73f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Sep 2019 11:21:53 +0200 Subject: transf_initial_states --- backend/Duplicate.v | 23 +++++++++++----- backend/Duplicateaux.ml | 3 ++- backend/Duplicateproof.v | 70 +++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 84 insertions(+), 12 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index cb52ec04..ac67cfe1 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -6,23 +6,32 @@ Require Import Coqlib Errors. Local Open Scope error_monad_scope. -(** External oracle returning the new RTL function, along with a mapping - of new nodes to old nodes *) -Axiom duplicate_aux: RTL.function -> RTL.function * (PTree.t nat). +(** External oracle returning the new RTL code (entry point unchanged), + along with a mapping of new nodes to old nodes *) +Axiom duplicate_aux: RTL.function -> RTL.code * (PTree.t nat). Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux". (** * Verification of node duplications *) (** Verifies that the mapping [mp] is giving correct information *) -Definition verify_mapping (f tf: function) (mp: PTree.t nat) : res unit := OK tt. (* TODO *) +Definition verify_mapping (f: function) (tc: code) (mp: PTree.t nat) : res unit := OK tt. (* TODO *) (** * Entry points *) Definition transf_function (f: function) : res function := - let (tf, mp) := duplicate_aux f in - do u <- verify_mapping f tf mp; - OK tf. + let (tc, mp) := duplicate_aux f in + do u <- verify_mapping f tc mp; + OK (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc (fn_entrypoint f)). + +Theorem transf_function_preserves: + forall f tf, + transf_function f = OK tf -> + fn_sig f = fn_sig tf /\ fn_params f = fn_params tf /\ fn_stacksize f = fn_stacksize tf /\ fn_entrypoint f = fn_entrypoint tf. +Proof. + intros. unfold transf_function in H. destruct (duplicate_aux _) as (tc & mp). monadInv H. + repeat (split; try reflexivity). +Qed. Definition transf_fundef (f: fundef) : res fundef := transf_partial_fundef transf_function f. diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 8a57f364..621a2dbe 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,3 +1,4 @@ +open RTL open Maps -let duplicate_aux f = (f, PTree.empty) +let duplicate_aux f = ((fn_code f), PTree.empty) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 264b7dff..b30c2c14 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -20,6 +20,31 @@ Hypothesis TRANSL: 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 TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match 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 sig_preserved: + forall f tf, + transf_fundef f = OK tf -> + funsig tf = funsig f. +Proof. + unfold transf_fundef, transf_partial_fundef; intros. + destruct f. monadInv H. simpl. symmetry; apply transf_function_preserves. assumption. + inv H. reflexivity. +Qed. + Inductive match_nodes (f: function): node -> node -> Prop := | match_node_intro: forall n, match_nodes f n n | match_node_nop: forall n n' n1 n1', @@ -84,7 +109,7 @@ Inductive match_states: state -> state -> Prop := | match_states_intro: forall st f sp pc rs m st' f' pc' (STACKS: list_forall2 match_stackframes st st') - (TRANSL: transf_function f = OK f') + (TRANSF: transf_function f = OK f') (DUPLIC: match_nodes f pc pc'), match_states (State st f sp pc rs m) (State st' f' sp pc' rs m) | match_states_call: @@ -97,10 +122,47 @@ Inductive match_states: state -> state -> Prop := (STACKS: list_forall2 match_stackframes st st'), match_states (Returnstate st v m) (Returnstate st' v m). -Theorem transf_program_correct: - forward_simulation (RTL.semantics prog) (RTL.semantics tprog). +Theorem transf_initial_states: + forall s1, initial_state prog s1 -> + exists s2, initial_state tprog s2 /\ match_states s1 s2. +Proof. + intros. inv H. + exploit function_ptr_translated; eauto. intros (tf & FIND & TRANSF). + eexists. split. + - econstructor. + + eapply (Genv.init_mem_transf_partial TRANSL); eauto. + + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. + symmetry. eapply match_program_main. eauto. + + exploit function_ptr_translated; eauto. + + destruct f. + * monadInv TRANSF. rewrite <- H3. symmetry; eapply transf_function_preserves. assumption. + * monadInv TRANSF. assumption. + - constructor; eauto. constructor. +Qed. + +Theorem transf_final_states: + forall s1 s2 r, + match_states s1 s2 -> final_state s1 r -> final_state s2 r. +Proof. +Admitted. + +Theorem step_simulation: + forall s1 t s1', step ge s1 t s1' -> + forall s2, match_states s1 s2 -> + exists s2', + step tge s2 t s2' + /\ match_states s1' s2'. Proof. - (* TODO *) Admitted. +Theorem transf_program_correct: + forward_simulation (semantics prog) (semantics tprog). +Proof. + eapply forward_simulation_step with match_states. + - eapply senv_preserved. + - eapply transf_initial_states. + - eapply transf_final_states. + - eapply step_simulation. +Qed. + End PRESERVATION. -- cgit From 4a5f1db8abe7831649f6f15178958e0c57955a25 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Sep 2019 11:49:32 +0200 Subject: Duplicate: exec_function_internal --- backend/Duplicate.v | 9 +++++++++ backend/Duplicateproof.v | 36 ++++++++++++++++++++++++++++++++++-- 2 files changed, 43 insertions(+), 2 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index ac67cfe1..8a78ee80 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -33,6 +33,15 @@ Proof. repeat (split; try reflexivity). Qed. +Remark transf_function_fnsig: forall f tf, transf_function f = OK tf -> fn_sig f = fn_sig tf. + Proof. apply transf_function_preserves. Qed. +Remark transf_function_fnparams: forall f tf, transf_function f = OK tf -> fn_params f = fn_params tf. + Proof. apply transf_function_preserves. Qed. +Remark transf_function_fnstacksize: forall f tf, transf_function f = OK tf -> fn_stacksize f = fn_stacksize tf. + Proof. apply transf_function_preserves. Qed. +Remark transf_function_fnentrypoint: forall f tf, transf_function f = OK tf -> fn_entrypoint f = fn_entrypoint tf. + Proof. apply transf_function_preserves. Qed. + Definition transf_fundef (f: fundef) : res fundef := transf_partial_fundef transf_function f. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index b30c2c14..69fc41ae 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -144,15 +144,47 @@ Theorem transf_final_states: forall s1 s2 r, match_states s1 s2 -> final_state s1 r -> final_state s2 r. Proof. -Admitted. + intros. inv H0. inv H. inv STACKS. constructor. +Qed. Theorem step_simulation: forall s1 t s1', step ge s1 t s1' -> - forall s2, match_states s1 s2 -> + forall s2 (MS: match_states s1 s2), exists s2', step tge s2 t s2' /\ match_states s1' s2'. Proof. + induction 1; intros; inv MS. +(* Inop *) + - admit. +(* Iop *) + - admit. +(* Iload *) + - admit. +(* Istore *) + - admit. +(* Icall *) + - admit. +(* Itailcall *) + - admit. +(* Ibuiltin *) + - admit. +(* Icond *) + - admit. +(* Ijumptable *) + - admit. +(* Ireturn *) + - admit. +(* exec_function_internal *) + - monadInv TRANSF. eexists. split. + + econstructor. erewrite <- transf_function_fnstacksize; eauto. + + erewrite transf_function_fnentrypoint; eauto. + erewrite transf_function_fnparams; eauto. + econstructor; eauto. constructor. +(* exec_function_external *) + - admit. +(* exec_return *) + - admit. Admitted. Theorem transf_program_correct: -- cgit From f06898fc9711736b3b2e373941d762f90d8fa253 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Sep 2019 12:05:59 +0200 Subject: Duplicate: exec_function_external et exec_return --- backend/Duplicateproof.v | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 69fc41ae..40e7493d 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -1,6 +1,6 @@ (** Correctness proof for code duplication *) Require Import AST Linking Errors Globalenvs Smallstep. -Require Import Coqlib Maps. +Require Import Coqlib Maps Events. Require Import RTL Duplicate. Definition match_prog (p tp: program) := @@ -182,9 +182,13 @@ Proof. erewrite transf_function_fnparams; eauto. econstructor; eauto. constructor. (* exec_function_external *) - - admit. + - monadInv TRANSF. eexists. split. + + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + constructor. assumption. (* exec_return *) - - admit. + - inv STACKS. destruct b1 as [res' f' sp' pc' rs']. eexists. split. + + constructor. + + inv H1. constructor; assumption. Admitted. Theorem transf_program_correct: -- cgit From 9cc45ec4201247d08ac47d5b668ee2ddd0ff9984 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Sep 2019 16:49:03 +0200 Subject: Duplicate: changement de match_nodes --- backend/Duplicateproof.v | 80 ++++++++++++++++++++++++++---------------------- 1 file changed, 44 insertions(+), 36 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 40e7493d..77a6a954 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -45,64 +45,63 @@ Proof. inv H. reflexivity. Qed. -Inductive match_nodes (f: function): node -> node -> Prop := - | match_node_intro: forall n, match_nodes f n n +Inductive match_nodes (f f': function): node -> node -> Prop := | match_node_nop: forall n n' n1 n1', (fn_code f)!n = Some (Inop n1) -> - (fn_code f)!n' = Some (Inop n1') -> - match_nodes f n1 n1' -> - match_nodes f n n' + (fn_code f')!n' = Some (Inop n1') -> + match_nodes f f' n1 n1' -> + match_nodes f f' n n' | match_node_op: forall n n' n1 n1' op lr r, (fn_code f)!n = Some (Iop op lr r n1) -> - (fn_code f)!n' = Some (Iop op lr r n1') -> - match_nodes f n1 n1' -> - match_nodes f n n' + (fn_code f')!n' = Some (Iop op lr r n1') -> + match_nodes f f' n1 n1' -> + match_nodes f f' n n' | match_node_load: forall n n' n1 n1' m a lr r, (fn_code f)!n = Some (Iload m a lr r n1) -> - (fn_code f)!n' = Some (Iload m a lr r n1') -> - match_nodes f n1 n1' -> - match_nodes f n n' + (fn_code f')!n' = Some (Iload m a lr r n1') -> + match_nodes f f' n1 n1' -> + match_nodes f f' n n' | match_node_store: forall n n' n1 n1' m a lr r, (fn_code f)!n = Some (Istore m a lr r n1) -> - (fn_code f)!n' = Some (Istore m a lr r n1') -> - match_nodes f n1 n1' -> - match_nodes f n n' + (fn_code f')!n' = Some (Istore m a lr r n1') -> + match_nodes f f' n1 n1' -> + match_nodes f f' n n' | match_node_call: forall n n' n1 n1' s ri lr r, (fn_code f)!n = Some (Icall s ri lr r n1) -> - (fn_code f)!n' = Some (Icall s ri lr r n1') -> - match_nodes f n1 n1' -> - match_nodes f n n' + (fn_code f')!n' = Some (Icall s ri lr r n1') -> + match_nodes f f' n1 n1' -> + match_nodes f f' n n' | match_node_tailcall: forall n n' s ri lr, (fn_code f)!n = Some (Itailcall s ri lr) -> - (fn_code f)!n' = Some (Itailcall s ri lr) -> - match_nodes f n n' + (fn_code f')!n' = Some (Itailcall s ri lr) -> + match_nodes f f' n n' | match_node_builtin: forall n n' n1 n1' ef la br, (fn_code f)!n = Some (Ibuiltin ef la br n1) -> - (fn_code f)!n' = Some (Ibuiltin ef la br n1') -> - match_nodes f n1 n1' -> - match_nodes f n n' + (fn_code f')!n' = Some (Ibuiltin ef la br n1') -> + match_nodes f f' n1 n1' -> + match_nodes f f' n n' | match_node_cond: forall n n' n1 n1' n2 n2' c lr, (fn_code f)!n = Some (Icond c lr n1 n2) -> - (fn_code f)!n' = Some (Icond c lr n1' n2') -> - match_nodes f n1 n1' -> - match_nodes f n2 n2' -> - match_nodes f n n' + (fn_code f')!n' = Some (Icond c lr n1' n2') -> + match_nodes f f' n1 n1' -> + match_nodes f f' n2 n2' -> + match_nodes f f' n n' | match_node_jumptable: forall n n' ln ln' r, (fn_code f)!n = Some (Ijumptable r ln) -> - (fn_code f)!n' = Some (Ijumptable r ln') -> - list_forall2 (match_nodes f) ln ln' -> - match_nodes f n n' + (fn_code f')!n' = Some (Ijumptable r ln') -> + list_forall2 (match_nodes f f') ln ln' -> + match_nodes f f' n n' | match_node_return: forall n n' or, (fn_code f)!n = Some (Ireturn or) -> - (fn_code f)!n = Some (Ireturn or) -> - match_nodes f n n' + (fn_code f')!n = Some (Ireturn or) -> + match_nodes f f' n n' . Inductive match_stackframes: stackframe -> stackframe -> Prop := | match_stackframe_intro: forall res f sp pc rs f' pc' (TRANSF: transf_function f = OK f') - (DUPLIC: match_nodes f pc pc'), + (DUPLIC: match_nodes f f' pc pc'), match_stackframes (Stackframe res f sp pc rs) (Stackframe res f' sp pc' rs). Inductive match_states: state -> state -> Prop := @@ -110,7 +109,7 @@ Inductive match_states: state -> state -> Prop := forall st f sp pc rs m st' f' pc' (STACKS: list_forall2 match_stackframes st st') (TRANSF: transf_function f = OK f') - (DUPLIC: match_nodes f pc pc'), + (DUPLIC: match_nodes f f' pc pc'), match_states (State st f sp pc rs m) (State st' f' sp pc' rs m) | match_states_call: forall st st' f f' args m @@ -156,9 +155,17 @@ Theorem step_simulation: Proof. induction 1; intros; inv MS. (* Inop *) - - admit. + - inv DUPLIC; try (rewrite H0 in H; discriminate). + rewrite H0 in H. inv H. + eexists. split. + + eapply exec_Inop. eassumption. + + constructor; eauto. (* Iop *) - - admit. + - admit. (* inv DUPLIC; try (rewrite H1 in H; discriminate). + rewrite H1 in H. inv H. + eexists. split. + + eapply exec_Iop. eassumption. + + constructor; eauto. *) (* Iload *) - admit. (* Istore *) @@ -180,7 +187,7 @@ Proof. + econstructor. erewrite <- transf_function_fnstacksize; eauto. + erewrite transf_function_fnentrypoint; eauto. erewrite transf_function_fnparams; eauto. - econstructor; eauto. constructor. + econstructor; eauto. admit. (* econstructor. *) (* exec_function_external *) - monadInv TRANSF. eexists. split. + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. @@ -191,6 +198,7 @@ Proof. + inv H1. constructor; assumption. Admitted. + Theorem transf_program_correct: forward_simulation (semantics prog) (semantics tprog). Proof. -- cgit From 55a90812e9f6f65b4abe7a124e933875f212238c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 4 Sep 2019 18:44:23 +0200 Subject: ca avance --- backend/CSEproof.v | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/backend/CSEproof.v b/backend/CSEproof.v index def8003c..108aef31 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -608,8 +608,17 @@ Proof. unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. auto. - -(* TODO *) +- eapply load_notrap1_eval_to; assumption. +- destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate. + eapply load_notrap2_eval_to; eauto. rewrite <- H11. + destruct a; simpl in H10; try discriminate; simpl; trivial. + rewrite negb_false_iff in H8. + eapply Mem.load_storebytes_other. eauto. + rewrite H6. rewrite Z2Nat.id by omega. + eapply pdisjoint_sound. eauto. + unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. + erewrite <- regs_valnums_sound by eauto. eauto with va. + auto. Qed. Lemma load_memcpy: -- cgit From fcb50cc5284a006bde4eda21431dc811412cf819 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 4 Sep 2019 19:46:40 +0200 Subject: stuck in CSEproof --- backend/CSEdomain.v | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/backend/CSEdomain.v b/backend/CSEdomain.v index aa0b9fb1..26d9c481 100644 --- a/backend/CSEdomain.v +++ b/backend/CSEdomain.v @@ -109,7 +109,16 @@ Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem): | load_eval_to: forall trap chunk addr vl a v, eval_addressing ge sp addr (map valu vl) = Some a -> Mem.loadv chunk m a = Some v -> - rhs_eval_to valu ge sp m (Load trap chunk addr vl) v. + rhs_eval_to valu ge sp m (Load trap chunk addr vl) v + | load_notrap1_eval_to: forall chunk addr vl, + eval_addressing ge sp addr (map valu vl) = None -> + rhs_eval_to valu ge sp m (Load NOTRAP chunk addr vl) + (default_notrap_load_value chunk) + | load_notrap2_eval_to: forall chunk addr vl a, + eval_addressing ge sp addr (map valu vl) = Some a -> + Mem.loadv chunk m a = None -> + rhs_eval_to valu ge sp m (Load NOTRAP chunk addr vl) + (default_notrap_load_value chunk). Inductive equation_holds (valu: valuation) (ge: genv) (sp: val) (m: mem): equation -> Prop := -- cgit From e188b6c4a1c43fb83157670e1c28db5798f50f0b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 4 Sep 2019 22:58:55 +0200 Subject: going forward --- backend/CSEproof.v | 91 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 50 insertions(+), 41 deletions(-) diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 108aef31..50eb4637 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -72,8 +72,10 @@ Proof. intros. inv H; simpl in *. - constructor. rewrite valnums_val_exten by assumption. auto. - eapply load_eval_to; eauto. rewrite valnums_val_exten by assumption. auto. +(* - apply load_notrap1_eval_to; auto. rewrite valnums_val_exten by assumption. assumption. - eapply load_notrap2_eval_to; eauto. rewrite valnums_val_exten by assumption. assumption. +*) Qed. Lemma equation_holds_exten: @@ -380,11 +382,11 @@ Proof. Qed. Lemma add_load_holds: - forall valu1 ge sp rs m n addr (args: list reg) a trap chunk v dst, + forall valu1 ge sp rs m n addr (args: list reg) a chunk v dst, numbering_holds valu1 ge sp rs m n -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> - exists valu2, numbering_holds valu2 ge sp (rs#dst <- v) m (add_load n dst trap chunk addr args). + exists valu2, numbering_holds valu2 ge sp (rs#dst <- v) m (add_load n dst chunk addr args). Proof. unfold add_load; intros. destruct (valnum_regs n args) as [n1 vl] eqn:VN. @@ -395,12 +397,12 @@ Proof. + intros. apply Regmap.gso; auto. Qed. - +(* Lemma add_load_holds_none1: forall valu1 ge sp rs m n addr (args: list reg) chunk dst, numbering_holds valu1 ge sp rs m n -> eval_addressing ge sp addr rs##args = None -> - exists valu2, numbering_holds valu2 ge sp (rs#dst <- (default_notrap_load_value chunk)) m (add_load n dst NOTRAP chunk addr args). + exists valu2, numbering_holds valu2 ge sp (rs#dst <- (default_notrap_load_value chunk)) m (add_load n dst chunk addr args). Proof. unfold add_load; intros. destruct (valnum_regs n args) as [n1 vl] eqn:VN. @@ -426,6 +428,7 @@ Proof. + rewrite Regmap.gss; auto. eapply load_notrap2_eval_to. rewrite <- B; eauto. assumption. + intros. apply Regmap.gso; auto. Qed. + *) Lemma set_unknown_holds: forall valu ge sp rs m n r v, @@ -520,6 +523,7 @@ Proof. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va. +(* - eapply load_notrap1_eval_to; assumption. - destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate. eapply load_notrap2_eval_to; eauto. @@ -532,6 +536,7 @@ Proof. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va. +*) Qed. Lemma store_normalized_range_sound: @@ -608,6 +613,7 @@ Proof. unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. auto. +(* - eapply load_notrap1_eval_to; assumption. - destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate. eapply load_notrap2_eval_to; eauto. rewrite <- H11. @@ -619,6 +625,7 @@ Proof. unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. auto. +*) Qed. Lemma load_memcpy: @@ -698,7 +705,7 @@ Lemma shift_memcpy_eq_holds: Proof with (try discriminate). intros. set (delta := dst - src) in *. unfold shift_memcpy_eq in H. destruct e as [l strict rhs] eqn:E. - destruct rhs as [op vl | trap chunk addr vl]... + destruct rhs as [op vl | chunk addr vl]... destruct addr... try (rename i into ofs). set (i1 := Ptrofs.unsigned ofs) in *. set (j := i1 + delta) in *. @@ -1091,44 +1098,14 @@ Proof. destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. destruct SAT as [valu1 NH1]. exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q). - destruct (find_rhs n1 (Load trap chunk addr vl)) as [r|] eqn:?. -+ (* replaced by move *) - exploit find_rhs_sound; eauto. intros (v' & EV & LD). - assert (v' = v) by (inv EV; congruence). subst v'. - econstructor; split. - eapply exec_Iop; eauto. simpl; eauto. - econstructor; eauto. - eapply analysis_correct_1; eauto. simpl; auto. - unfold transfer; rewrite H. - eapply add_load_holds; eauto. - apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto. -+ (* load is preserved, but addressing is possibly simplified *) - destruct (reduce addressing combine_addr n1 addr args vl) as [addr' args'] eqn:?. - assert (ADDR: eval_addressing ge sp addr' rs##args' = Some a). - { eapply reduce_sound with (sem := fun addr vl => eval_addressing ge sp addr vl); eauto. - intros; eapply combine_addr_sound; eauto. } - exploit eval_addressing_lessdef. apply regs_lessdef_regs; eauto. eexact ADDR. - intros [a' [A B]]. - assert (ADDR': eval_addressing tge sp addr' rs'##args' = Some a'). - { rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. } - exploit Mem.loadv_extends; eauto. - intros [v' [X Y]]. - econstructor; split. - eapply exec_Iload; eauto. - econstructor; eauto. - eapply analysis_correct_1; eauto. simpl; auto. - unfold transfer; rewrite H. - eapply add_load_holds; eauto. - apply set_reg_lessdef; auto. + destruct trap. -- (* Iload notrap1 *) - destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. - destruct SAT as [valu1 NH1]. - exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q). - destruct (find_rhs n1 (Load NOTRAP chunk addr vl)) as [r|] eqn:?. + (* TRAP *) + { + destruct (find_rhs n1 (Load chunk addr vl)) as [r|] eqn:?. + (* replaced by move *) exploit find_rhs_sound; eauto. intros (v' & EV & LD). - assert (v' = Vundef) by (inv EV; congruence). subst v'. + assert (v' = v) by (inv EV; congruence). subst v'. econstructor; split. eapply exec_Iop; eauto. simpl; eauto. econstructor; eauto. @@ -1154,9 +1131,41 @@ Proof. unfold transfer; rewrite H. eapply add_load_holds; eauto. apply set_reg_lessdef; auto. + } - (* TODO *) + (* NOTRAP *) + { + assert (exists a' : val, + eval_addressing ge sp addr rs' ## args = Some a' /\ Val.lessdef a a') + as Haa'. + apply eval_addressing_lessdef with (vl1 := rs ## args). + apply regs_lessdef_regs; assumption. + assumption. + destruct Haa' as [a' [Ha'1 Ha'2]]. + + assert ( + exists v' : val, + Mem.loadv chunk m' a' = Some v' /\ Val.lessdef v v') as Hload' by + (apply Mem.loadv_extends with (m1 := m) (addr1 := a); assumption). + destruct Hload' as [v' [Hv'1 Hv'2]]. + + econstructor. split. + eapply exec_Iload; eauto. + rewrite eval_addressing_preserved with (ge1 := ge). + exact Ha'1. + exact symbols_preserved. + + econstructor; eauto. + eapply analysis_correct_1; eauto. simpl; eauto. + unfold transfer. rewrite H. + exists valu1. + apply set_unknown_holds. + assumption. + apply set_reg_lessdef; assumption. + } +(* TODO *) + - (* Istore *) destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. destruct SAT as [valu1 NH1]. -- cgit From 25e3a0643d99248e479b7d18f3dfcbb9bbc35d83 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 09:30:53 +0200 Subject: CSEproof for non trapping loads --- backend/CSE.v | 26 +++++++++++--------- backend/CSEdomain.v | 12 ++++----- backend/CSEproof.v | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 89 insertions(+), 19 deletions(-) diff --git a/backend/CSE.v b/backend/CSE.v index 1c884cf0..2827161d 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -202,10 +202,10 @@ Definition add_op (n: numbering) (rd: reg) (op: operation) (rs: list reg) := and added to [n] as described in [add_rhs]. *) Definition add_load (n: numbering) (rd: reg) - (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) + (chunk: memory_chunk) (addr: addressing) (rs: list reg) := let (n1, vs) := valnum_regs n rs in - add_rhs n1 rd (Load trap chunk addr vs). + add_rhs n1 rd (Load chunk addr vs). (** [set_unknown n rd] returns a numbering where [rd] is mapped to no value number, and no equations are added. This is useful @@ -246,7 +246,7 @@ Definition kill_equations (pred: rhs -> bool) (n: numbering) : numbering := Definition filter_loads (r: rhs) : bool := match r with | Op op _ => op_depends_on_memory op - | Load _ _ _ _ => true + | Load _ _ _ => true end. Definition kill_all_loads (n: numbering) : numbering := @@ -262,7 +262,7 @@ Definition filter_after_store (app: VA.t) (n: numbering) (p: aptr) (sz: Z) (r: r match r with | Op op vl => op_depends_on_memory op - | Load trap chunk addr vl => + | Load chunk addr vl => match regs_valnums n vl with | None => true | Some rl => @@ -297,7 +297,7 @@ Definition add_store_result (app: VA.t) (n: numbering) (chunk: memory_chunk) (ad let (n1, vsrc) := valnum_reg n rsrc in let (n2, vargs) := valnum_regs n1 rargs in {| num_next := n2.(num_next); - num_eqs := Eq vsrc false (Load TRAP chunk addr vargs) :: n2.(num_eqs); + num_eqs := Eq vsrc false (Load chunk addr vargs) :: n2.(num_eqs); num_reg := n2.(num_reg); num_val := n2.(num_val) |} else n. @@ -326,7 +326,7 @@ Definition kill_loads_after_storebytes Definition shift_memcpy_eq (src sz delta: Z) (e: equation) := match e with - | Eq l strict (Load trap chunk (Ainstack i) _) => + | Eq l strict (Load chunk (Ainstack i) _) => let i := Ptrofs.unsigned i in let j := i + delta in if zle src i @@ -334,7 +334,7 @@ Definition shift_memcpy_eq (src sz delta: Z) (e: equation) := && zeq (Z.modulo delta (align_chunk chunk)) 0 && zle 0 j && zle j Ptrofs.max_unsigned - then Some(Eq l strict (Load trap chunk (Ainstack (Ptrofs.repr j)) nil)) + then Some(Eq l strict (Load chunk (Ainstack (Ptrofs.repr j)) nil)) else None | _ => None end. @@ -459,8 +459,10 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb before | Iop op args res s => add_op before res op args - | Iload trap chunk addr args dst s => - add_load before dst trap chunk addr args + | Iload TRAP chunk addr args dst s => + add_load before dst chunk addr args + | Iload NOTRAP _ _ _ dst _ => + set_unknown before dst | Istore chunk addr args src s => let app := approx!!pc in let n := kill_loads_after_store app before chunk addr args in @@ -534,14 +536,14 @@ Definition transf_instr (n: numbering) (instr: instruction) := let (op', args') := reduce _ combine_op n1 op args vl in Iop op' args' res s end - | Iload trap chunk addr args dst s => + | Iload TRAP chunk addr args dst s => let (n1, vl) := valnum_regs n args in - match find_rhs n1 (Load trap chunk addr vl) with + match find_rhs n1 (Load chunk addr vl) with | Some r => Iop Omove (r :: nil) dst s | None => let (addr', args') := reduce _ combine_addr n1 addr args vl in - Iload trap chunk addr' args' dst s + Iload TRAP chunk addr' args' dst s end | Istore chunk addr args src s => let (n1, vl) := valnum_regs n args in diff --git a/backend/CSEdomain.v b/backend/CSEdomain.v index 26d9c481..34ec0118 100644 --- a/backend/CSEdomain.v +++ b/backend/CSEdomain.v @@ -32,7 +32,7 @@ Definition valnum := positive. Inductive rhs : Type := | Op: operation -> list valnum -> rhs - | Load: trapping_mode -> memory_chunk -> addressing -> list valnum -> rhs. + | Load: memory_chunk -> addressing -> list valnum -> rhs. Inductive equation : Type := | Eq (v: valnum) (strict: bool) (r: rhs). @@ -74,7 +74,7 @@ Definition empty_numbering := Definition valnums_rhs (r: rhs): list valnum := match r with | Op op vl => vl - | Load trap chunk addr vl => vl + | Load chunk addr vl => vl end. Definition wf_rhs (next: valnum) (r: rhs) : Prop := @@ -106,11 +106,11 @@ Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem): | op_eval_to: forall op vl v, eval_operation ge sp op (map valu vl) m = Some v -> rhs_eval_to valu ge sp m (Op op vl) v - | load_eval_to: forall trap chunk addr vl a v, + | load_eval_to: forall chunk addr vl a v, eval_addressing ge sp addr (map valu vl) = Some a -> Mem.loadv chunk m a = Some v -> - rhs_eval_to valu ge sp m (Load trap chunk addr vl) v - | load_notrap1_eval_to: forall chunk addr vl, + rhs_eval_to valu ge sp m (Load chunk addr vl) v +(* | load_notrap1_eval_to: forall chunk addr vl, eval_addressing ge sp addr (map valu vl) = None -> rhs_eval_to valu ge sp m (Load NOTRAP chunk addr vl) (default_notrap_load_value chunk) @@ -118,7 +118,7 @@ Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem): eval_addressing ge sp addr (map valu vl) = Some a -> Mem.loadv chunk m a = None -> rhs_eval_to valu ge sp m (Load NOTRAP chunk addr vl) - (default_notrap_load_value chunk). + (default_notrap_load_value chunk) *). Inductive equation_holds (valu: valuation) (ge: genv) (sp: val) (m: mem): equation -> Prop := diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 50eb4637..684729d4 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -1164,8 +1164,76 @@ Proof. apply set_reg_lessdef; assumption. } -(* TODO *) +- (* Iload notrap 1*) + destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. + destruct SAT as [valu1 NH1]. + exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q). + + econstructor. split. + eapply exec_Iload_notrap1; eauto. + rewrite eval_addressing_preserved with (ge1 := ge). + apply eval_addressing_lessdef_none with (vl1 := rs ## args). + apply regs_lessdef_regs; assumption. + assumption. + exact symbols_preserved. + + econstructor; eauto. + eapply analysis_correct_1; eauto. simpl; eauto. + unfold transfer. rewrite H. + exists valu1. + apply set_unknown_holds. + assumption. + apply set_reg_lessdef. + constructor. assumption. +- (* Iload notrap 2*) + destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. + destruct SAT as [valu1 NH1]. + exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q). + + assert (exists a' : val, + eval_addressing ge sp addr rs' ## args = Some a' /\ Val.lessdef a a') + as Haa'. + apply eval_addressing_lessdef with (vl1 := rs ## args). + apply regs_lessdef_regs; assumption. + assumption. + destruct Haa' as [a' [Ha'1 Ha'2]]. + + destruct (Mem.loadv chunk m' a') eqn:Hload'. + + { + econstructor. split. + eapply exec_Iload; eauto. + rewrite eval_addressing_preserved with (ge1 := ge). + exact Ha'1. + exact symbols_preserved. + + econstructor; eauto. + eapply analysis_correct_1; eauto. simpl; eauto. + unfold transfer. rewrite H. + exists valu1. + apply set_unknown_holds. + assumption. + unfold default_notrap_load_value. + apply set_reg_lessdef; eauto. + } + { + econstructor. split. + eapply exec_Iload_notrap2; eauto. + rewrite eval_addressing_preserved with (ge1 := ge). + exact Ha'1. + exact symbols_preserved. + + econstructor; eauto. + eapply analysis_correct_1; eauto. simpl; eauto. + unfold transfer. rewrite H. + exists valu1. + apply set_unknown_holds. + assumption. + apply set_reg_lessdef. + constructor. assumption. + } + - (* Istore *) destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. destruct SAT as [valu1 NH1]. -- cgit From 7042070a3668ae149ec6a490b8e7c1a6aa82d6fe Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 11:07:04 +0200 Subject: LinearizeProof for non trapping loads --- backend/Linearizeproof.v | 48 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 16 deletions(-) diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 10a3d8b2..18dc52a5 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -585,45 +585,61 @@ Proof. intros; eapply reachable_successors; eauto. eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto. - (* Lop *) +- (* Lop *) left; econstructor; split. simpl. apply plus_one. econstructor; eauto. instantiate (1 := v); rewrite <- H; apply eval_operation_preserved. exact symbols_preserved. econstructor; eauto. - (* Lload *) +- (* Lload *) left; econstructor; split. simpl. - apply plus_one. econstructor. + apply plus_one. eapply exec_Lload. instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. econstructor; eauto. - (* Lgetstack *) +- (* Lload notrap1 *) + left; econstructor; split. simpl. + apply plus_one. eapply exec_Lload_notrap1. + rewrite <- H. + apply eval_addressing_preserved. + exact symbols_preserved. eauto. + econstructor; eauto. + +- (* Lload notrap2 *) + left; econstructor; split. simpl. + apply plus_one. eapply exec_Lload_notrap2. + rewrite <- H. + apply eval_addressing_preserved. + exact symbols_preserved. eauto. eauto. + econstructor; eauto. + +- (* Lgetstack *) left; econstructor; split. simpl. apply plus_one. econstructor; eauto. econstructor; eauto. - (* Lsetstack *) +- (* Lsetstack *) left; econstructor; split. simpl. apply plus_one. econstructor; eauto. econstructor; eauto. - (* Lstore *) +- (* Lstore *) left; econstructor; split. simpl. apply plus_one. econstructor. instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. econstructor; eauto. - (* Lcall *) +- (* Lcall *) exploit find_function_translated; eauto. intros [tfd [A B]]. left; econstructor; split. simpl. apply plus_one. econstructor; eauto. symmetry; eapply sig_preserved; eauto. econstructor; eauto. constructor; auto. econstructor; eauto. - (* Ltailcall *) +- (* Ltailcall *) exploit find_function_translated; eauto. intros [tfd [A B]]. left; econstructor; split. simpl. apply plus_one. econstructor; eauto. @@ -633,18 +649,18 @@ Proof. rewrite (match_parent_locset _ _ STACKS). econstructor; eauto. - (* Lbuiltin *) +- (* Lbuiltin *) left; econstructor; split. simpl. apply plus_one. eapply exec_Lbuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. - (* Lbranch *) +- (* Lbranch *) assert ((reachable f)!!pc = true). apply REACH; simpl; auto. right; split. simpl; omega. split. auto. simpl. econstructor; eauto. - (* Lcond *) +- (* Lcond *) assert (REACH1: (reachable f)!!pc1 = true) by (apply REACH; simpl; auto). assert (REACH2: (reachable f)!!pc2 = true) by (apply REACH; simpl; auto). simpl linearize_block. @@ -670,18 +686,18 @@ Proof. apply plus_one. eapply exec_Lcond_false. eauto. eauto. econstructor; eauto. - (* Ljumptable *) +- (* Ljumptable *) assert (REACH': (reachable f)!!pc = true). apply REACH. simpl. eapply list_nth_z_in; eauto. right; split. simpl; omega. split. auto. econstructor; eauto. - (* Lreturn *) +- (* Lreturn *) left; econstructor; split. simpl. apply plus_one. econstructor; eauto. rewrite (stacksize_preserved _ _ TRF). eauto. rewrite (match_parent_locset _ _ STACKS). econstructor; eauto. - (* internal functions *) +- (* internal functions *) assert (REACH: (reachable f)!!(LTL.fn_entrypoint f) = true). apply reachable_entrypoint. monadInv H7. @@ -691,13 +707,13 @@ Proof. generalize EQ; intro EQ'; monadInv EQ'. simpl. econstructor; eauto. simpl. eapply is_tail_add_branch. constructor. - (* external function *) +- (* external function *) monadInv H8. left; econstructor; split. apply plus_one. eapply exec_function_external; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. - (* return *) +- (* return *) inv H3. inv H1. left; econstructor; split. apply plus_one. econstructor. -- cgit From c4cc75dc6abcb0eee6f3288e96fea4aec540fd68 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 11:19:22 +0200 Subject: more proofs going through --- backend/Allocation.v | 24 +++++++++++++----------- backend/Bounds.v | 6 +++--- backend/Debugvar.v | 2 +- backend/LTL.v | 19 ++++++++++++++++--- backend/Linear.v | 23 ++++++++++++++++++++--- backend/Linearize.v | 4 ++-- backend/Lineartyping.v | 16 +++++++++++++++- backend/RTL.v | 2 -- backend/Tunnelingproof.v | 25 +++++++++++++++++++++++++ common/AST.v | 1 + common/Memory.v | 3 +++ 11 files changed, 99 insertions(+), 26 deletions(-) diff --git a/backend/Allocation.v b/backend/Allocation.v index c2e80f1c..2fa3fc0b 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -58,19 +58,19 @@ Inductive block_shape: Type := (mv2: moves) (s: node) | BSopdead (op: operation) (args: list reg) (res: reg) (mv: moves) (s: node) - | BSload (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg) + | BSload (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) | BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg) (mv: moves) (s: node) - | BSload2 (addr1 addr2: addressing) (args: list reg) (dst: reg) + | BSload2 (trap : trapping_mode) (addr1 addr2: addressing) (args: list reg) (dst: reg) (mv1: moves) (args1': list mreg) (dst1': mreg) (mv2: moves) (args2': list mreg) (dst2': mreg) (mv3: moves) (s: node) - | BSload2_1 (addr: addressing) (args: list reg) (dst: reg) + | BSload2_1 (trap : trapping_mode) (addr: addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) - | BSload2_2 (addr addr': addressing) (args: list reg) (dst: reg) + | BSload2_2 (trap : trapping_mode) (addr addr': addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) | BSstore (chunk: memory_chunk) (addr: addressing) (args: list reg) (src: reg) @@ -229,32 +229,34 @@ Definition pair_instr_block | Iload trap chunk addr args dst s => let (mv1, b1) := extract_moves nil b in match b1 with - | Lload chunk' addr' args' dst' :: b2 => + | Lload trap' chunk' addr' args' dst' :: b2 => + assertion (trapping_mode_eq trap' trap); if chunk_eq chunk Mint64 && Archi.splitlong then assertion (chunk_eq chunk' Mint32); let (mv2, b3) := extract_moves nil b2 in match b3 with - | Lload chunk'' addr'' args'' dst'' :: b4 => + | Lload trap'' chunk'' addr'' args'' dst'' :: b4 => + assertion (trapping_mode_eq trap'' trap); let (mv3, b5) := extract_moves nil b4 in assertion (chunk_eq chunk'' Mint32); assertion (eq_addressing addr addr'); assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr'')); assertion (check_succ s b5); - Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s) + Some(BSload2 trap addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s) | _ => assertion (check_succ s b3); if (eq_addressing addr addr') then - Some(BSload2_1 addr args dst mv1 args' dst' mv2 s) + Some(BSload2_1 trap addr args dst mv1 args' dst' mv2 s) else (assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr')); - Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s)) + Some(BSload2_2 trap addr addr' args dst mv1 args' dst' mv2 s)) end else ( let (mv2, b3) := extract_moves nil b2 in assertion (chunk_eq chunk chunk'); assertion (eq_addressing addr addr'); assertion (check_succ s b3); - Some(BSload chunk addr args dst mv1 args' dst' mv2 s)) + Some(BSload trap chunk addr args dst mv1 args' dst' mv2 s)) | _ => assertion (check_succ s b1); Some(BSloaddead chunk addr args dst mv1 s) @@ -1023,7 +1025,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv) | BSopdead op args res mv s => assertion (reg_unconstrained res e); track_moves env mv e - | BSload chunk addr args dst mv1 args' dst' mv2 s => + | BSload trap chunk addr args dst mv1 args' dst' mv2 s => do e1 <- track_moves env mv2 e; do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1; track_moves env mv1 e2 diff --git a/backend/Bounds.v b/backend/Bounds.v index fa695234..b8c12166 100644 --- a/backend/Bounds.v +++ b/backend/Bounds.v @@ -67,7 +67,7 @@ Definition instr_within_bounds (i: instruction) := | Lgetstack sl ofs ty r => slot_within_bounds sl ofs ty /\ mreg_within_bounds r | Lsetstack r sl ofs ty => slot_within_bounds sl ofs ty | Lop op args res => mreg_within_bounds res - | Lload chunk addr args dst => mreg_within_bounds dst + | Lload trap chunk addr args dst => mreg_within_bounds dst | Lcall sig ros => size_arguments sig <= bound_outgoing b | Lbuiltin ef args res => (forall r, In r (params_of_builtin_res res) \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r) @@ -104,7 +104,7 @@ Definition record_regs_of_instr (u: RegSet.t) (i: instruction) : RegSet.t := | Lgetstack sl ofs ty r => record_reg u r | Lsetstack r sl ofs ty => record_reg u r | Lop op args res => record_reg u res - | Lload chunk addr args dst => record_reg u dst + | Lload trap chunk addr args dst => record_reg u dst | Lstore chunk addr args src => u | Lcall sig ros => u | Ltailcall sig ros => u @@ -280,7 +280,7 @@ Definition defined_by_instr (r': mreg) (i: instruction) := match i with | Lgetstack sl ofs ty r => r' = r | Lop op args res => r' = res - | Lload chunk addr args dst => r' = dst + | Lload trap chunk addr args dst => r' = dst | Lbuiltin ef args res => In r' (params_of_builtin_res res) \/ In r' (destroyed_by_builtin ef) | _ => False end. diff --git a/backend/Debugvar.v b/backend/Debugvar.v index 1f361030..56908855 100644 --- a/backend/Debugvar.v +++ b/backend/Debugvar.v @@ -233,7 +233,7 @@ Definition transfer (lm: labelmap) (before: option avail) (i: instruction): (lm, Some (kill (S sl ofs ty) s)) | Lop op args dst => (lm, Some (kill (R dst) s)) - | Lload chunk addr args dst => + | Lload trap chunk addr args dst => (lm, Some (kill (R dst) s)) | Lstore chunk addr args src => (lm, before) diff --git a/backend/LTL.v b/backend/LTL.v index 5e7eec8c..ee8b4826 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -29,7 +29,7 @@ Definition node := positive. Inductive instruction: Type := | Lop (op: operation) (args: list mreg) (res: mreg) - | Lload (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) + | Lload (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) | Lgetstack (sl: slot) (ofs: Z) (ty: typ) (dst: mreg) | Lsetstack (src: mreg) (sl: slot) (ofs: Z) (ty: typ) | Lstore (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) @@ -209,11 +209,24 @@ Inductive step: state -> trace -> state -> Prop := rs' = Locmap.set (R res) v (undef_regs (destroyed_by_op op) rs) -> step (Block s f sp (Lop op args res :: bb) rs m) E0 (Block s f sp bb rs' m) - | exec_Lload: forall s f sp chunk addr args dst bb rs m a v rs', + | exec_Lload: forall s f sp trap chunk addr args dst bb rs m a v rs', eval_addressing ge sp addr (reglist rs args) = Some a -> Mem.loadv chunk m a = Some v -> rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) -> - step (Block s f sp (Lload chunk addr args dst :: bb) rs m) + step (Block s f sp (Lload trap chunk addr args dst :: bb) rs m) + E0 (Block s f sp bb rs' m) + | exec_Lload_notrap1: forall s f sp chunk addr args dst bb rs m rs', + eval_addressing ge sp addr (reglist rs args) = None -> + rs' = Locmap.set (R dst) (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (Block s f sp (Lload NOTRAP chunk addr args dst :: bb) rs m) + E0 (Block s f sp bb rs' m) + | exec_Lload_notrap2: forall s f sp chunk addr args dst bb rs m a rs', + eval_addressing ge sp addr (reglist rs args) = Some a -> + Mem.loadv chunk m a = None -> + rs' = Locmap.set (R dst) (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (Block s f sp (Lload NOTRAP chunk addr args dst :: bb) rs m) E0 (Block s f sp bb rs' m) | exec_Lgetstack: forall s f sp sl ofs ty dst bb rs m rs', rs' = Locmap.set (R dst) (rs (S sl ofs ty)) (undef_regs (destroyed_by_getstack sl) rs) -> diff --git a/backend/Linear.v b/backend/Linear.v index 447c6ba6..1443f795 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -28,7 +28,7 @@ Inductive instruction: Type := | Lgetstack: slot -> Z -> typ -> mreg -> instruction | Lsetstack: mreg -> slot -> Z -> typ -> instruction | Lop: operation -> list mreg -> mreg -> instruction - | Lload: memory_chunk -> addressing -> list mreg -> mreg -> instruction + | Lload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lcall: signature -> mreg + ident -> instruction | Ltailcall: signature -> mreg + ident -> instruction @@ -160,11 +160,28 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Lop op args res :: b) rs m) E0 (State s f sp b rs' m) | exec_Lload: - forall s f sp chunk addr args dst b rs m a v rs', + forall s f sp trap chunk addr args dst b rs m a v rs', eval_addressing ge sp addr (reglist rs args) = Some a -> Mem.loadv chunk m a = Some v -> rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) -> - step (State s f sp (Lload chunk addr args dst :: b) rs m) + step (State s f sp (Lload trap chunk addr args dst :: b) rs m) + E0 (State s f sp b rs' m) + | exec_Lload_notrap1: + forall s f sp chunk addr args dst b rs m rs', + eval_addressing ge sp addr (reglist rs args) = None -> + rs' = Locmap.set (R dst) + (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (State s f sp (Lload NOTRAP chunk addr args dst :: b) rs m) + E0 (State s f sp b rs' m) + | exec_Lload_notrap2: + forall s f sp chunk addr args dst b rs m a rs', + eval_addressing ge sp addr (reglist rs args) = Some a -> + Mem.loadv chunk m a = None -> + rs' = Locmap.set (R dst) + (default_notrap_load_value chunk) + (undef_regs (destroyed_by_load chunk addr) rs) -> + step (State s f sp (Lload NOTRAP chunk addr args dst :: b) rs m) E0 (State s f sp b rs' m) | exec_Lstore: forall s f sp chunk addr args src b rs m m' a rs', diff --git a/backend/Linearize.v b/backend/Linearize.v index 2cfa4d3c..4216958c 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -163,8 +163,8 @@ Fixpoint linearize_block (b: LTL.bblock) (k: code) : code := | nil => k | LTL.Lop op args res :: b' => Lop op args res :: linearize_block b' k - | LTL.Lload chunk addr args dst :: b' => - Lload chunk addr args dst :: linearize_block b' k + | LTL.Lload trap chunk addr args dst :: b' => + Lload trap chunk addr args dst :: linearize_block b' k | LTL.Lgetstack sl ofs ty dst :: b' => Lgetstack sl ofs ty dst :: linearize_block b' k | LTL.Lsetstack src sl ofs ty :: b' => diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 1fe23a9d..da66b6ff 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -76,7 +76,7 @@ Definition wt_instr (i: instruction) : bool := let (targs, tres) := type_of_operation op in subtype tres (mreg_type res) end - | Lload chunk addr args dst => + | Lload trap chunk addr args dst => subtype (type_of_chunk chunk) (mreg_type dst) | Ltailcall sg ros => zeq (size_arguments sg) 0 @@ -332,6 +332,20 @@ Local Opaque mreg_type. apply wt_setreg. eapply Val.has_subtype; eauto. destruct a; simpl in H0; try discriminate. eapply Mem.load_type; eauto. apply wt_undef_regs; auto. +- (* load notrap1 *) + simpl in *; InvBooleans. + econstructor; eauto. + apply wt_setreg. eapply Val.has_subtype; eauto. + unfold default_notrap_load_value. + constructor. + apply wt_undef_regs; auto. +- (* load notrap2 *) + simpl in *; InvBooleans. + econstructor; eauto. + apply wt_setreg. eapply Val.has_subtype; eauto. + unfold default_notrap_load_value. + constructor. + apply wt_undef_regs; auto. - (* store *) simpl in *; InvBooleans. econstructor. eauto. eauto. eauto. diff --git a/backend/RTL.v b/backend/RTL.v index 95fa1f82..29a49311 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -195,8 +195,6 @@ Definition find_function end end. -Definition default_notrap_load_value (chunk : memory_chunk) := Vundef. - (** The transitions are presented as an inductive predicate [step ge st1 t st2], where [ge] is the global environment, [st1] the initial state, [st2] the final state, and [t] the trace diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 4f95ac9b..d3b8a9f0 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -441,6 +441,31 @@ Proof. rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. +- (* Lload notrap1 *) + exploit eval_addressing_lessdef_none. apply reglist_lessdef; eauto. eassumption. + left; simpl; econstructor; split. + eapply exec_Lload_notrap1. + rewrite <- H0. + apply eval_addressing_preserved. exact symbols_preserved. eauto. + econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. +- (* Lload notrap2 *) + exploit eval_addressing_lessdef. apply reglist_lessdef; eauto. eauto. + intros (ta & EV & LD). + destruct (Mem.loadv chunk tm ta) eqn:Htload. + { + left; simpl; econstructor; split. + eapply exec_Lload. + rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved. + exact Htload. eauto. + econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. + } + { + left; simpl; econstructor; split. + eapply exec_Lload_notrap2. + rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved. + exact Htload. eauto. + econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef. + } - (* Lgetstack *) left; simpl; econstructor; split. econstructor; eauto. diff --git a/common/AST.v b/common/AST.v index d98f954a..bb8508b7 100644 --- a/common/AST.v +++ b/common/AST.v @@ -202,6 +202,7 @@ Proof. decide equality. Defined. + (** Initialization data for global variables. *) Inductive init_data: Type := diff --git a/common/Memory.v b/common/Memory.v index b68a5049..cfd13601 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -39,6 +39,9 @@ Require Import Values. Require Export Memdata. Require Export Memtype. +Definition default_notrap_load_value (chunk : memory_chunk) := Vundef. + + (* To avoid useless definitions of inductors in extracted code. *) Local Unset Elimination Schemes. Local Unset Case Analysis Schemes. -- cgit From fb09457f928fd4f19cd89a1fe22246444e3a5f4a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 11:26:52 +0200 Subject: some more proofs on notrap --- backend/CleanupLabelsproof.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v index e92be2b4..84ca403e 100644 --- a/backend/CleanupLabelsproof.v +++ b/backend/CleanupLabelsproof.v @@ -255,6 +255,18 @@ Proof. left; econstructor; split. econstructor; eauto. econstructor; eauto with coqlib. +(* Lload notrap1 *) + assert (eval_addressing tge sp addr (LTL.reglist rs args) = None). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + left; econstructor; split. + eapply exec_Lload_notrap1; eauto. + econstructor; eauto with coqlib. +(* Lload notrap2 *) + assert (eval_addressing tge sp addr (LTL.reglist rs args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + left; econstructor; split. + eapply exec_Lload_notrap2; eauto. + econstructor; eauto with coqlib. (* Lstore *) assert (eval_addressing tge sp addr (LTL.reglist rs args) = Some a). rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. -- cgit From 42a4bac600c0eaa552b66659f2c67d2f8b44cdf6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 11:49:55 +0200 Subject: more proof --- backend/Debugvarproof.v | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v index d31c63ec..95020637 100644 --- a/backend/Debugvarproof.v +++ b/backend/Debugvarproof.v @@ -449,6 +449,22 @@ Proof. eauto. eauto. apply eval_add_delta_ranges. traceEq. constructor; auto. +- (* load notrap1 *) + econstructor; split. + eapply plus_left. + eapply exec_Lload_notrap1. + rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved. + eauto. eauto. + apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* load notrap2 *) + econstructor; split. + eapply plus_left. + eapply exec_Lload_notrap2. + rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved. + eauto. eauto. + apply eval_add_delta_ranges. traceEq. + constructor; auto. - (* store *) econstructor; split. eapply plus_left. -- cgit From 4284ab56c71cd64ebf6ce22ad13d3cd5533ac7ed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 12:10:11 +0200 Subject: more on notrap --- backend/Mach.v | 19 ++++++++++++++++--- backend/Stacking.v | 4 ++-- mppa_k1c/Asmblockgen.v | 19 ++++++++++++------- mppa_k1c/Asmblockgenproof1.v | 34 ++++++++++++++++++++++++++-------- mppa_k1c/lib/Machblock.v | 17 ++++++++++++++--- mppa_k1c/lib/Machblockgen.v | 2 +- mppa_k1c/lib/Machblockgenproof.v | 4 ++++ 7 files changed, 75 insertions(+), 24 deletions(-) diff --git a/backend/Mach.v b/backend/Mach.v index 9fdee9eb..1c6fdb18 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -56,7 +56,7 @@ Inductive instruction: Type := | Msetstack: mreg -> ptrofs -> typ -> instruction | Mgetparam: ptrofs -> typ -> mreg -> instruction | Mop: operation -> list mreg -> mreg -> instruction - | Mload: memory_chunk -> addressing -> list mreg -> mreg -> instruction + | Mload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mcall: signature -> mreg + ident -> instruction | Mtailcall: signature -> mreg + ident -> instruction @@ -321,11 +321,24 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Mop op args res :: c) rs m) E0 (State s f sp c rs' m) | exec_Mload: - forall s f sp chunk addr args dst c rs m a v rs', + forall s f sp trap chunk addr args dst c rs m a v rs', 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) -> - step (State s f sp (Mload chunk addr args dst :: c) rs m) + step (State s f sp (Mload trap chunk addr args dst :: c) rs m) + E0 (State s f sp c rs' m) + | exec_Mload_notrap1: + forall s f sp chunk addr args dst c rs m rs', + eval_addressing ge sp addr rs##args = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + step (State s f sp (Mload NOTRAP chunk addr args dst :: c) rs m) + E0 (State s f sp c rs' m) + | exec_Mload_notrap2: + forall s f sp chunk addr args dst c rs m a rs', + 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)) -> + step (State s f sp (Mload NOTRAP chunk addr args dst :: c) rs m) E0 (State s f sp c rs' m) | exec_Mstore: forall s f sp chunk addr args src c rs m m' a rs', diff --git a/backend/Stacking.v b/backend/Stacking.v index 7b382d05..0e3f2832 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -133,8 +133,8 @@ Definition transl_instr end | Lop op args res => Mop (transl_op fe op) args res :: k - | Lload chunk addr args dst => - Mload chunk (transl_addr fe addr) args dst :: k + | Lload trap chunk addr args dst => + Mload trap chunk (transl_addr fe addr) args dst :: k | Lstore chunk addr args src => Mstore chunk (transl_addr fe addr) args src :: k | Lcall sig ros => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ade84e7b..cd9b3202 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1008,12 +1008,17 @@ Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) do r <- ireg_of dst; transl_memory_access2XS chunk (PLoadRRRXS (chunk2load chunk) r) scale args k. -Definition transl_load (chunk: memory_chunk) (addr: addressing) +Definition transl_load (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - match addr with - | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k - | Aindexed2 => transl_load_rrr chunk addr args dst k - | _ => transl_load_rro chunk addr args dst k + match trap with + | NOTRAP => Error(msg "Asmblockgen.transl_load NOTRAP TODO") + | TRAP => + match addr with + | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k + | Aindexed2 => transl_load_rrr chunk addr args dst k + | _ => transl_load_rro chunk addr args dst k + end end. Definition chunk2store (chunk: memory_chunk) := @@ -1073,8 +1078,8 @@ Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c) | MBop op args res => transl_op op args res k - | MBload chunk addr args dst => - transl_load chunk addr args dst k + | MBload trap chunk addr args dst => + transl_load trap chunk addr args dst k | MBstore chunk addr args src => transl_store chunk addr args src k end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index e1e2b0b0..ce01041d 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1947,9 +1947,9 @@ Proof. Qed. Lemma transl_load_memory_access_ok: - forall addr chunk args dst k c rs a v m, + forall addr trap chunk args dst k c rs a v m, (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> - transl_load chunk addr args dst k = OK c -> + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr rd, @@ -1958,6 +1958,8 @@ Lemma transl_load_memory_access_ok: /\ forall base ofs rs, exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs. Proof. + destruct trap. + { (* TRAP *) intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). @@ -1967,12 +1969,15 @@ Proof. - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity | eauto ]. + } + intros until m. intros ADDR TR ? ?. + monadInv TR. Qed. Lemma transl_load_memory_access2_ok: - forall addr chunk args dst k c rs a v m, + forall addr trap chunk args dst k c rs a v m, addr = Aindexed2 -> - transl_load chunk addr args dst k = OK c -> + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, @@ -1983,17 +1988,24 @@ Lemma transl_load_memory_access2_ok: /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro. Proof. + destruct trap. + { (* TRAP *) intros until m. intros ? TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ x)); simpl; reflexivity | eauto]. + } + { (* NOTRAP *) + intros until m. intros ? TR ? ?. + unfold transl_load in TR. subst. monadInv TR. + } Qed. Lemma transl_load_memory_access2XS_ok: - forall scale chunk args dst k c rs a v m, - transl_load chunk (Aindexed2XS scale) args dst k = OK c -> + forall scale trap chunk args dst k c rs a v m, + transl_load trap chunk (Aindexed2XS scale) args dst k = OK c -> eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, @@ -2004,17 +2016,23 @@ Lemma transl_load_memory_access2XS_ok: /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro. Proof. + destruct trap. + { (* TRAP *) intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ x)); simpl; rewrite Heqb; eauto | eauto]. + } + { (* NOTRAP *) + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. } Qed. Lemma transl_load_correct: - forall chunk addr args dst k c (rs: regset) m a v, - transl_load chunk addr args dst k = OK c -> + forall trap chunk addr args dst k c (rs: regset) m a v, + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v index 2759c49d..5a7f1782 100644 --- a/mppa_k1c/lib/Machblock.v +++ b/mppa_k1c/lib/Machblock.v @@ -20,7 +20,7 @@ Inductive basic_inst: Type := | MBsetstack: mreg -> ptrofs -> typ -> basic_inst | MBgetparam: ptrofs -> typ -> mreg -> basic_inst | MBop: operation -> list mreg -> mreg -> basic_inst - | MBload: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + | MBload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> basic_inst | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst . @@ -207,11 +207,22 @@ Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m: rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) -> basic_step s fb sp rs m (MBop op args res) rs' m | exec_MBload: - forall addr args a v rs' chunk dst, + forall addr args a v rs' trap chunk dst, eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) -> - basic_step s fb sp rs m (MBload chunk addr args dst) rs' m + basic_step s fb sp rs m (MBload trap chunk addr args dst) rs' m + | exec_MBload_notrap1: + forall addr args rs' chunk dst, + eval_addressing ge sp addr rs##args = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m + | exec_MBload_notrap2: + forall addr args a rs' chunk dst, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m | exec_MBstore: forall chunk addr args src m' a rs', eval_addressing ge sp addr rs##args = Some a -> diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index db48934e..a65b218f 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -33,7 +33,7 @@ Definition trans_inst (i:Mach.instruction) : Machblock_inst := | Msetstack src ofs ty => MB_basic (MBsetstack src ofs ty) | Mgetparam ofs ty dst => MB_basic (MBgetparam ofs ty dst) | Mop op args res => MB_basic (MBop op args res) - | Mload chunk addr args dst => MB_basic (MBload chunk addr args dst) + | Mload trap chunk addr args dst=> MB_basic (MBload trap chunk addr args dst) | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) | Mlabel l => MB_label l end. diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 9186e54a..77db094d 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -483,6 +483,10 @@ Proof. unfold Genv.symbol_address; rewrite symbols_preserved; auto. - eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap1; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap2; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. - eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; unfold Genv.symbol_address; rewrite symbols_preserved; auto. Qed. -- cgit From 339d7e5ff093a2002aa8c939aece10bafe2914d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 13:16:05 +0200 Subject: more proofs --- backend/Stackingproof.v | 39 +++++++++++++++++++++++++++++++++++++++ mppa_k1c/Op.v | 13 +++++++++++++ 2 files changed, 52 insertions(+) diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 326fab61..1d4a93e7 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -1918,6 +1918,45 @@ Proof. apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto. +- (* Lload notrap1*) + assert (eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = None) as Haddress. + eapply eval_addressing_inject_none; eauto. + eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP. + eapply agree_reglist; eauto. + econstructor; split. + apply plus_one. apply exec_Mload_notrap1. + rewrite <- Haddress. apply eval_addressing_preserved. exact symbols_preserved. + eauto. econstructor; eauto with coqlib. + apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. + apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto. + +- (* Lload notrap2 *) + assert (exists a', + eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' + /\ Val.inject j a a'). + eapply eval_addressing_inject; eauto. + eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP. + eapply agree_reglist; eauto. + destruct H1 as [a' [A B]]. + + destruct ( Mem.loadv chunk m' a') as [v'|] eqn:Hloadv. + { + econstructor; split. + apply plus_one. apply exec_Mload with (a:=a') (v:=v'); eauto. + rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto with coqlib. + apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. + apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto. + } + { + econstructor; split. + apply plus_one. apply exec_Mload_notrap2 with (a:=a'); eauto. + rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto with coqlib. + apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. + apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto. + } + - (* Lstore *) assert (exists a', eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c75a1a22..7aea2929 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1903,6 +1903,19 @@ Proof. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> -- cgit From 7556ba3dc77b1811b8a1063acc45ac1972865363 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 13:58:54 +0200 Subject: more stuff on non trapping loads --- mppa_k1c/Asmblockgenproof.v | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c44ef3ff..828e4665 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,6 +1204,14 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. + - (* MBload notrap1 TODO *) + simpl in EQ0. + discriminate. + + - (* MBload notrap2 TODO *) + simpl in EQ0. + discriminate. + - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. -- cgit From f9feebf866ec62fc57cb6e7deea9864b65945f16 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 14:08:52 +0200 Subject: moving forward with proofs --- backend/Allocation.v | 14 +++++++------- backend/Allocproof.v | 44 ++++++++++++++++++++++---------------------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/backend/Allocation.v b/backend/Allocation.v index 2fa3fc0b..c1fbf90d 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -1029,7 +1029,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv) do e1 <- track_moves env mv2 e; do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1; track_moves env mv1 e2 - | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => + | BSload2 trap addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => do e1 <- track_moves env mv3 e; let e2 := remove_equation (Eq kind_second_word dst (R dst2')) e1 in assertion (loc_unconstrained (R dst2') e2); @@ -1042,14 +1042,14 @@ Definition transfer_aux (f: RTL.function) (env: regenv) assertion (reg_unconstrained dst e5); do e6 <- add_equations args args1' e5; track_moves env mv1 e6 - | BSload2_1 addr args dst mv1 args' dst' mv2 s => + | BSload2_1 trap addr args dst mv1 args' dst' mv2 s => do e1 <- track_moves env mv2 e; let e2 := remove_equation (Eq kind_first_word dst (R dst')) e1 in assertion (reg_loc_unconstrained dst (R dst') e2); assertion (can_undef (destroyed_by_load Mint32 addr) e2); do e3 <- add_equations args args' e2; track_moves env mv1 e3 - | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => + | BSload2_2 trap addr addr' args dst mv1 args' dst' mv2 s => do e1 <- track_moves env mv2 e; let e2 := remove_equation (Eq kind_second_word dst (R dst')) e1 in assertion (reg_loc_unconstrained dst (R dst') e2); @@ -1265,10 +1265,10 @@ Definition successors_block_shape (bsh: block_shape) : list node := | BShighlong src dst mv s => s :: nil | BSop op args res mv1 args' res' mv2 s => s :: nil | BSopdead op args res mv s => s :: nil - | BSload chunk addr args dst mv1 args' dst' mv2 s => s :: nil - | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil - | BSload2_1 addr args dst mv1 args' dst' mv2 s => s :: nil - | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => s :: nil + | BSload trap chunk addr args dst mv1 args' dst' mv2 s => s :: nil + | BSload2 trap addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil + | BSload2_1 trap addr args dst mv1 args' dst' mv2 s => s :: nil + | BSload2_2 trap addr addr' args dst mv1 args' dst' mv2 s => s :: nil | BSloaddead chunk addr args dst mv s => s :: nil | BSstore chunk addr args src mv1 args' src' s => s :: nil | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s => s :: nil diff --git a/backend/Allocproof.v b/backend/Allocproof.v index ac4122bc..428bcc0e 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -98,37 +98,37 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (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 chunk addr args dst mv1 args' dst' mv2 s) + 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 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, + (Lload trap chunk addr args' dst' :: expand_moves mv2 (Lbranch s :: k))) + | ebs_load2: forall trap 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 Mint64 addr args dst s) + expand_block_shape (BSload2 trap addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s) + (Iload trap Mint64 addr args dst s) (expand_moves mv1 - (Lload Mint32 addr args1' dst1' :: + (Lload trap Mint32 addr args1' dst1' :: expand_moves mv2 - (Lload Mint32 addr2 args2' dst2' :: + (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, + | ebs_load2_1: forall trap 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 Mint64 addr args dst s) + expand_block_shape (BSload2_1 trap addr args dst mv1 args' dst' mv2 s) + (Iload trap Mint64 addr args dst s) (expand_moves mv1 - (Lload Mint32 addr args' dst' :: + (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, + | ebs_load2_2: forall trap 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 Mint64 addr args dst s) + expand_block_shape (BSload2_2 trap addr addr2 args dst mv1 args' dst' mv2 s) + (Iload trap Mint64 addr args dst s) (expand_moves mv1 - (Lload Mint32 addr2 args' dst' :: + (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 -> @@ -1970,8 +1970,8 @@ Ltac UseShape := end. Remark addressing_not_long: - forall env f addr args dst s r, - wt_instr f env (Iload Mint64 addr args dst s) -> Archi.splitlong = true -> + 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. @@ -1981,7 +1981,7 @@ Proof. { 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 H8; discriminate. + red; intros; subst r. rewrite C in H9; discriminate. Qed. (** The proof of semantic preservation is a simulation argument of the @@ -2083,7 +2083,7 @@ Proof. eapply wt_exec_Iop; eauto. (* load regular *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. +- 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]]. @@ -2100,7 +2100,7 @@ Proof. econstructor; eauto. (* load pair *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. +- 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 *. @@ -2155,7 +2155,7 @@ Proof. econstructor; eauto. (* load first word of a pair *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. +- 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 *. @@ -2185,7 +2185,7 @@ Proof. econstructor; eauto. (* load second word of a pair *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. +- 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 *. -- cgit From 3db304d599b7edf4ac77eb74c9b37e765b25bbd3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 16:51:08 +0200 Subject: BSload notrap1 --- backend/Allocproof.v | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 428bcc0e..fce54563 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -2082,7 +2082,7 @@ Proof. econstructor; eauto. eapply wt_exec_Iop; eauto. -(* load regular *) +(* 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]. @@ -2229,6 +2229,24 @@ Proof. econstructor; eauto. eapply wt_exec_Iload; eauto. +- (* BSload 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. + (* store *) - exploit exec_moves; eauto. intros [ls1 [X Y]]. exploit add_equations_lessdef; eauto. intros LD. simpl in LD. inv LD. -- cgit From 10fc3a0544cce0dcc345b2d14d2c00a33d9bbe92 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 5 Sep 2019 18:34:47 +0200 Subject: Duplicate: big progress on step_simulation, only Ijumptbl left --- backend/Duplicate.v | 19 ++--- backend/Duplicateaux.ml | 2 +- backend/Duplicateproof.v | 212 ++++++++++++++++++++++++++++++----------------- 3 files changed, 148 insertions(+), 85 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 8a78ee80..743d62e4 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -7,29 +7,30 @@ Require Import Coqlib Errors. Local Open Scope error_monad_scope. (** External oracle returning the new RTL code (entry point unchanged), - along with a mapping of new nodes to old nodes *) -Axiom duplicate_aux: RTL.function -> RTL.code * (PTree.t nat). + along with the new entrypoint, and a mapping of new nodes to old nodes *) +Axiom duplicate_aux: RTL.function -> RTL.code * node * (PTree.t nat). Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux". (** * Verification of node duplications *) (** Verifies that the mapping [mp] is giving correct information *) -Definition verify_mapping (f: function) (tc: code) (mp: PTree.t nat) : res unit := OK tt. (* TODO *) +Definition verify_mapping (f: function) (tc: code) (tentry: node) (mp: PTree.t nat) : res unit := OK tt. (* TODO *) (** * Entry points *) Definition transf_function (f: function) : res function := - let (tc, mp) := duplicate_aux f in - do u <- verify_mapping f tc mp; - OK (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc (fn_entrypoint f)). + let (tcte, mp) := duplicate_aux f in + let (tc, te) := tcte in + do u <- verify_mapping f tc te mp; + OK (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te). Theorem transf_function_preserves: forall f tf, transf_function f = OK tf -> - fn_sig f = fn_sig tf /\ fn_params f = fn_params tf /\ fn_stacksize f = fn_stacksize tf /\ fn_entrypoint f = fn_entrypoint tf. + fn_sig f = fn_sig tf /\ fn_params f = fn_params tf /\ fn_stacksize f = fn_stacksize tf. Proof. - intros. unfold transf_function in H. destruct (duplicate_aux _) as (tc & mp). monadInv H. + intros. unfold transf_function in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. repeat (split; try reflexivity). Qed. @@ -39,8 +40,6 @@ Remark transf_function_fnparams: forall f tf, transf_function f = OK tf -> fn_pa Proof. apply transf_function_preserves. Qed. Remark transf_function_fnstacksize: forall f tf, transf_function f = OK tf -> fn_stacksize f = fn_stacksize tf. Proof. apply transf_function_preserves. Qed. -Remark transf_function_fnentrypoint: forall f tf, transf_function f = OK tf -> fn_entrypoint f = fn_entrypoint tf. - Proof. apply transf_function_preserves. Qed. Definition transf_fundef (f: fundef) : res fundef := transf_partial_fundef transf_function f. diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 621a2dbe..a272ac85 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,4 +1,4 @@ open RTL open Maps -let duplicate_aux f = ((fn_code f), PTree.empty) +let duplicate_aux f = (((fn_code f), (fn_entrypoint f)), PTree.empty) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 77a6a954..48964fb0 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -1,7 +1,7 @@ (** Correctness proof for code duplication *) Require Import AST Linking Errors Globalenvs Smallstep. -Require Import Coqlib Maps Events. -Require Import RTL Duplicate. +Require Import Coqlib Maps Events Values. +Require Import Op RTL Duplicate. Definition match_prog (p tp: program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -12,6 +12,40 @@ Proof. intros. eapply match_transform_partial_program_contextual; eauto. Qed. +(* est-ce plus simple de prendre is_copy: node -> node, avec un noeud hors CFG à la place de None ? *) +Inductive match_inst (is_copy: node -> option node): instruction -> instruction -> Prop := + | match_inst_nop: forall n n', + is_copy n' = (Some n) -> match_inst is_copy (Inop n) (Inop n') + | match_inst_op: forall n n' op lr r, + is_copy n' = (Some n) -> match_inst is_copy (Iop op lr r n) (Iop op lr r n') + | match_inst_load: forall n n' m a lr r, + is_copy n' = (Some n) -> match_inst is_copy (Iload m a lr r n) (Iload m a lr r n') + | match_inst_store: forall n n' m a lr r, + is_copy n' = (Some n) -> match_inst is_copy (Istore m a lr r n) (Istore m a lr r n') + | match_inst_call: forall n n' s ri lr r, + is_copy n' = (Some n) -> match_inst is_copy (Icall s ri lr r n) (Icall s ri lr r n') + | match_inst_tailcall: forall n n' s ri lr, + is_copy n' = (Some n) -> match_inst is_copy (Itailcall s ri lr) (Itailcall s ri lr) + | match_inst_builtin: forall n n' ef la br, + is_copy n' = (Some n) -> match_inst is_copy (Ibuiltin ef la br n) (Ibuiltin ef la br n') + | match_inst_cond: forall ifso ifso' ifnot ifnot' c lr, + is_copy ifso' = (Some ifso) -> is_copy ifnot' = (Some ifnot) -> + match_inst is_copy (Icond c lr ifso ifnot) (Icond c lr ifso' ifnot') + | match_inst_jumptable: forall ln ln' r, + list_forall2 (fun n n' => (is_copy n' = (Some n))) ln ln' -> + match_inst is_copy (Ijumptable r ln) (Ijumptable r ln') + | match_inst_return: forall or, match_inst is_copy (Ireturn or) (Ireturn or). + +Axiom revmap: function -> node -> option node. (* mapping from nodes of [tprog], to nodes of [prog], for function [f] *) + +Axiom revmap_correct: forall f f' n n', + transf_function f = OK f' -> + revmap f n' = Some n -> + (forall i, (fn_code f)!n = Some i -> exists i', (fn_code f')!n' = Some i' /\ match_inst (revmap f) i i'). + +Axiom revmap_entrypoint: + forall f f', transf_function f = OK f' -> revmap f (fn_entrypoint f') = Some (fn_entrypoint f). + Section PRESERVATION. Variable prog: program. @@ -28,6 +62,15 @@ Lemma senv_preserved: Senv.equiv ge tge. Proof (Genv.senv_match TRANSL). +Lemma functions_translated: + forall (v: val) (f: fundef), + Genv.find_funct ge v = Some f -> + exists tf cunit, transf_fundef f = OK tf /\ Genv.find_funct tge v = Some tf /\ linkorder cunit prog. +Proof. + intros. exploit (Genv.find_funct_match TRANSL); eauto. + intros (cu & tf & A & B & C). exists tf, cu. split; auto. +Qed. + Lemma function_ptr_translated: forall v f, Genv.find_funct_ptr ge v = Some f -> @@ -35,6 +78,14 @@ Lemma function_ptr_translated: Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. Proof (Genv.find_funct_ptr_transf_partial TRANSL). +Lemma function_sig_translated: + forall f f', transf_fundef f = OK f' -> funsig f' = funsig f. +Proof. + intros. destruct f. + - simpl in H. monadInv H. simpl. symmetry. apply transf_function_preserves. assumption. + - simpl in H. monadInv H. reflexivity. +Qed. + Lemma sig_preserved: forall f tf, transf_fundef f = OK tf -> @@ -45,63 +96,11 @@ Proof. inv H. reflexivity. Qed. -Inductive match_nodes (f f': function): node -> node -> Prop := - | match_node_nop: forall n n' n1 n1', - (fn_code f)!n = Some (Inop n1) -> - (fn_code f')!n' = Some (Inop n1') -> - match_nodes f f' n1 n1' -> - match_nodes f f' n n' - | match_node_op: forall n n' n1 n1' op lr r, - (fn_code f)!n = Some (Iop op lr r n1) -> - (fn_code f')!n' = Some (Iop op lr r n1') -> - match_nodes f f' n1 n1' -> - match_nodes f f' n n' - | match_node_load: forall n n' n1 n1' m a lr r, - (fn_code f)!n = Some (Iload m a lr r n1) -> - (fn_code f')!n' = Some (Iload m a lr r n1') -> - match_nodes f f' n1 n1' -> - match_nodes f f' n n' - | match_node_store: forall n n' n1 n1' m a lr r, - (fn_code f)!n = Some (Istore m a lr r n1) -> - (fn_code f')!n' = Some (Istore m a lr r n1') -> - match_nodes f f' n1 n1' -> - match_nodes f f' n n' - | match_node_call: forall n n' n1 n1' s ri lr r, - (fn_code f)!n = Some (Icall s ri lr r n1) -> - (fn_code f')!n' = Some (Icall s ri lr r n1') -> - match_nodes f f' n1 n1' -> - match_nodes f f' n n' - | match_node_tailcall: forall n n' s ri lr, - (fn_code f)!n = Some (Itailcall s ri lr) -> - (fn_code f')!n' = Some (Itailcall s ri lr) -> - match_nodes f f' n n' - | match_node_builtin: forall n n' n1 n1' ef la br, - (fn_code f)!n = Some (Ibuiltin ef la br n1) -> - (fn_code f')!n' = Some (Ibuiltin ef la br n1') -> - match_nodes f f' n1 n1' -> - match_nodes f f' n n' - | match_node_cond: forall n n' n1 n1' n2 n2' c lr, - (fn_code f)!n = Some (Icond c lr n1 n2) -> - (fn_code f')!n' = Some (Icond c lr n1' n2') -> - match_nodes f f' n1 n1' -> - match_nodes f f' n2 n2' -> - match_nodes f f' n n' - | match_node_jumptable: forall n n' ln ln' r, - (fn_code f)!n = Some (Ijumptable r ln) -> - (fn_code f')!n' = Some (Ijumptable r ln') -> - list_forall2 (match_nodes f f') ln ln' -> - match_nodes f f' n n' - | match_node_return: forall n n' or, - (fn_code f)!n = Some (Ireturn or) -> - (fn_code f')!n = Some (Ireturn or) -> - match_nodes f f' n n' -. - Inductive match_stackframes: stackframe -> stackframe -> Prop := | match_stackframe_intro: forall res f sp pc rs f' pc' (TRANSF: transf_function f = OK f') - (DUPLIC: match_nodes f f' pc pc'), + (DUPLIC: revmap f pc' = Some pc), match_stackframes (Stackframe res f sp pc rs) (Stackframe res f' sp pc' rs). Inductive match_states: state -> state -> Prop := @@ -109,7 +108,7 @@ Inductive match_states: state -> state -> Prop := forall st f sp pc rs m st' f' pc' (STACKS: list_forall2 match_stackframes st st') (TRANSF: transf_function f = OK f') - (DUPLIC: match_nodes f f' pc pc'), + (DUPLIC: revmap f pc' = Some pc), match_states (State st f sp pc rs m) (State st' f' sp pc' rs m) | match_states_call: forall st st' f f' args m @@ -155,39 +154,103 @@ Theorem step_simulation: Proof. induction 1; intros; inv MS. (* Inop *) - - inv DUPLIC; try (rewrite H0 in H; discriminate). - rewrite H0 in H. inv H. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). + inv H3. eexists. split. - + eapply exec_Inop. eassumption. + + eapply exec_Inop; eauto. + constructor; eauto. (* Iop *) - - admit. (* inv DUPLIC; try (rewrite H1 in H; discriminate). - rewrite H1 in H. inv H. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. eexists. split. - + eapply exec_Iop. eassumption. - + constructor; eauto. *) + + eapply exec_Iop; eauto. erewrite eval_operation_preserved; eauto. + + constructor; eauto. (* Iload *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Iload; eauto. erewrite eval_addressing_preserved; eauto. + + constructor; auto. (* Istore *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Istore; eauto. erewrite eval_addressing_preserved; eauto. + + constructor; auto. (* Icall *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + destruct ros. + * simpl in H0. apply functions_translated in H0. + destruct H0 as (tf & cunit & TFUN & GFIND & LO). + eexists. split. + + eapply exec_Icall. eassumption. simpl. eassumption. + apply function_sig_translated. assumption. + + repeat (constructor; auto). + * simpl in H0. destruct (Genv.find_symbol _ _) eqn:GFS; try discriminate. + apply function_ptr_translated in H0. destruct H0 as (tf & GFF & TF). + eexists. split. + + eapply exec_Icall. eassumption. simpl. rewrite symbols_preserved. rewrite GFS. + eassumption. apply function_sig_translated. assumption. + + repeat (constructor; auto). (* Itailcall *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H10 & H11). inv H11. + pose symbols_preserved as SYMPRES. + destruct ros. + * simpl in H0. apply functions_translated in H0. + destruct H0 as (tf & cunit & TFUN & GFIND & LO). + eexists. split. + + eapply exec_Itailcall. eassumption. simpl. eassumption. + apply function_sig_translated. assumption. + erewrite <- transf_function_fnstacksize; eauto. + + repeat (constructor; auto). + * simpl in H0. destruct (Genv.find_symbol _ _) eqn:GFS; try discriminate. + apply function_ptr_translated in H0. destruct H0 as (tf & GFF & TF). + eexists. split. + + eapply exec_Itailcall. eassumption. simpl. rewrite symbols_preserved. rewrite GFS. + eassumption. apply function_sig_translated. assumption. + erewrite <- transf_function_fnstacksize; eauto. + + repeat (constructor; auto). (* Ibuiltin *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved; eauto. + eapply external_call_symbols_preserved; eauto. eapply senv_preserved. + + constructor; auto. (* Icond *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Icond; eauto. + + constructor; auto. destruct b; auto. (* Ijumptable *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Ijumptable; eauto. admit. + + admit. (* Ireturn *) - - admit. + - eapply revmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Ireturn; eauto. erewrite <- transf_function_fnstacksize; eauto. + + constructor; auto. (* exec_function_internal *) - monadInv TRANSF. eexists. split. + econstructor. erewrite <- transf_function_fnstacksize; eauto. - + erewrite transf_function_fnentrypoint; eauto. - erewrite transf_function_fnparams; eauto. - econstructor; eauto. admit. (* econstructor. *) + + erewrite transf_function_fnparams; eauto. + econstructor; eauto. apply revmap_entrypoint. assumption. (* exec_function_external *) - monadInv TRANSF. eexists. split. + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. @@ -199,6 +262,7 @@ Proof. Admitted. + Theorem transf_program_correct: forward_simulation (semantics prog) (semantics tprog). Proof. -- cgit From 8e03466a1a2e7bbc9057ac76ee18deda990dc884 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 23:26:38 +0200 Subject: progress in proof --- backend/Allocproof.v | 41 +++++++++++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/backend/Allocproof.v b/backend/Allocproof.v index fce54563..44dda4ac 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -102,33 +102,33 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (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 trap addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 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 trap addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s) - (Iload trap Mint64 addr args dst s) + 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' :: + (Lload TRAP Mint32 addr args1' dst1' :: expand_moves mv2 - (Lload trap Mint32 addr2 args2' dst2' :: + (Lload TRAP Mint32 addr2 args2' dst2' :: expand_moves mv3 (Lbranch s :: k)))) - | ebs_load2_1: forall trap addr args dst mv1 args' dst' mv2 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 trap addr args dst mv1 args' dst' mv2 s) - (Iload trap Mint64 addr args dst s) + 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' :: + (Lload TRAP Mint32 addr args' dst' :: expand_moves mv2 (Lbranch s :: k))) - | ebs_load2_2: forall trap addr addr2 args dst mv1 args' dst' mv2 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 trap addr addr2 args dst mv1 args' dst' mv2 s) - (Iload trap Mint64 addr args dst s) + 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' :: + (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 -> @@ -2246,7 +2246,20 @@ Proof. eauto. eauto. eauto. traceEq. exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. econstructor; eauto. - + +(* BSload notrap 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. -- cgit From da8f9c30dcc4bfd4bb1e0b4537188597946cda8f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 6 Sep 2019 10:51:32 +0200 Subject: Duplicate: proof complete, assuming revmap, revmap_correct and revmap_entrypoint --- backend/Duplicateproof.v | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 48964fb0..618009a1 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -96,6 +96,23 @@ Proof. inv H. reflexivity. Qed. +Lemma list_nth_z_revmap: + forall ln f ln' (pc pc': node) val, + list_nth_z ln val = Some pc -> + list_forall2 (fun n n' => revmap f n' = Some n) ln ln' -> + exists pc', + list_nth_z ln' val = Some pc' + /\ revmap f pc' = Some pc. +Proof. + induction ln; intros until val; intros LNZ LFA. + - inv LNZ. + - inv LNZ. destruct (zeq val 0) eqn:ZEQ. + + inv H0. destruct ln'; inv LFA. + simpl. exists n. split; auto. + + inv LFA. simpl. rewrite ZEQ. exploit IHln. 2: eapply H0. all: eauto. + intros (pc'1 & LNZ & REV). exists pc'1. split; auto. congruence. +Qed. + Inductive match_stackframes: stackframe -> stackframe -> Prop := | match_stackframe_intro: forall res f sp pc rs f' pc' @@ -236,9 +253,10 @@ Proof. - eapply revmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. + exploit list_nth_z_revmap; eauto. intros (pc'1 & LNZ & REVM). eexists. split. - + eapply exec_Ijumptable; eauto. admit. - + admit. + + eapply exec_Ijumptable; eauto. + + constructor; auto. (* Ireturn *) - eapply revmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. @@ -259,9 +277,7 @@ Proof. - inv STACKS. destruct b1 as [res' f' sp' pc' rs']. eexists. split. + constructor. + inv H1. constructor; assumption. -Admitted. - - +Qed. Theorem transf_program_correct: forward_simulation (semantics prog) (semantics tprog). -- cgit From e64b9464fb6662bf63ac255eca94d17d572c9d81 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 6 Sep 2019 22:33:46 +0200 Subject: ONE "admitted" and things compile --- backend/Allocation.v | 28 +++++++++++++++------------- backend/Allocproof.v | 37 ++++++++++++++++++++++++++++++++++--- backend/Inliningaux.ml | 2 +- backend/PrintLTL.ml | 7 ++++--- backend/PrintMach.ml | 5 +++-- backend/PrintRTL.ml | 7 ++++--- backend/PrintXTL.ml | 7 ++++--- backend/Regalloc.ml | 26 +++++++++++++------------- backend/Splitting.ml | 4 ++-- backend/XTL.ml | 4 ++-- backend/XTL.mli | 2 +- common/PrintAST.ml | 4 ++++ 12 files changed, 87 insertions(+), 46 deletions(-) diff --git a/backend/Allocation.v b/backend/Allocation.v index c1fbf90d..6e4fcc82 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -63,14 +63,14 @@ Inductive block_shape: Type := (mv2: moves) (s: node) | BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg) (mv: moves) (s: node) - | BSload2 (trap : trapping_mode) (addr1 addr2: addressing) (args: list reg) (dst: reg) + | BSload2 (addr1 addr2: addressing) (args: list reg) (dst: reg) (mv1: moves) (args1': list mreg) (dst1': mreg) (mv2: moves) (args2': list mreg) (dst2': mreg) (mv3: moves) (s: node) - | BSload2_1 (trap : trapping_mode) (addr: addressing) (args: list reg) (dst: reg) + | BSload2_1 (addr: addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) - | BSload2_2 (trap : trapping_mode) (addr addr': addressing) (args: list reg) (dst: reg) + | BSload2_2 (addr addr': addressing) (args: list reg) (dst: reg) (mv1: moves) (args': list mreg) (dst': mreg) (mv2: moves) (s: node) | BSstore (chunk: memory_chunk) (addr: addressing) (args: list reg) (src: reg) @@ -232,24 +232,26 @@ Definition pair_instr_block | Lload trap' chunk' addr' args' dst' :: b2 => assertion (trapping_mode_eq trap' trap); if chunk_eq chunk Mint64 && Archi.splitlong then + (* TODO: do not support non trapping split loads *) + assertion (trapping_mode_eq trap TRAP); assertion (chunk_eq chunk' Mint32); let (mv2, b3) := extract_moves nil b2 in match b3 with | Lload trap'' chunk'' addr'' args'' dst'' :: b4 => - assertion (trapping_mode_eq trap'' trap); + assertion (trapping_mode_eq trap'' TRAP); let (mv3, b5) := extract_moves nil b4 in assertion (chunk_eq chunk'' Mint32); assertion (eq_addressing addr addr'); assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr'')); assertion (check_succ s b5); - Some(BSload2 trap addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s) + Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s) | _ => assertion (check_succ s b3); if (eq_addressing addr addr') then - Some(BSload2_1 trap addr args dst mv1 args' dst' mv2 s) + Some(BSload2_1 addr args dst mv1 args' dst' mv2 s) else (assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr')); - Some(BSload2_2 trap addr addr' args dst mv1 args' dst' mv2 s)) + Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s)) end else ( let (mv2, b3) := extract_moves nil b2 in @@ -1029,7 +1031,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv) do e1 <- track_moves env mv2 e; do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1; track_moves env mv1 e2 - | BSload2 trap addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => + | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => do e1 <- track_moves env mv3 e; let e2 := remove_equation (Eq kind_second_word dst (R dst2')) e1 in assertion (loc_unconstrained (R dst2') e2); @@ -1042,14 +1044,14 @@ Definition transfer_aux (f: RTL.function) (env: regenv) assertion (reg_unconstrained dst e5); do e6 <- add_equations args args1' e5; track_moves env mv1 e6 - | BSload2_1 trap addr args dst mv1 args' dst' mv2 s => + | BSload2_1 addr args dst mv1 args' dst' mv2 s => do e1 <- track_moves env mv2 e; let e2 := remove_equation (Eq kind_first_word dst (R dst')) e1 in assertion (reg_loc_unconstrained dst (R dst') e2); assertion (can_undef (destroyed_by_load Mint32 addr) e2); do e3 <- add_equations args args' e2; track_moves env mv1 e3 - | BSload2_2 trap addr addr' args dst mv1 args' dst' mv2 s => + | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => do e1 <- track_moves env mv2 e; let e2 := remove_equation (Eq kind_second_word dst (R dst')) e1 in assertion (reg_loc_unconstrained dst (R dst') e2); @@ -1266,9 +1268,9 @@ Definition successors_block_shape (bsh: block_shape) : list node := | BSop op args res mv1 args' res' mv2 s => s :: nil | BSopdead op args res mv s => s :: nil | BSload trap chunk addr args dst mv1 args' dst' mv2 s => s :: nil - | BSload2 trap addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil - | BSload2_1 trap addr args dst mv1 args' dst' mv2 s => s :: nil - | BSload2_2 trap addr addr' args dst mv1 args' dst' mv2 s => s :: nil + | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil + | BSload2_1 addr args dst mv1 args' dst' mv2 s => s :: nil + | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => s :: nil | BSloaddead chunk addr args dst mv s => s :: nil | BSstore chunk addr args src mv1 args' src' s => s :: nil | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s => s :: nil diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 44dda4ac..ab6f87b0 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -2229,7 +2229,7 @@ Proof. econstructor; eauto. eapply wt_exec_Iload; eauto. -- (* BSload notrap1 *) +- (* load notrap1 *) generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS). intro WTRS'. exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. @@ -2247,7 +2247,7 @@ Proof. exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. econstructor; eauto. -(* BSload notrap dead? *) +(* load notrap1 dead *) - exploit exec_moves; eauto. intros [ls1 [X Y]]. econstructor; split. eapply plus_left. econstructor; eauto. @@ -2259,7 +2259,38 @@ Proof. econstructor; eauto. eapply wt_exec_Iload_notrap; eauto. +(* load regular notrap2 *) +- (* 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]]. + + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. eapply exec_Lload_notrap2 with (a := 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. + + generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS). intro WTRS'. + *) + + admit. +- (* 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. @@ -2511,7 +2542,7 @@ Proof. eapply plus_left. constructor. eexact A. traceEq. econstructor; eauto. apply wt_regset_assign; auto. rewrite WTRES0; auto. -Qed. +Admitted. Lemma initial_states_simulation: forall st1, RTL.initial_state prog st1 -> diff --git a/backend/Inliningaux.ml b/backend/Inliningaux.ml index 842e0c93..609b2637 100644 --- a/backend/Inliningaux.ml +++ b/backend/Inliningaux.ml @@ -57,7 +57,7 @@ let used_in_globvar io gv = let fun_inline_analysis id io fn = let inst io nid = function | Iop (op, args, dest, succ) -> used_id io (globals_operation op) - | Iload (chunk, addr, args, dest, succ) + | Iload (_, chunk, addr, args, dest, succ) | Istore (chunk, addr, args, dest, succ) -> used_id io (globals_addressing addr) | Ibuiltin (ef, args, dest, succ) -> used_id io (globals_of_builtin_args args) | Icall (_, Coq_inr cid, _, _, _) diff --git a/backend/PrintLTL.ml b/backend/PrintLTL.ml index 1c449e74..b309a9f2 100644 --- a/backend/PrintLTL.ml +++ b/backend/PrintLTL.ml @@ -61,9 +61,10 @@ let print_succ pp s dfl = let print_instruction pp succ = function | Lop(op, args, res) -> fprintf pp "%a = %a" mreg res (print_operation mreg) (op, args) - | Lload(chunk, addr, args, dst) -> - fprintf pp "%a = %s[%a]" - mreg dst (name_of_chunk chunk) (print_addressing mreg) (addr, args) + | Lload(trap,chunk, addr, args, dst) -> + fprintf pp "%a = %s[%a]%a" + mreg dst (name_of_chunk chunk) (print_addressing mreg) (addr, args) + print_trapping_mode trap | Lgetstack(sl, ofs, ty, dst) -> fprintf pp "%a = %a" mreg dst slot (sl, ofs, ty) | Lsetstack(src, sl, ofs, ty) -> diff --git a/backend/PrintMach.ml b/backend/PrintMach.ml index 517f3037..70e65832 100644 --- a/backend/PrintMach.ml +++ b/backend/PrintMach.ml @@ -48,10 +48,11 @@ let print_instruction pp i = | Mop(op, args, res) -> fprintf pp "\t%a = %a\n" reg res (PrintOp.print_operation reg) (op, args) - | Mload(chunk, addr, args, dst) -> - fprintf pp "\t%a = %s[%a]\n" + | Mload(trap, chunk, addr, args, dst) -> + fprintf pp "\t%a = %s[%a]%a\n" reg dst (name_of_chunk chunk) (PrintOp.print_addressing reg) (addr, args) + print_trapping_mode trap | Mstore(chunk, addr, args, src) -> fprintf pp "\t%s[%a] = %a\n" (name_of_chunk chunk) diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml index 841540b6..c25773e5 100644 --- a/backend/PrintRTL.ml +++ b/backend/PrintRTL.ml @@ -50,10 +50,11 @@ let print_instruction pp (pc, i) = fprintf pp "%a = %a\n" reg res (PrintOp.print_operation reg) (op, args); print_succ pp s (pc - 1) - | Iload(chunk, addr, args, dst, s) -> - fprintf pp "%a = %s[%a]\n" + | Iload(trap, chunk, addr, args, dst, s) -> + fprintf pp "%a = %s[%a]%a\n" reg dst (name_of_chunk chunk) - (PrintOp.print_addressing reg) (addr, args); + (PrintOp.print_addressing reg) (addr, args) + print_trapping_mode trap; print_succ pp s (pc - 1) | Istore(chunk, addr, args, src, s) -> fprintf pp "%s[%a] = %a\n" diff --git a/backend/PrintXTL.ml b/backend/PrintXTL.ml index 6432682a..1c7655fb 100644 --- a/backend/PrintXTL.ml +++ b/backend/PrintXTL.ml @@ -86,9 +86,10 @@ let print_instruction pp succ = function fprintf pp "(%a) = (%a) using %a, %a" vars dsts vars srcs var t1 var t2 | Xop(op, args, res) -> fprintf pp "%a = %a" var res (print_operation var) (op, args) - | Xload(chunk, addr, args, dst) -> - fprintf pp "%a = %s[%a]" - var dst (name_of_chunk chunk) (print_addressing var) (addr, args) + | Xload(trap, chunk, addr, args, dst) -> + fprintf pp "%a = %s[%a]%a" + var dst (name_of_chunk chunk) (print_addressing var) (addr, args) + print_trapping_mode trap | Xstore(chunk, addr, args, src) -> fprintf pp "%s[%a] = %a" (name_of_chunk chunk) (print_addressing var) (addr, args) var src diff --git a/backend/Regalloc.ml b/backend/Regalloc.ml index 7db8a866..f2658b04 100644 --- a/backend/Regalloc.ml +++ b/backend/Regalloc.ml @@ -249,18 +249,18 @@ let block_of_RTL_instr funsig tyenv = function else let t = new_temp (tyenv res) in (t :: args2', t) in movelist args1 args3 (Xop(op, args3, res3) :: move res3 res1 [Xbranch s]) - | RTL.Iload(chunk, addr, args, dst, s) -> + | RTL.Iload(trap, chunk, addr, args, dst, s) -> if Archi.splitlong && chunk = Mint64 then begin match offset_addressing addr (coqint_of_camlint 4l) with | None -> assert false | Some addr' -> - [Xload(Mint32, addr, vregs tyenv args, + [Xload(trap, Mint32, addr, vregs tyenv args, V((if Archi.big_endian then dst else twin_reg dst), Tint)); - Xload(Mint32, addr', vregs tyenv args, + Xload(trap, Mint32, addr', vregs tyenv args, V((if Archi.big_endian then twin_reg dst else dst), Tint)); Xbranch s] end else - [Xload(chunk, addr, vregs tyenv args, vreg tyenv dst); Xbranch s] + [Xload(trap, chunk, addr, vregs tyenv args, vreg tyenv dst); Xbranch s] | RTL.Istore(chunk, addr, args, src, s) -> if Archi.splitlong && chunk = Mint64 then begin match offset_addressing addr (coqint_of_camlint 4l) with @@ -364,7 +364,7 @@ let live_before instr after = if VSet.mem res after then vset_addlist args (VSet.remove res after) else after - | Xload(chunk, addr, args, dst) -> + | Xload(trap, chunk, addr, args, dst) -> if VSet.mem dst after then vset_addlist args (VSet.remove dst after) else after @@ -459,7 +459,7 @@ let dce_instr instr after k = if VSet.mem res after then instr :: k else k - | Xload(chunk, addr, args, dst) -> + | Xload(trap, chunk, addr, args, dst) -> if VSet.mem dst after then instr :: k else k @@ -550,7 +550,7 @@ let spill_costs f = (* temps must not be spilled *) | Xop(op, args, res) -> charge_list 10 1 args; charge 10 1 res - | Xload(chunk, addr, args, dst) -> + | Xload(trap, chunk, addr, args, dst) -> charge_list 10 1 args; charge 10 1 dst | Xstore(chunk, addr, args, src) -> charge_list 10 1 args; charge 10 1 src @@ -677,7 +677,7 @@ let add_interfs_instr g instr live = (vset_addlist (res :: argl) (VSet.remove res live)) end; add_interfs_destroyed g (VSet.remove res live) (destroyed_by_op op) - | Xload(chunk, addr, args, dst) -> + | Xload(trap, chunk, addr, args, dst) -> add_interfs_def g dst live; add_interfs_destroyed g (VSet.remove dst live) (destroyed_by_load chunk addr) @@ -782,7 +782,7 @@ let tospill_instr alloc instr ts = ts | Xop(op, args, res) -> addlist_tospill alloc args (add_tospill alloc res ts) - | Xload(chunk, addr, args, dst) -> + | Xload(trap, chunk, addr, args, dst) -> addlist_tospill alloc args (add_tospill alloc dst ts) | Xstore(chunk, addr, args, src) -> addlist_tospill alloc args (add_tospill alloc src ts) @@ -964,10 +964,10 @@ let spill_instr tospill eqs instr = add res tmp (kill tmp (kill res eqs2))) end end - | Xload(chunk, addr, args, dst) -> + | Xload(trap, chunk, addr, args, dst) -> let (args', c1, eqs1) = reload_vars tospill eqs args in let (dst', c2, eqs2) = save_var tospill eqs1 dst in - (c1 @ Xload(chunk, addr, args', dst') :: c2, eqs2) + (c1 @ Xload(trap, chunk, addr, args', dst') :: c2, eqs2) | Xstore(chunk, addr, args, src) -> let (args', c1, eqs1) = reload_vars tospill eqs args in let (src', c2, eqs2) = reload_var tospill eqs1 src in @@ -1115,8 +1115,8 @@ let transl_instr alloc instr k = LTL.Lop(Omove, [rarg1], rres) :: LTL.Lop(op, rres :: rargl, rres) :: k end - | Xload(chunk, addr, args, dst) -> - LTL.Lload(chunk, addr, mregs_of alloc args, mreg_of alloc dst) :: k + | Xload(trap, chunk, addr, args, dst) -> + LTL.Lload(trap, chunk, addr, mregs_of alloc args, mreg_of alloc dst) :: k | Xstore(chunk, addr, args, src) -> LTL.Lstore(chunk, addr, mregs_of alloc args, mreg_of alloc src) :: k | Xcall(sg, vos, args, res) -> diff --git a/backend/Splitting.ml b/backend/Splitting.ml index 40f09c3d..78eb66a5 100644 --- a/backend/Splitting.ml +++ b/backend/Splitting.ml @@ -151,8 +151,8 @@ let ren_instr f maps pc i = | Inop s -> Inop s | Iop(op, args, res, s) -> Iop(op, ren_regs before args, ren_reg after res, s) - | Iload(chunk, addr, args, dst, s) -> - Iload(chunk, addr, ren_regs before args, ren_reg after dst, s) + | Iload(trap, chunk, addr, args, dst, s) -> + Iload(trap, chunk, addr, ren_regs before args, ren_reg after dst, s) | Istore(chunk, addr, args, src, s) -> Istore(chunk, addr, ren_regs before args, ren_reg before src, s) | Icall(sg, ros, args, res, s) -> diff --git a/backend/XTL.ml b/backend/XTL.ml index f10efeed..c496fafb 100644 --- a/backend/XTL.ml +++ b/backend/XTL.ml @@ -30,7 +30,7 @@ type instruction = | Xspill of var * var | Xparmove of var list * var list * var * var | Xop of operation * var list * var - | Xload of memory_chunk * addressing * var list * var + | Xload of trapping_mode * memory_chunk * addressing * var list * var | Xstore of memory_chunk * addressing * var list * var | Xcall of signature * (var, ident) sum * var list * var list | Xtailcall of signature * (var, ident) sum * var list @@ -159,7 +159,7 @@ let type_instr = function let (targs, tres) = type_of_operation op in set_vars_type args targs; set_var_type res tres - | Xload(chunk, addr, args, dst) -> + | Xload(trap, chunk, addr, args, dst) -> set_vars_type args (type_of_addressing addr); set_var_type dst (type_of_chunk chunk) | Xstore(chunk, addr, args, src) -> diff --git a/backend/XTL.mli b/backend/XTL.mli index 54988d4b..b4b77fab 100644 --- a/backend/XTL.mli +++ b/backend/XTL.mli @@ -31,7 +31,7 @@ type instruction = | Xspill of var * var | Xparmove of var list * var list * var * var | Xop of operation * var list * var - | Xload of memory_chunk * addressing * var list * var + | Xload of trapping_mode * memory_chunk * addressing * var list * var | Xstore of memory_chunk * addressing * var list * var | Xcall of signature * (var, ident) sum * var list * var list | Xtailcall of signature * (var, ident) sum * var list diff --git a/common/PrintAST.ml b/common/PrintAST.ml index e477957a..baddb722 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -90,3 +90,7 @@ let rec print_builtin_res px oc = function fprintf oc "splitlong(%a, %a)" (print_builtin_res px) hi (print_builtin_res px) lo +let print_trapping_mode oc = function + | TRAP -> () + | NOTRAP -> output_string oc " [notrap]" + -- cgit From 75109076ec027675e297ff1273660fc6b5a5f239 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 6 Sep 2019 23:46:15 +0200 Subject: for nontrap --- x86/Op.v | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/x86/Op.v b/x86/Op.v index 16d75426..a1000a51 100644 --- a/x86/Op.v +++ b/x86/Op.v @@ -1199,6 +1199,21 @@ Proof. unfold eval_addressing; intros. destruct Archi.ptr64; eauto using eval_addressing32_inj, eval_addressing64_inj. 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 *; + inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate. +Qed. + Lemma eval_operation_inj: forall op sp1 vl1 sp2 vl2 v1, (forall id ofs, @@ -1425,6 +1440,19 @@ Proof. destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. +Lemma eval_addressing_lessdef_none: + forall sp addr vl1 vl2, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = None -> + eval_addressing genv sp addr vl2 = None. +Proof. + intros until vl2. intros Hlessdef Heval1. + destruct addr; simpl in *; + inv Hlessdef; trivial; try discriminate; + inv H0; trivial; try discriminate; + inv H2; trivial; try discriminate. +Qed. + End EVAL_LESSDEF. (** Compatibility of the evaluation functions with memory injections. *) -- cgit From f2831013b46d0486e5e134f26fde9ece7b78ff93 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 09:49:58 +0200 Subject: more for passing notrap through x86 --- backend/Constpropproof.v | 12 ++++++++++-- x86/Asmgen.v | 12 +++++++++--- x86/Asmgenproof.v | 12 +++++++++--- x86/Asmgenproof1.v | 8 +++++--- x86/Op.v | 13 +++++++++++++ x86/ValueAOp.v | 21 ++++++++++++++++++++- 6 files changed, 66 insertions(+), 12 deletions(-) diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index eb4b6f17..dca36b4e 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -452,7 +452,8 @@ Proof. - (* Iload notrap1 *) rename pc'0 into pc. TransfInstr. - assert (eval_static_addressing addr (aregs ae args) = Vbot) as Hbot by (eapply eval_static_addressing_sound_none; eauto with va). + destruct (eval_static_addressing addr (aregs ae args)) eqn:Hstatic. + { assert (eval_addressing tge (Vptr sp0 Ptrofs.zero) addr rs' ## args = None) as Hnone. rewrite eval_addressing_preserved with (ge1 := ge). apply eval_addressing_lessdef_none with (vl1 := rs ## args). @@ -463,7 +464,14 @@ Proof. left; econstructor; econstructor; split. eapply exec_Iload_notrap1; eauto. eapply match_states_succ; eauto. apply set_reg_lessdef; auto. - + } + { exploit eval_static_addressing_sound; eauto. + rewrite eval_addressing_preserved with (ge1 := ge). + apply eval_addressing_lessdef with (vl1 := rs ## args). + apply regs_lessdef_regs; assumption. + assumption. + exact symbols_preserved. + } - (* Iload notrap2 *) rename pc'0 into pc. TransfInstr. assert (exists v2 : val, diff --git a/x86/Asmgen.v b/x86/Asmgen.v index 73e3263e..99e9fc2b 100644 --- a/x86/Asmgen.v +++ b/x86/Asmgen.v @@ -636,9 +636,14 @@ Definition transl_op (** Translation of memory loads and stores *) -Definition transl_load (chunk: memory_chunk) +Definition transl_load + (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dest: mreg) (k: code) : res code := + match trap with + | NOTRAP => Error (msg "Asmgen.transl_load x86 does not support non trapping loads") + | TRAP => do am <- transl_addressing addr args; match chunk with | Mint8unsigned => @@ -659,6 +664,7 @@ Definition transl_load (chunk: memory_chunk) do r <- freg_of dest; OK(Pmovsd_fm r am :: k) | _ => Error (msg "Asmgen.transl_load") + end end. Definition transl_store (chunk: memory_chunk) @@ -699,8 +705,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) loadind RSP f.(fn_link_ofs) Tptr AX k1) | Mop op args res => transl_op op args res k - | Mload chunk addr args dst => - transl_load chunk addr args dst k + | Mload trap chunk addr args dst => + transl_load trap chunk addr args dst k | Mstore chunk addr args src => transl_store chunk addr args src k | Mcall sig (inl reg) => diff --git a/x86/Asmgenproof.v b/x86/Asmgenproof.v index f1fd41e3..6886b2fd 100644 --- a/x86/Asmgenproof.v +++ b/x86/Asmgenproof.v @@ -235,11 +235,11 @@ Proof. Qed. Remark transl_load_label: - forall chunk addr args dest k c, - transl_load chunk addr args dest k = OK c -> + forall trap chunk addr args dest k c, + transl_load trap chunk addr args dest k = OK c -> tail_nolabel k c. Proof. - intros. monadInv H. destruct chunk; TailNoLabel. + intros. destruct trap; try discriminate. monadInv H. destruct chunk; TailNoLabel. Qed. Remark transl_store_label: @@ -567,6 +567,12 @@ Opaque loadind. split. eapply agree_set_undef_mreg; eauto. congruence. simpl; congruence. +- (* Mload notrap *) (* isn't there a nicer way? *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + +- (* Mload notrap *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + - (* Mstore *) assert (eval_addressing tge sp addr rs##args = Some a). rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. diff --git a/x86/Asmgenproof1.v b/x86/Asmgenproof1.v index fd88954e..7cff1047 100644 --- a/x86/Asmgenproof1.v +++ b/x86/Asmgenproof1.v @@ -1464,8 +1464,8 @@ Qed. (** Translation of memory loads. *) Lemma transl_load_correct: - forall chunk addr args dest k c (rs: regset) m a v, - transl_load chunk addr args dest k = OK c -> + forall trap chunk addr args dest k c (rs: regset) m a v, + transl_load trap chunk addr args dest k = OK c -> eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', @@ -1473,7 +1473,9 @@ Lemma transl_load_correct: /\ rs'#(preg_of dest) = v /\ forall r, data_preg r = true -> r <> preg_of dest -> rs'#r = rs#r. Proof. - unfold transl_load; intros. monadInv H. + unfold transl_load; intros. + destruct trap; simpl; try discriminate. + monadInv H. exploit transl_addressing_mode_correct; eauto. intro EA. assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)). diff --git a/x86/Op.v b/x86/Op.v index a1000a51..a7176ce4 100644 --- a/x86/Op.v +++ b/x86/Op.v @@ -1505,6 +1505,19 @@ Proof. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> diff --git a/x86/ValueAOp.v b/x86/ValueAOp.v index d0b8427a..e5584b6a 100644 --- a/x86/ValueAOp.v +++ b/x86/ValueAOp.v @@ -261,6 +261,25 @@ Proof. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. apply select_sound; auto. eapply eval_static_condition_sound; eauto. 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. + destruct (Archi.ptr64). + inv Hlist. + destruct addr; trivial; discriminate. + inv H0. + destruct addr; trivial; try discriminate. simpl in *. + inv H2. + destruct addr; trivial; discriminate. + inv H3; + destruct addr; trivial; discriminate. +Qed. +*) End SOUNDNESS. -- cgit From 046c24d29796a3bb130c94fe464e54e8a7aa2eb3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 10:11:56 +0200 Subject: notrap works on x86 --- backend/Constpropproof.v | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index dca36b4e..2e43a93f 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -452,10 +452,8 @@ Proof. - (* Iload notrap1 *) rename pc'0 into pc. TransfInstr. - destruct (eval_static_addressing addr (aregs ae args)) eqn:Hstatic. - { - assert (eval_addressing tge (Vptr sp0 Ptrofs.zero) addr rs' ## args = None) as Hnone. - rewrite eval_addressing_preserved with (ge1 := ge). + assert (eval_addressing tge (Vptr sp0 Ptrofs.zero) addr (rs' ## args) = None). + rewrite eval_addressing_preserved with (ge1 := ge); eauto. apply eval_addressing_lessdef_none with (vl1 := rs ## args). apply regs_lessdef_regs; assumption. assumption. @@ -464,14 +462,7 @@ Proof. left; econstructor; econstructor; split. eapply exec_Iload_notrap1; eauto. eapply match_states_succ; eauto. apply set_reg_lessdef; auto. - } - { exploit eval_static_addressing_sound; eauto. - rewrite eval_addressing_preserved with (ge1 := ge). - apply eval_addressing_lessdef with (vl1 := rs ## args). - apply regs_lessdef_regs; assumption. - assumption. - exact symbols_preserved. - } + - (* Iload notrap2 *) rename pc'0 into pc. TransfInstr. assert (exists v2 : val, -- cgit From 35febfa5b231a71234a1b32c128169352e96eaca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 12:27:43 +0200 Subject: fixes for ARM --- arm/Asmexpand.ml | 27 +++++++++++++-------------- arm/Asmgen.v | 13 +++++++++---- arm/Asmgenproof.v | 7 +++++++ arm/Asmgenproof1.v | 8 +++++--- arm/Op.v | 40 ++++++++++++++++++++++++++++++++++++++++ backend/CSEproof.v | 12 +++--------- backend/Constpropproof.v | 12 ++++-------- backend/Inliningproof.v | 4 ++-- backend/Stackingproof.v | 5 +++-- 9 files changed, 86 insertions(+), 42 deletions(-) diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index a4ec0c5d..5d5779d4 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -18,7 +18,6 @@ open Asm open Asmexpandaux open AST open Camlcoq -open Integers exception Error of string @@ -104,7 +103,7 @@ let memcpy_small_arg sz arg tmp = (r, _0) | BA_addrstack ofs -> if offset_in_range ofs - && offset_in_range (Int.add ofs (Int.repr (Z.of_uint sz))) + && offset_in_range (Integers.Int.add ofs (Integers.Int.repr (Z.of_uint sz))) then (IR13, ofs) else begin expand_addimm tmp IR13 ofs; (tmp, _0) end | _ -> @@ -119,19 +118,19 @@ let expand_builtin_memcpy_small sz al src dst = if sz >= 8 && al >= 4 && !Clflags.option_ffpu then begin emit (Pfldd (FR7,rsrc,osrc)); emit (Pfstd (FR7,rdst,odst)); - copy (Int.add osrc _8) (Int.add odst _8) (sz - 8) + copy (Integers.Int.add osrc _8) (Integers.Int.add odst _8) (sz - 8) end else if sz >= 4 && al >= 4 then begin emit (Pldr (IR14,rsrc,SOimm osrc)); emit (Pstr (IR14,rdst,SOimm odst)); - copy (Int.add osrc _4) (Int.add odst _4) (sz - 4) + copy (Integers.Int.add osrc _4) (Integers.Int.add odst _4) (sz - 4) end else if sz >= 2 && al >= 2 then begin emit (Pldrh (IR14,rsrc,SOimm osrc)); emit (Pstrh (IR14,rdst,SOimm odst)); - copy (Int.add osrc _2) (Int.add odst _2) (sz - 2) + copy (Integers.Int.add osrc _2) (Integers.Int.add odst _2) (sz - 2) end else if sz >= 1 then begin emit (Pldrb (IR14,rsrc,SOimm osrc)); emit (Pstrb (IR14,rdst,SOimm odst)); - copy (Int.add osrc _1) (Int.add odst _1) (sz - 1) + copy (Integers.Int.add osrc _1) (Integers.Int.add odst _1) (sz - 1) end in copy osrc odst sz @@ -188,8 +187,8 @@ let expand_builtin_vload_common chunk base ofs res = | Mint32, BR(IR res) -> emit (Pldr (res, base, SOimm ofs)) | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> - let ofs_hi = if Archi.big_endian then ofs else Int.add ofs _4 in - let ofs_lo = if Archi.big_endian then Int.add ofs _4 else ofs in + let ofs_hi = if Archi.big_endian then ofs else Integers.Int.add ofs _4 in + let ofs_lo = if Archi.big_endian then Integers.Int.add ofs _4 else ofs in if base <> res2 then begin emit (Pldr (res2, base, SOimm ofs_lo)); emit (Pldr (res1, base, SOimm ofs_hi)) @@ -209,7 +208,7 @@ let expand_builtin_vload chunk args res = | [BA(IR addr)] -> expand_builtin_vload_common chunk addr _0 res | [BA_addrstack ofs] -> - if offset_in_range (Int.add ofs (Memdata.size_chunk chunk)) then + if offset_in_range (Integers.Int.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vload_common chunk IR13 ofs res else begin expand_addimm IR14 IR13 ofs; @@ -219,7 +218,7 @@ let expand_builtin_vload chunk args res = emit (Ploadsymbol (IR14,id,ofs)); expand_builtin_vload_common chunk IR14 _0 res | [BA_addptr(BA(IR addr), BA_int ofs)] -> - if offset_in_range (Int.add ofs (Memdata.size_chunk chunk)) then + if offset_in_range (Integers.Int.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vload_common chunk addr ofs res else begin expand_addimm IR14 addr ofs; @@ -237,8 +236,8 @@ let expand_builtin_vstore_common chunk base ofs src = | Mint32, BA(IR src) -> emit (Pstr (src, base, SOimm ofs)) | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> - let ofs_hi = if Archi.big_endian then ofs else Int.add ofs _4 in - let ofs_lo = if Archi.big_endian then Int.add ofs _4 else ofs in + let ofs_hi = if Archi.big_endian then ofs else Integers.Int.add ofs _4 in + let ofs_lo = if Archi.big_endian then Integers.Int.add ofs _4 else ofs in emit (Pstr (src2, base, SOimm ofs_lo)); emit (Pstr (src1, base, SOimm ofs_hi)) | Mfloat32, BA(FR src) -> @@ -253,7 +252,7 @@ let expand_builtin_vstore chunk args = | [BA(IR addr); src] -> expand_builtin_vstore_common chunk addr _0 src | [BA_addrstack ofs; src] -> - if offset_in_range (Int.add ofs (Memdata.size_chunk chunk)) then + if offset_in_range (Integers.Int.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vstore_common chunk IR13 ofs src else begin expand_addimm IR14 IR13 ofs; @@ -263,7 +262,7 @@ let expand_builtin_vstore chunk args = emit (Ploadsymbol (IR14,id,ofs)); expand_builtin_vstore_common chunk IR14 _0 src | [BA_addptr(BA(IR addr), BA_int ofs); src] -> - if offset_in_range (Int.add ofs (Memdata.size_chunk chunk)) then + if offset_in_range (Integers.Int.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vstore_common chunk addr ofs src else begin expand_addimm IR14 addr ofs; diff --git a/arm/Asmgen.v b/arm/Asmgen.v index 1a1e7f2f..016a1c5a 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -689,8 +689,12 @@ Definition transl_memory_access_float None mk_immed addr args k. -Definition transl_load (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: code) := +Definition transl_load (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: code) := + match trap with + | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on Arm") + | TRAP => match chunk with | Mint8signed => transl_memory_access_int Pldrsb mk_immed_mem_small dst addr args k @@ -708,6 +712,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) transl_memory_access_float Pfldd mk_immed_mem_float dst addr args k | _ => Error (msg "Asmgen.transl_load") + end end. Definition transl_store (chunk: memory_chunk) (addr: addressing) @@ -747,8 +752,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) else loadind_int IR13 f.(fn_link_ofs) IR12 c) | Mop op args res => transl_op op args res k - | Mload chunk addr args dst => - transl_load chunk addr args dst k + | Mload trap chunk addr args dst => + transl_load trap chunk addr args dst k | Mstore chunk addr args src => transl_store chunk addr args src k | Mcall sig (inl arg) => diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index 25f91d23..92ae524f 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -303,6 +303,7 @@ Proof. eapply tail_nolabel_trans. 2: eapply loadind_label; eauto. unfold loadind_int; TailNoLabel. eapply transl_op_label; eauto. unfold transl_load, transl_memory_access_int, transl_memory_access_float in H. + destruct t; try discriminate. destruct m; monadInv H; eapply transl_memory_access_label; eauto; simpl; auto. unfold transl_store, transl_memory_access_int, transl_memory_access_float in H. destruct m; monadInv H; eapply transl_memory_access_label; eauto; simpl; auto. @@ -618,6 +619,12 @@ Opaque loadind. split. eapply agree_set_undef_mreg; eauto. congruence. simpl; congruence. +- (* Mload notrap1 *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + +- (* Mload notrap *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + - (* Mstore *) assert (eval_addressing tge sp addr rs##args = Some a). rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 807e069d..7ef7b776 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -1540,8 +1540,8 @@ Proof. Qed. Lemma transl_load_correct: - forall chunk addr args dst k c (rs: regset) a m v, - transl_load chunk addr args dst k = OK c -> + forall trap chunk addr args dst k c (rs: regset) a m 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', @@ -1549,7 +1549,9 @@ Lemma transl_load_correct: /\ rs'#(preg_of dst) = v /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r. Proof. - intros. destruct chunk; simpl in H. + intros. + destruct trap; try (simpl in *; discriminate). + destruct chunk; simpl in H. eapply transl_load_int_correct; eauto. eapply transl_load_int_correct; eauto. eapply transl_load_int_correct; eauto. diff --git a/arm/Op.v b/arm/Op.v index cc90e043..9de365e9 100644 --- a/arm/Op.v +++ b/arm/Op.v @@ -975,6 +975,20 @@ Proof. apply Val.offset_ptr_inject; auto. Qed. +Lemma eval_addressing_inj_none: + forall addr sp1 vl1 sp2 vl2, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = None -> + eval_addressing ge2 sp2 addr vl2 = None. +Proof. + intros until vl2. intros Hglobal Hinjsp Hinjvl. + destruct addr; simpl in *; + inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate. +Qed. End EVAL_COMPAT. (** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) @@ -1080,6 +1094,19 @@ Proof. destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. +Lemma eval_addressing_lessdef_none: + forall sp addr vl1 vl2, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = None -> + eval_addressing genv sp addr vl2 = None. +Proof. + intros. rewrite val_inject_list_lessdef in H. + eapply eval_addressing_inj_none with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. +Qed. + End EVAL_LESSDEF. (** Compatibility of the evaluation functions with memory injections. *) @@ -1132,6 +1159,19 @@ Proof. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 684729d4..209fa40f 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -1151,9 +1151,7 @@ Proof. econstructor. split. eapply exec_Iload; eauto. - rewrite eval_addressing_preserved with (ge1 := ge). - exact Ha'1. - exact symbols_preserved. + try (rewrite eval_addressing_preserved with (ge1 := ge) by assumption). econstructor; eauto. eapply analysis_correct_1; eauto. simpl; eauto. @@ -1204,9 +1202,7 @@ Proof. { econstructor. split. eapply exec_Iload; eauto. - rewrite eval_addressing_preserved with (ge1 := ge). - exact Ha'1. - exact symbols_preserved. + try (rewrite eval_addressing_preserved with (ge1 := ge) by assumption). econstructor; eauto. eapply analysis_correct_1; eauto. simpl; eauto. @@ -1220,9 +1216,7 @@ Proof. { econstructor. split. eapply exec_Iload_notrap2; eauto. - rewrite eval_addressing_preserved with (ge1 := ge). - exact Ha'1. - exact symbols_preserved. + try (rewrite eval_addressing_preserved with (ge1 := ge) by assumption). econstructor; eauto. eapply analysis_correct_1; eauto. simpl; eauto. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 2e43a93f..4d104141 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -444,8 +444,8 @@ Proof. destruct (Mem.loadv_extends chunk m m' a v2 v MEM H1 Hlessdef2) as [vX [Hvx1 Hvx2]]. left; econstructor; econstructor; split. eapply exec_Iload with (a := v2); eauto. - erewrite eval_addressing_preserved with (ge1:=ge); auto. - exact symbols_preserved. + try (erewrite eval_addressing_preserved with (ge1:=ge); auto; + exact symbols_preserved). eapply match_states_succ; eauto. apply set_reg_lessdef; auto. } @@ -476,18 +476,14 @@ Proof. left; econstructor; econstructor; split. eapply exec_Iload; eauto. - rewrite eval_addressing_preserved with (ge1 := ge). - exact Heval'. - exact symbols_preserved. + try (rewrite eval_addressing_preserved with (ge1 := ge); eassumption). eapply match_states_succ; eauto. apply set_reg_lessdef; auto. } { left; econstructor; econstructor; split. eapply exec_Iload_notrap2; eauto. - rewrite eval_addressing_preserved with (ge1 := ge). - exact Heval'. - exact symbols_preserved. + try (rewrite eval_addressing_preserved with (ge1 := ge); eassumption). eapply match_states_succ; eauto. apply set_reg_lessdef; auto. } diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 588d7165..ebc48160 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -1017,7 +1017,7 @@ Proof. + left; econstructor; split. eapply plus_one. eapply exec_Iload; eauto. - rewrite <- P. apply eval_addressing_preserved. exact symbols_preserved. + try (rewrite <- P; apply eval_addressing_preserved; exact symbols_preserved). econstructor; eauto. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. @@ -1025,7 +1025,7 @@ Proof. + left; econstructor; split. eapply plus_one. eapply exec_Iload_notrap2; eauto. - rewrite <- P. apply eval_addressing_preserved. exact symbols_preserved. + try (rewrite <- P; apply eval_addressing_preserved; assumption). econstructor; eauto. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 1d4a93e7..19a40e0f 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -1943,7 +1943,7 @@ Proof. { econstructor; split. apply plus_one. apply exec_Mload with (a:=a') (v:=v'); eauto. - rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + try (rewrite <- A; apply eval_addressing_preserved; assumption). econstructor; eauto with coqlib. apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto. @@ -1951,7 +1951,8 @@ Proof. { econstructor; split. apply plus_one. apply exec_Mload_notrap2 with (a:=a'); eauto. - rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. + try (rewrite <- A; apply eval_addressing_preserved; assumption). + econstructor; eauto with coqlib. apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto. -- cgit From 4cdd085383c5e18989b8636455ddcfc7ceb5843a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 13:12:39 +0200 Subject: fixes for compiling on other platforms --- backend/CSEproof.v | 6 +++--- backend/Constpropproof.v | 4 ++-- backend/Inliningproof.v | 2 +- backend/Stackingproof.v | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 209fa40f..5bbb7508 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -1151,7 +1151,7 @@ Proof. econstructor. split. eapply exec_Iload; eauto. - try (rewrite eval_addressing_preserved with (ge1 := ge) by assumption). + try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved). econstructor; eauto. eapply analysis_correct_1; eauto. simpl; eauto. @@ -1202,7 +1202,7 @@ Proof. { econstructor. split. eapply exec_Iload; eauto. - try (rewrite eval_addressing_preserved with (ge1 := ge) by assumption). + try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved). econstructor; eauto. eapply analysis_correct_1; eauto. simpl; eauto. @@ -1216,7 +1216,7 @@ Proof. { econstructor. split. eapply exec_Iload_notrap2; eauto. - try (rewrite eval_addressing_preserved with (ge1 := ge) by assumption). + try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved). econstructor; eauto. eapply analysis_correct_1; eauto. simpl; eauto. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 4d104141..63cfee24 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -476,14 +476,14 @@ Proof. left; econstructor; econstructor; split. eapply exec_Iload; eauto. - try (rewrite eval_addressing_preserved with (ge1 := ge); eassumption). + try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved). eapply match_states_succ; eauto. apply set_reg_lessdef; auto. } { left; econstructor; econstructor; split. eapply exec_Iload_notrap2; eauto. - try (rewrite eval_addressing_preserved with (ge1 := ge); eassumption). + try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved). eapply match_states_succ; eauto. apply set_reg_lessdef; auto. } diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index ebc48160..b60c1cb7 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -1025,7 +1025,7 @@ Proof. + left; econstructor; split. eapply plus_one. eapply exec_Iload_notrap2; eauto. - try (rewrite <- P; apply eval_addressing_preserved; assumption). + try (rewrite <- P; apply eval_addressing_preserved; exact symbols_preserved). econstructor; eauto. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 19a40e0f..d3fcdb91 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -1943,7 +1943,7 @@ Proof. { econstructor; split. apply plus_one. apply exec_Mload with (a:=a') (v:=v'); eauto. - try (rewrite <- A; apply eval_addressing_preserved; assumption). + try (rewrite <- A; apply eval_addressing_preserved; auto; exact symbols_preserved). econstructor; eauto with coqlib. apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto. @@ -1951,7 +1951,7 @@ Proof. { econstructor; split. apply plus_one. apply exec_Mload_notrap2 with (a:=a'); eauto. - try (rewrite <- A; apply eval_addressing_preserved; assumption). + try (rewrite <- A; apply eval_addressing_preserved; auto; exact symbols_preserved). econstructor; eauto with coqlib. apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto. -- cgit From d84a003dc41c1ce572e86f399f5a610a78eda15f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 13:48:11 +0200 Subject: PowerPC compiles --- powerpc/Asmexpand.ml | 31 +++++++++++++++---------------- powerpc/Asmgen.v | 14 ++++++++++---- powerpc/Asmgenproof.v | 8 ++++++++ powerpc/Asmgenproof1.v | 5 +++-- powerpc/Op.v | 42 ++++++++++++++++++++++++++++++++++++++++++ riscV/Op.v | 26 ++++++++++++++++++++++++++ 6 files changed, 104 insertions(+), 22 deletions(-) diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index 5ca4c611..0ef0a21e 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -14,7 +14,6 @@ of the PPC assembly code. *) open Camlcoq -open Integers open AST open Asm open Asmexpandaux @@ -89,7 +88,7 @@ let expand_annot_val kind txt targ args res = Note that lfd and stfd cannot trap on ill-formed floats. *) let offset_in_range ofs = - Int.eq (Asmgen.high_s ofs) _0 + Integers.Int.eq (Asmgen.high_s ofs) _0 let memcpy_small_arg sz arg tmp = match arg with @@ -97,7 +96,7 @@ let memcpy_small_arg sz arg tmp = (r, _0) | BA_addrstack ofs -> if offset_in_range ofs - && offset_in_range (Int.add ofs (Int.repr (Z.of_uint sz))) + && offset_in_range (Integers.Int.add ofs (Integers.Int.repr (Z.of_uint sz))) then (GPR1, ofs) else begin emit_addimm tmp GPR1 ofs; (tmp, _0) end | _ -> @@ -112,19 +111,19 @@ let expand_builtin_memcpy_small sz al src dst = if sz >= 8 && al >= 4 && !Clflags.option_ffpu then begin emit (Plfd(FPR13, Cint osrc, rsrc)); emit (Pstfd(FPR13, Cint odst, rdst)); - copy (Int.add osrc _8) (Int.add odst _8) (sz - 8) + copy (Integers.Int.add osrc _8) (Integers.Int.add odst _8) (sz - 8) end else if sz >= 4 then begin emit (Plwz(GPR0, Cint osrc, rsrc)); emit (Pstw(GPR0, Cint odst, rdst)); - copy (Int.add osrc _4) (Int.add odst _4) (sz - 4) + copy (Integers.Int.add osrc _4) (Integers.Int.add odst _4) (sz - 4) end else if sz >= 2 then begin emit (Plhz(GPR0, Cint osrc, rsrc)); emit (Psth(GPR0, Cint odst, rdst)); - copy (Int.add osrc _2) (Int.add odst _2) (sz - 2) + copy (Integers.Int.add osrc _2) (Integers.Int.add odst _2) (sz - 2) end else if sz >= 1 then begin emit (Plbz(GPR0, Cint osrc, rsrc)); emit (Pstb(GPR0, Cint odst, rdst)); - copy (Int.add osrc _1) (Int.add odst _1) (sz - 1) + copy (Integers.Int.add osrc _1) (Integers.Int.add odst _1) (sz - 1) end in copy osrc odst sz @@ -134,7 +133,7 @@ let memcpy_big_arg arg tmp = | BA (IR r) -> emit (Paddi(tmp, r, Cint _m4)) | BA_addrstack ofs -> - emit_addimm tmp GPR1 (Int.add ofs _m4) + emit_addimm tmp GPR1 (Integers.Int.add ofs _m4) | _ -> assert false @@ -227,10 +226,10 @@ let expand_volatile_access let offset_constant cst delta = match cst with | Cint n -> - let n' = Int.add n delta in + let n' = Integers.Int.add n delta in if offset_in_range n' then Some (Cint n') else None | Csymbol_sda(id, ofs) -> - Some (Csymbol_sda(id, Int.add ofs delta)) + Some (Csymbol_sda(id, Integers.Int.add ofs delta)) | _ -> None let expand_load_int64 hi lo base ofs_hi ofs_lo = @@ -438,7 +437,7 @@ let expand_integer_cond_move a1 a2 a3 res = if a2 = a3 then emit (Pmr (res, a2)) else if eref then begin - emit (Pcmpwi (a1,Cint (Int.zero))); + emit (Pcmpwi (a1,Cint (Integers.Int.zero))); emit (Pisel (res,a3,a2,CRbit_2)) end else begin (* a1 has type _Bool, hence it is 0 or 1 *) @@ -683,23 +682,23 @@ let expand_builtin_inline name args res = | "__builtin_icbi", [BA(IR a1)],_ -> emit (Picbi(GPR0,a1)) | "__builtin_dcbtls", [BA (IR a1); BA_int loc],_ -> - if not ((Int.eq loc _0) || (Int.eq loc _2)) then + if not ((Integers.Int.eq loc _0) || (Integers.Int.eq loc _2)) then raise (Error "the second argument of __builtin_dcbtls must be 0 or 2"); emit (Pdcbtls (loc,GPR0,a1)) | "__builtin_dcbtls",_,_ -> raise (Error "the second argument of __builtin_dcbtls must be a constant") | "__builtin_icbtls", [BA (IR a1); BA_int loc],_ -> - if not ((Int.eq loc _0) || (Int.eq loc _2)) then + if not ((Integers.Int.eq loc _0) || (Integers.Int.eq loc _2)) then raise (Error "the second argument of __builtin_icbtls must be 0 or 2"); emit (Picbtls (loc,GPR0,a1)) | "__builtin_icbtls",_,_ -> raise (Error "the second argument of __builtin_icbtls must be a constant") | "__builtin_prefetch" , [BA (IR a1) ;BA_int rw; BA_int loc],_ -> - if not (Int.ltu loc _4) then + if not (Integers.Int.ltu loc _4) then raise (Error "the last argument of __builtin_prefetch must be 0, 1 or 2"); - if Int.eq rw _0 then begin + if Integers.Int.eq rw _0 then begin emit (Pdcbt (loc,GPR0,a1)); - end else if Int.eq rw _1 then begin + end else if Integers.Int.eq rw _1 then begin emit (Pdcbtst (loc,GPR0,a1)); end else raise (Error "the second argument of __builtin_prefetch must be 0 or 1") diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index a686414a..29e2c028 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -783,8 +783,13 @@ Definition transl_memory_access Error(msg "Asmgen.transl_memory_access") end. -Definition transl_load (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: code) := +Definition transl_load + (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: code) := + match trap with + | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on PPC") + | TRAP => match chunk with | Mint8signed => do r <- ireg_of dst; @@ -812,6 +817,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) transl_memory_access (Plfd r) (Plfdx r) addr args GPR12 k | _ => Error (msg "Asmgen.transl_load") + end end. Definition transl_store (chunk: memory_chunk) (addr: addressing) @@ -869,8 +875,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) loadind GPR1 f.(fn_link_ofs) Tint R11 k1) | Mop op args res => transl_op op args res k - | Mload chunk addr args dst => - transl_load chunk addr args dst k + | Mload trap chunk addr args dst => + transl_load trap chunk addr args dst k | Mstore chunk addr args src => transl_store chunk addr args src k | Mcall sig (inl r) => diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index d653633c..21d5ce48 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -328,6 +328,7 @@ Proof. eapply loadind_label; eauto. eapply tail_nolabel_trans; eapply loadind_label; eauto. eapply transl_op_label; eauto. + destruct t; try discriminate. destruct m; monadInv H; (eapply tail_nolabel_trans; [eapply transl_memory_access_label; TailNoLabel|TailNoLabel]). destruct m; monadInv H; eapply transl_memory_access_label; TailNoLabel. destruct s0; monadInv H; TailNoLabel. @@ -657,6 +658,13 @@ Opaque loadind. split. simpl; congruence. apply R; auto with asmgen. + +- (* Mload notrap *) (* isn't there a nicer way? *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + +- (* Mload notrap *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + - (* Mstore *) assert (eval_addressing tge sp addr rs##args = Some a). rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 884d5366..6ceb7f85 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -1677,8 +1677,8 @@ Qed. (** Translation of loads *) Lemma transl_load_correct: - forall chunk addr args dst k c (rs: regset) m a v, - transl_load chunk addr args dst k = OK c -> + forall trap chunk addr args dst k c (rs: regset) m a v, + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', @@ -1687,6 +1687,7 @@ Lemma transl_load_correct: /\ forall r, r <> PC -> r <> GPR12 -> r <> GPR0 -> r <> preg_of dst -> rs' r = rs r. Proof. intros. + destruct trap; try discriminate. assert (LD: forall v, Val.lessdef a v -> v = a). { intros. inv H2; auto. discriminate H1. } assert (BASE: forall mk1 mk2 k' chunk' v', diff --git a/powerpc/Op.v b/powerpc/Op.v index 0f082c1f..cbd0291b 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -1032,6 +1032,21 @@ Proof. apply Val.add_inject; auto. apply H; simpl; 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 *; + inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate. +Qed. End EVAL_COMPAT. (** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) @@ -1098,6 +1113,20 @@ Proof. rewrite <- val_inject_list_lessdef. eauto. 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 *; + inv Hlessdef; trivial; try discriminate; + inv H0; trivial; try discriminate; + inv H2; trivial; try discriminate. +Qed. + Lemma eval_operation_lessdef: forall sp op vl1 vl2 v1 m1 m2, Val.lessdef_list vl1 vl2 -> @@ -1189,6 +1218,19 @@ Proof. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> diff --git a/riscV/Op.v b/riscV/Op.v index bb04f786..73d3f543 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -1159,6 +1159,20 @@ Proof. apply Val.offset_ptr_inject; auto. Qed. +Lemma eval_addressing_inj_none: + forall addr sp1 vl1 sp2 vl2, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = None -> + eval_addressing ge2 sp2 addr vl2 = None. +Proof. + intros until vl2. intros Hglobal Hinjsp Hinjvl. + destruct addr; simpl in *; + inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate. +Qed. End EVAL_COMPAT. (** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) @@ -1265,6 +1279,18 @@ Proof. destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. +Lemma eval_addressing_lessdef_none: + forall sp addr vl1 vl2, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = None -> + eval_addressing genv sp addr vl2 = None. +Proof. + intros until vl2. intros Hlessdef Heval1. + destruct addr; simpl in *; + inv Hlessdef; trivial; try discriminate; + inv H0; trivial; try discriminate; + inv H2; trivial; try discriminate. +Qed. End EVAL_LESSDEF. (** Compatibility of the evaluation functions with memory injections. *) -- cgit From 54846ce3ee63b8fff66ac5bf27d1c89ac701ed94 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 14:20:34 +0200 Subject: fix for Risc-V --- riscV/Asmgen.v | 13 +++++++++---- riscV/Asmgenproof.v | 8 +++++++- riscV/Asmgenproof1.v | 7 ++++--- riscV/Op.v | 14 ++++++++++++++ 4 files changed, 34 insertions(+), 8 deletions(-) diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index a704ed74..ecaca7b3 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -770,9 +770,13 @@ Definition transl_memory_access Error(msg "Asmgen.transl_memory_access") end. -Definition transl_load (chunk: memory_chunk) (addr: addressing) +Definition transl_load (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: code) := - match chunk with + match trap with + | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on Arm") + | TRAP => + match chunk with | Mint8signed => do r <- ireg_of dst; transl_memory_access (Plb r) addr args k @@ -799,6 +803,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) transl_memory_access (Pfld r) addr args k | _ => Error (msg "Asmgen.transl_load") + end end. Definition transl_store (chunk: memory_chunk) (addr: addressing) @@ -848,8 +853,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) else loadind_ptr SP f.(fn_link_ofs) X30 c) | Mop op args res => transl_op op args res k - | Mload chunk addr args dst => - transl_load chunk addr args dst k + | Mload trap chunk addr args dst => + transl_load trap chunk addr args dst k | Mstore chunk addr args src => transl_store chunk addr args src k | Mcall sig (inl r) => diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 5ec57886..e2fafb16 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -359,7 +359,7 @@ Proof. - destruct ep. eapply loadind_label; eauto. eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. - eapply transl_op_label; eauto. -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct t; (try discriminate); destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). @@ -725,6 +725,12 @@ Local Transparent destroyed_by_op. intros; auto with asmgen. simpl; congruence. +- (* Mload notrap *) (* isn't there a nicer way? *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + +- (* Mload notrap *) + inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. + - (* Mstore *) assert (eval_addressing tge sp addr (map rs args) = Some a). rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 98d5bd33..175e484f 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1318,8 +1318,8 @@ Proof. Qed. Lemma transl_load_correct: - forall chunk addr args dst k c (rs: regset) m a v, - transl_load chunk addr args dst k = OK c -> + forall trap chunk addr args dst k c (rs: regset) m a v, + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', @@ -1327,7 +1327,8 @@ Lemma transl_load_correct: /\ rs'#(preg_of dst) = v /\ forall r, r <> PC -> r <> X31 -> r <> preg_of dst -> rs'#r = rs#r. Proof. - intros until v; intros TR EV LOAD. + intros until v; intros TR EV LOAD. + destruct trap; try (simpl in *; discriminate). assert (A: exists mk_instr, transl_memory_access mk_instr addr args k = OK c /\ forall base ofs rs, diff --git a/riscV/Op.v b/riscV/Op.v index 73d3f543..97bc301a 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -1343,6 +1343,20 @@ Proof. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. + +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> -- cgit From 68da36573f9e6e0109095eb74da5f5ec74202b8e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 16:16:53 +0200 Subject: moving forward on K1C --- mppa_k1c/Asm.v | 82 +++++++++++++++++----------------- mppa_k1c/Asmblock.v | 6 +-- mppa_k1c/Asmblockdeps.v | 103 +++++++++++++++++++++++++++---------------- mppa_k1c/Asmblockgen.v | 38 +++++++--------- mppa_k1c/Asmblockgenproof0.v | 30 +++++++------ mppa_k1c/Asmblockgenproof1.v | 54 ++++++++--------------- mppa_k1c/Asmvliw.v | 49 +++++++++++++------- mppa_k1c/Peephole.v | 9 ++-- 8 files changed, 200 insertions(+), 171 deletions(-) diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f09aa99c..e37176ef 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -107,16 +107,16 @@ Inductive instruction : Type := | Pstsud (rd rs1 rs2: ireg) (** Loads **) - | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) - | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) - | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) - | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) - | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) - | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) - | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) - | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) - | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) - | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) @@ -481,41 +481,41 @@ Definition basic_to_instruction (b: basic) := | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm (** Load *) - | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) - | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro) - | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro) - | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro) - - | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro) + | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) + + | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) (** Store *) | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9b4489c5..91e5ac89 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -260,11 +260,11 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := parexec (** Auxiliaries for memory accesses *) -Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset chunk rs rs m m d a ofs. +Definition exec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset trap chunk rs rs m m d a ofs. -Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg chunk rs rs m m d a ro. +Definition exec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg trap chunk rs rs m m d a ro. -Definition exec_load_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs chunk rs rs m m d a ro. +Definition exec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs trap chunk rs rs m m d a ro. Definition exec_load_q_offset (rs: regset) (m: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := parexec_load_q_offset rs rs m m d a ofs. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c4c1bbf1..65792d13 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -83,9 +83,9 @@ Coercion OArithRRI32: arith_name_rri32 >-> Funclass. Coercion OArithRRI64: arith_name_rri64 >-> Funclass. Inductive load_op := - | OLoadRRO (n: load_name) (ofs: offset) - | OLoadRRR (n: load_name) - | OLoadRRRXS (n: load_name) + | OLoadRRO (n: load_name) (trap: trapping_mode) (ofs: offset) + | OLoadRRR (n: load_name) (trap: trapping_mode) + | OLoadRRRXS (n: load_name) (trap: trapping_mode) . Coercion OLoadRRO: load_name >-> Funclass. @@ -142,33 +142,39 @@ Definition arith_eval (ao: arith_op) (l: list value) := | _, _ => None end. -Definition exec_load_deps_offset (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := +Definition exec_incorrect_load trap chunk := + match trap with + | TRAP => None + | NOTRAP => Some (Val (concrete_default_notrap_load_value chunk)) + end. + +Definition exec_load_deps_offset (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := let (ge, fn) := Ge in match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end | _ => None end. -Definition exec_load_deps_reg (chunk: memory_chunk) (m: mem) (v vo: val) := +Definition exec_load_deps_reg (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := match Mem.loadv chunk m (Val.addl v vo) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end. -Definition exec_load_deps_regxs (chunk: memory_chunk) (m: mem) (v vo: val) := +Definition exec_load_deps_regxs (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := match Mem.loadv chunk m (Val.addl v (Val.shll vo (scale_of_chunk chunk))) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end. Definition load_eval (lo: load_op) (l: list value) := match lo, l with - | OLoadRRO n ofs, [Val v; Memstate m] => exec_load_deps_offset (load_chunk n) m v ofs - | OLoadRRR n, [Val v; Val vo; Memstate m] => exec_load_deps_reg (load_chunk n) m v vo - | OLoadRRRXS n, [Val v; Val vo; Memstate m] => exec_load_deps_regxs (load_chunk n) m v vo + | OLoadRRO n trap ofs, [Val v; Memstate m] => exec_load_deps_offset trap (load_chunk n) m v ofs + | OLoadRRR n trap, [Val v; Val vo; Memstate m] => exec_load_deps_reg trap (load_chunk n) m v vo + | OLoadRRRXS n trap, [Val v; Val vo; Memstate m] => exec_load_deps_regxs trap (load_chunk n) m v vo | _, _ => None end. @@ -364,24 +370,47 @@ Proof. Qed. Hint Resolve offset_eq_correct: wlp. +Definition trapping_mode_eq trap1 trap2 := + RET (match trap1, trap2 with + | TRAP, TRAP | NOTRAP, NOTRAP => true + | TRAP, NOTRAP | NOTRAP, TRAP => false + end). +Lemma trapping_mode_eq_correct t1 t2: + WHEN trapping_mode_eq t1 t2 ~> b THEN b = true -> t1 = t2. +Proof. + wlp_simplify. + destruct t1; destruct t2; trivial; discriminate. +Qed. +Hint Resolve trapping_mode_eq_correct: wlp. + Definition load_op_eq (o1 o2: load_op): ?? bool := match o1 with - | OLoadRRO n1 ofs1 => - match o2 with OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (offset_eq ofs1 ofs2) | _ => RET false end - | OLoadRRR n1 => - match o2 with OLoadRRR n2 => phys_eq n1 n2 | _ => RET false end - | OLoadRRRXS n1 => - match o2 with OLoadRRRXS n2 => phys_eq n1 n2 | _ => RET false end + | OLoadRRO n1 trap ofs1 => + match o2 with + | OLoadRRO n2 trap2 ofs2 => iandb (phys_eq n1 n2) (iandb (offset_eq ofs1 ofs2) (trapping_mode_eq trap trap2)) + | _ => RET false + end + | OLoadRRR n1 trap => + match o2 with + | OLoadRRR n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end + | OLoadRRRXS n1 trap => + match o2 with + | OLoadRRRXS n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end end. Lemma load_op_eq_correct o1 o2: WHEN load_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. Proof. destruct o1, o2; wlp_simplify; try discriminate. - - f_equal. pose (Ptrofs.eq_spec ofs ofs0). - rewrite H in *. trivial. - - congruence. - - congruence. + { f_equal. + destruct trap, trap0; simpl in *; trivial; discriminate. + pose (Ptrofs.eq_spec ofs ofs0). + rewrite H in *. trivial. } + all: destruct trap, trap0; simpl in *; trivial; discriminate. Qed. Hint Resolve load_op_eq_correct: wlp. Opaque load_op_eq_correct. @@ -617,21 +646,21 @@ Definition trans_arith (ai: ar_instruction) : inst := Definition trans_basic (b: basic) : inst := match b with | PArith ai => trans_arith ai - | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (PReg (#a) @ PReg pmem @ Enil))] - | PLoadRRR n d a ro => [(#d, Op (Load (OLoadRRR n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] - | PLoadRRRXS n d a ro => [(#d, Op (Load (OLoadRRRXS n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PLoadRRO trap n d a ofs => [(#d, Op (Load (OLoadRRO n trap ofs)) (PReg (#a) @ PReg pmem @ Enil))] + | PLoadRRR trap n d a ro => [(#d, Op (Load (OLoadRRR n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PLoadRRRXS trap n d a ro => [(#d, Op (Load (OLoadRRRXS n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))] | PLoadQRRO qd a ofs => let (d0, d1) := gpreg_q_expand qd in - [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] | PLoadORRO od a ofs => match gpreg_o_expand od with | (d0, d1, d2, d3) => - [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d2, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d3, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d2, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d3, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] end | PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] | PStoreRRRXS n s a ro => [(pmem, Op (Store (OStoreRRRXS n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] @@ -861,21 +890,21 @@ Local Ltac preg_eq_discr r rd := unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; unfold eval_offset; simpl; auto; - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Load Reg *) + destruct i; simpl load_chunk. all: unfold parexec_load_reg; simpl; unfold exec_load_deps_reg; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Load Reg XS *) + destruct i; simpl load_chunk. all: unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. @@ -1537,9 +1566,9 @@ Definition string_of_load_name (n: load_name) : pstring := Definition string_of_load (op: load_op): pstring := match op with - | OLoadRRO n _ => string_of_load_name n - | OLoadRRR n => string_of_load_name n - | OLoadRRRXS n => string_of_load_name n + | OLoadRRO n _ _ => string_of_load_name n + | OLoadRRR n _ => string_of_load_name n + | OLoadRRRXS n _ => string_of_load_name n end. Definition string_of_store_name (n: store_name) : pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index cd9b3202..fd50f3b4 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -912,12 +912,12 @@ end. Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := match ty, preg_of dst with - | Tint, IR rd => OK (indexed_memory_access (PLoadRRO Plw rd) base ofs ::i k) - | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO Pld rd) base ofs ::i k) - | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO Pfls rd) base ofs ::i k) - | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO Pfld rd) base ofs ::i k) - | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO Plw_a rd) base ofs ::i k) - | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO Pld_a rd) base ofs ::i k) + | Tint, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfls rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfld rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld_a rd) base ofs ::i k) | _, _ => Error (msg "Asmblockgen.loadind") end. @@ -933,7 +933,7 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) end. Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := - indexed_memory_access (PLoadRRO Pld dst) base ofs. + indexed_memory_access (PLoadRRO TRAP Pld dst) base ofs. Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := indexed_memory_access (PStoreRRO Psd src) base ofs. @@ -993,32 +993,28 @@ Definition chunk2load (chunk: memory_chunk) := | Many64 => Pld_a end. -Definition transl_load_rro (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rro (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access (PLoadRRO (chunk2load chunk) r) addr args k. + transl_memory_access (PLoadRRO trap (chunk2load chunk) r) addr args k. -Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rrr (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2 (PLoadRRR (chunk2load chunk) r) addr args k. + transl_memory_access2 (PLoadRRR trap (chunk2load chunk) r) addr args k. -Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) +Definition transl_load_rrrXS (trap: trapping_mode) (chunk: memory_chunk) (scale : Z) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2XS chunk (PLoadRRRXS (chunk2load chunk) r) scale args k. + transl_memory_access2XS chunk (PLoadRRRXS trap (chunk2load chunk) r) scale args k. Definition transl_load (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - match trap with - | NOTRAP => Error(msg "Asmblockgen.transl_load NOTRAP TODO") - | TRAP => - match addr with - | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k - | Aindexed2 => transl_load_rrr chunk addr args dst k - | _ => transl_load_rro chunk addr args dst k - end + match addr with + | Aindexed2XS scale => transl_load_rrrXS trap chunk scale args dst k + | Aindexed2 => transl_load_rrr trap chunk addr args dst k + | _ => transl_load_rro trap chunk addr args dst k end. Definition chunk2store (chunk: memory_chunk) := diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index decc3e2e..07c445e2 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -897,34 +897,36 @@ Lemma exec_basic_instr_pc: Proof. intros. destruct b; try destruct i; try destruct i. all: try (inv H; Simpl). - 1-10: try (unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_load_reg in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). - 1-10: try (unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. - 1-10: try (unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. - - (* PLoadQRRO *) + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) unfold parexec_load_q_offset in H1. destruct (gpreg_q_expand _) as [r0 r1] in H1. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. - - (* PLoadORRO *) + inv H1. Simpl. } + { (* PLoadORRO *) unfold parexec_load_o_offset in H1. destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. - - (* PStoreQRRO *) + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) unfold parexec_store_q_offset in H1. destruct (gpreg_q_expand _) as [r0 r1] in H1. unfold eval_offset in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. - - (* PStoreORRO *) + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) unfold parexec_store_o_offset in H1. destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. unfold eval_offset in H1; try discriminate. @@ -932,7 +934,7 @@ Proof. destruct (Mem.storev _ _ _) in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. + inv H1. Simpl. reflexivity. } - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index ce01041d..68f21541 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1661,9 +1661,9 @@ Qed. Lemma indexed_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) rd m, + forall trap chunk (mk_instr: ireg -> offset -> basic) rd m, (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> forall (base: ireg) ofs k (rs: regset) v, Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> exists rs', @@ -1716,7 +1716,7 @@ Proof. /\ c = indexed_memory_access mk_instr base ofs :: k /\ forall base' ofs' rs', exec_basic_instr ge (mk_instr base' ofs') rs' m = - exec_load_offset (chunk_of_type ty) rs' m rd base' ofs'). + exec_load_offset TRAP (chunk_of_type ty) rs' m rd base' ofs'). { unfold loadind in TR. destruct ty, (preg_of dst); inv TR; econstructor; esplit; eauto. } destruct A as (mk_instr & rd & rdEq & B & C). subst c. rewrite rdEq. @@ -1784,7 +1784,9 @@ Lemma loadind_ptr_correct: /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. intros. eapply indexed_load_access_correct; eauto with asmgen. - intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. auto. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. + instantiate (1 := TRAP). + auto. Qed. Lemma storeind_ptr_correct: @@ -1877,11 +1879,11 @@ Proof. Qed. Lemma transl_load_access2_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', + forall trap chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> ireg_of mro = OK ro -> (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro) -> + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro) -> transl_memory_access2 mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -1900,11 +1902,11 @@ Proof. Qed. Lemma transl_load_access2XS_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', + forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> ireg_of mro = OK ro -> (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro) -> + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro) -> transl_memory_access2XS chunk mk_instr scale args k = OK c -> eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -1926,9 +1928,9 @@ Proof. Qed. Lemma transl_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', + forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> transl_memory_access mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -1956,22 +1958,17 @@ Lemma transl_load_memory_access_ok: preg_of dst = IR rd /\ transl_memory_access mk_instr addr args k = OK c /\ forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs. + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs. Proof. - destruct trap. - { (* TRAP *) intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity | eauto ]. - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity | eauto ]. - } - intros until m. intros ADDR TR ? ?. - monadInv TR. Qed. Lemma transl_load_memory_access2_ok: @@ -1986,21 +1983,14 @@ Lemma transl_load_memory_access2_ok: /\ preg_of mro = IR ro /\ transl_memory_access2 mk_instr addr args k = OK c /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro. + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro. Proof. - destruct trap. - { (* TRAP *) intros until m. intros ? TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ x)); simpl; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity | eauto]. - } - { (* NOTRAP *) - intros until m. intros ? TR ? ?. - unfold transl_load in TR. subst. monadInv TR. - } Qed. Lemma transl_load_memory_access2XS_ok: @@ -2014,20 +2004,14 @@ Lemma transl_load_memory_access2XS_ok: /\ preg_of mro = IR ro /\ transl_memory_access2XS chunk mk_instr scale args k = OK c /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro. + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro. Proof. - destruct trap. - { (* TRAP *) intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ x)); simpl; rewrite Heqb; eauto + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto | eauto]. - } - { (* NOTRAP *) - intros until m. intros TR ? ?. - unfold transl_load in TR. subst. monadInv TR. } Qed. Lemma transl_load_correct: diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 54654abb..bfe9d77b 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -313,6 +313,16 @@ Inductive cf_instruction : Type := . (** Loads **) +Definition concrete_default_notrap_load_value chunk := + match chunk with + | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned + | Mint32 => Vint Int.zero + | Mint64 => Vlong Int64.zero + | Many32 | Many64 => Vundef + | Mfloat32 => Vsingle Float32.zero + | Mfloat64 => Vfloat Float.zero + end. + Inductive load_name : Type := | Plb (**r load byte *) | Plbu (**r load byte unsigned *) @@ -327,9 +337,9 @@ Inductive load_name : Type := . Inductive ld_instruction : Type := - | PLoadRRO (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) - | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) - | PLoadRRRXS (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRO (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) + | PLoadRRR (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRRXS (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) | PLoadQRRO (rd: gpreg_q) (ra: ireg) (ofs: offset) | PLoadORRO (rd: gpreg_o) (ra: ireg) (ofs: offset) . @@ -1215,10 +1225,16 @@ Definition eval_offset (ofs: offset) : res ptrofs := OK ofs. (** * load/store *) -Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := +Definition parexec_incorrect_load trap chunk d rsw mw := + match trap with + | TRAP => Stuck + | NOTRAP => Next (rsw#d <- (concrete_default_notrap_load_value chunk)) mw + end. + +Definition parexec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end | _ => Stuck @@ -1263,15 +1279,15 @@ Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a end end. -Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := +Definition parexec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := match Mem.loadv chunk mr (Val.addl (rsr a) (rsr ro)) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end. -Definition parexec_load_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := +Definition parexec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := match Mem.loadv chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end. @@ -1284,7 +1300,8 @@ Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: | _ => Stuck end. -Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := +Definition parexec_store_reg + (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := match Mem.storev chunk mr (Val.addl (rsr a) (rsr ro)) (rsr s) with | None => Stuck | Some m' => Next rsw m' @@ -1342,7 +1359,7 @@ Definition load_chunk n := | Pfls => Mfloat32 | Pfld => Mfloat64 end. - + Definition store_chunk n := match n with | Psb => Mint8unsigned @@ -1361,12 +1378,12 @@ Definition bstep (bi: basic) (rsr rsw: regset) (mr mw: mem) := match bi with | PArith ai => Next (parexec_arith_instr ai rsr rsw) mw - | PLoadRRO n d a ofs => parexec_load_offset (load_chunk n) rsr rsw mr mw d a ofs - | PLoadRRR n d a ro => parexec_load_reg (load_chunk n) rsr rsw mr mw d a ro - | PLoadRRRXS n d a ro => parexec_load_regxs (load_chunk n) rsr rsw mr mw d a ro - | PLoadQRRO d a ofs => + | PLoad (PLoadRRO trap n d a ofs) => parexec_load_offset trap (load_chunk n) rsr rsw mr mw d a ofs + | PLoad (PLoadRRR trap n d a ro) => parexec_load_reg trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadRRRXS trap n d a ro) => parexec_load_regxs trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadQRRO d a ofs) => parexec_load_q_offset rsr rsw mr mw d a ofs - | PLoadORRO d a ofs => + | PLoad (PLoadORRO d a ofs) => parexec_load_o_offset rsr rsw mr mw d a ofs | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 7c8f65a8..0611fdda 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -2,6 +2,7 @@ Require Import Coqlib. Require Import Asmvliw. Require Import Values. Require Import Integers. +Require Import AST. Require Compopts. Definition gpreg_q_list : list gpreg_q := @@ -89,8 +90,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := | None => h0 :: (coalesce_mem t0) end - | (PLoadRRO Pld_a rd0 ra0 ofs0), - (PLoadRRO Pld_a rd1 ra1 ofs1) => + | (PLoad (PLoadRRO TRAP Pld_a rd0 ra0 ofs0)), + (PLoad (PLoadRRO TRAP Pld_a rd1 ra1 ofs1)) => match gpreg_q_search rd0 rd1 with | Some rd0rd1 => let zofs0 := Ptrofs.signed ofs0 in @@ -100,8 +101,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := if coalesce_octuples then match t1 with - | (PLoadRRO Pld_a rd2 ra2 ofs2) :: - (PLoadRRO Pld_a rd3 ra3 ofs3) :: t3 => + | (PLoad (PLoadRRO TRAP Pld_a rd2 ra2 ofs2)) :: + (PLoad (PLoadRRO TRAP Pld_a rd3 ra3 ofs3)) :: t3 => match gpreg_o_search rd0 rd1 rd2 rd3 with | Some octuple => let zofs2 := Ptrofs.signed ofs2 in -- cgit From 22e78b34ca993e0ff1f79c943b16122b1067bd74 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:22:40 +0200 Subject: further --- mppa_k1c/Asmblockgenproof.v | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 828e4665..67f02520 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,9 +1204,26 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. - - (* MBload notrap1 TODO *) - simpl in EQ0. - discriminate. + - simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = None). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef_none. eapply preg_vals; eauto. eassumption. + intros Haddr. rewrite (sp_val _ _ _ AG) in Haddr. + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl; congruence. - (* MBload notrap2 TODO *) simpl in EQ0. -- cgit From 2b2ad7fc33fecfd77598e485ae0af82be3f23471 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:40:56 +0200 Subject: moving forward with notrap --- mppa_k1c/Asmblockgenproof.v | 32 ++++++++++---------------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 67f02520..15655db6 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,30 +1204,18 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. - - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = None). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef_none. eapply preg_vals; eauto. eassumption. - intros Haddr. rewrite (sp_val _ _ _ AG) in Haddr. - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. + - (* notrap1 cannot happen *) + simpl in EQ0. unfold transl_load in EQ0. + destruct addr; simpl in H. + all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; + monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; + destruct args as [|h0 t0]; try discriminate; + destruct t0 as [|h1 t1]; try discriminate; + destruct t1 as [|h2 t2]; try discriminate. - (* MBload notrap2 TODO *) simpl in EQ0. - discriminate. + admit. - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. @@ -1253,7 +1241,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Qed. +Admitted. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, -- cgit From a57ba1a8a0036853cac31d9401a6f71b877e70c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:50:34 +0200 Subject: a couple "Admitted" and the Coq compiles --- mppa_k1c/PostpassSchedulingproof.v | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 21af276b..867c10c5 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -96,36 +96,42 @@ Proof. Qed. Lemma exec_load_offset_pc_var: - forall t rs m rd ra ofs rs' m' v, - exec_load_offset t rs m rd ra ofs = Next rs' m' -> - exec_load_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. + forall trap t rs m rd ra ofs rs' m' v, + exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> + exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. Qed. Lemma exec_load_reg_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_load_reg t rs m rd ra ro = Next rs' m' -> - exec_load_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. + forall trap t rs m rd ra ro rs' m' v, + exec_load_reg trap t rs m rd ra ro = Next rs' m' -> + exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. Proof. intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. Qed. Lemma exec_load_regxs_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_load_regxs t rs m rd ra ro = Next rs' m' -> - exec_load_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. + forall trap t rs m rd ra ro rs' m' v, + exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> + exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. Proof. intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. Qed. Lemma exec_load_offset_q_pc_var: -- cgit From 74699fa95d096dfc5b9ed7d60aaf1a1338bfc950 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 15:21:37 +0200 Subject: notrap in mppa_k1c ML code --- mppa_k1c/Asmexpand.ml | 34 +++++++++++++++++----------------- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- mppa_k1c/TargetPrinter.ml | 28 ++++++++++++++++------------ 3 files changed, 35 insertions(+), 31 deletions(-) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 1e5149fd..5a103915 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -190,10 +190,10 @@ let expand_builtin_memcpy_big sz al src dst = end); cpy tmpbuf2 16L (fun x y z -> Plq(x, y, z)) (fun x y z -> Psq(x, y, z)); - cpy tmpbuf 8L (fun x y z -> Pld(x, y, z)) (fun x y z -> Psd(x, y, z)); - cpy tmpbuf 4L (fun x y z -> Plw(x, y, z)) (fun x y z -> Psw(x, y, z)); - cpy tmpbuf 2L (fun x y z -> Plh(x, y, z)) (fun x y z -> Psh(x, y, z)); - cpy tmpbuf 1L (fun x y z -> Plb(x, y, z)) (fun x y z -> Psb(x, y, z)); + cpy tmpbuf 8L (fun x y z -> Pld(TRAP, x, y, z)) (fun x y z -> Psd(x, y, z)); + cpy tmpbuf 4L (fun x y z -> Plw(TRAP, x, y, z)) (fun x y z -> Psw(x, y, z)); + cpy tmpbuf 2L (fun x y z -> Plh(TRAP, x, y, z)) (fun x y z -> Psh(x, y, z)); + cpy tmpbuf 1L (fun x y z -> Plb(TRAP, x, y, z)) (fun x y z -> Psb(x, y, z)); assert (!remaining = 0L) end else @@ -203,7 +203,7 @@ let expand_builtin_memcpy_big sz al src dst = let lbl = new_label() in emit (Ploopdo (tmpbuf, lbl)); emit Psemi; - emit (Plb (tmpbuf, srcptr, AOff Z.zero)); + emit (Plb (TRAP, tmpbuf, srcptr, AOff Z.zero)); emit (Paddil (srcptr, srcptr, Z.one)); emit Psemi; emit (Psb (tmpbuf, dstptr, AOff Z.zero)); @@ -223,30 +223,30 @@ let expand_builtin_memcpy sz al args = let expand_builtin_vload_common chunk base ofs res = match chunk, res with | Mint8unsigned, BR(Asmvliw.IR res) -> - emit (Plbu (res, base, AOff ofs)) + emit (Plbu (TRAP, res, base, AOff ofs)) | Mint8signed, BR(Asmvliw.IR res) -> - emit (Plb (res, base, AOff ofs)) + emit (Plb (TRAP, res, base, AOff ofs)) | Mint16unsigned, BR(Asmvliw.IR res) -> - emit (Plhu (res, base, AOff ofs)) + emit (Plhu (TRAP, res, base, AOff ofs)) | Mint16signed, BR(Asmvliw.IR res) -> - emit (Plh (res, base, AOff ofs)) + emit (Plh (TRAP, res, base, AOff ofs)) | Mint32, BR(Asmvliw.IR res) -> - emit (Plw (res, base, AOff ofs)) + emit (Plw (TRAP, res, base, AOff ofs)) | Mint64, BR(Asmvliw.IR res) -> - emit (Pld (res, base, AOff ofs)) + emit (Pld (TRAP, res, base, AOff ofs)) | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> let ofs' = Integers.Ptrofs.add ofs _4 in if base <> res2 then begin - emit (Plw (res2, base, AOff ofs)); - emit (Plw (res1, base, AOff ofs')) + emit (Plw (TRAP, res2, base, AOff ofs)); + emit (Plw (TRAP, res1, base, AOff ofs')) end else begin - emit (Plw (res1, base, AOff ofs')); - emit (Plw (res2, base, AOff ofs)) + emit (Plw (TRAP, res1, base, AOff ofs')); + emit (Plw (TRAP, res2, base, AOff ofs)) end | Mfloat32, BR(Asmvliw.IR res) -> - emit (Pfls (res, base, AOff ofs)) + emit (Pfls (TRAP, res, base, AOff ofs)) | Mfloat64, BR(Asmvliw.IR res) -> - emit (Pfld (res, base, AOff ofs)) + emit (Pfld (TRAP, res, base, AOff ofs)) | _ -> assert false diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index fa61d588..41dac766 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -302,7 +302,7 @@ let arith_rec i = | PArithR (i, rd) -> arith_r_rec i (IR rd) let load_rec i = match i with - | PLoadRRO (i, rs1, rs2, imm) -> + | PLoadRRO (trap, i, rs1, rs2, imm) -> { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = [] } | PLoadQRRO(rs, ra, imm) -> @@ -313,7 +313,7 @@ let load_rec i = match i with let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = []} - | PLoadRRR (i, rs1, rs2, rs3) | PLoadRRRXS (i, rs1, rs2, rs3) -> + | PLoadRRR (trap, i, rs1, rs2, rs3) | PLoadRRRXS (trap, i, rs1, rs2, rs3) -> { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false; read_at_id = []; read_at_e1 = [] } diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5618875f..609077c6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -251,6 +251,10 @@ module Target (*: TARGET*) = | ARegXS _ -> fprintf oc ".xs" | _ -> () + let lsvariant oc = function + | TRAP -> () + | NOTRAP -> output_string oc ".s" + let icond_name = let open Asmvliw in function | ITne | ITneu -> "ne" | ITeq | ITequ -> "eq" @@ -424,18 +428,18 @@ module Target (*: TARGET*) = section oc Section_text (* Load/Store instructions *) - | Plb(rd, ra, adr) -> - fprintf oc " lbs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plbu(rd, ra, adr) -> - fprintf oc " lbz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plh(rd, ra, adr) -> - fprintf oc " lhs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plhu(rd, ra, adr) -> - fprintf oc " lhz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plw(rd, ra, adr) | Plw_a(rd, ra, adr) | Pfls(rd, ra, adr) -> - fprintf oc " lws%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Pld(rd, ra, adr) | Pfld(rd, ra, adr) | Pld_a(rd, ra, adr) -> assert Archi.ptr64; - fprintf oc " ld%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra + | Plb(trap, rd, ra, adr) -> + fprintf oc " lbs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plbu(trap, rd, ra, adr) -> + fprintf oc " lbz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plh(trap, rd, ra, adr) -> + fprintf oc " lhs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plhu(trap, rd, ra, adr) -> + fprintf oc " lhz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plw(trap, rd, ra, adr) | Plw_a(trap, rd, ra, adr) | Pfls(trap, rd, ra, adr) -> + fprintf oc " lws%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Pld(trap, rd, ra, adr) | Pfld(trap, rd, ra, adr) | Pld_a(trap, rd, ra, adr) -> assert Archi.ptr64; + fprintf oc " ld%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra | Plq(rd, ra, adr) -> fprintf oc " lq%a %a = %a[%a]\n" xscale adr gpreg_q rd addressing adr ireg ra | Plo(rd, ra, adr) -> -- cgit From 5898702ac91da16b487b7debb522a440c296fa93 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 15:53:01 +0200 Subject: more proofs on notrap --- mppa_k1c/Asmblockgenproof1.v | 130 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 124 insertions(+), 6 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 68f21541..55fca89a 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1927,6 +1927,32 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access2XS_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro) -> + transl_memory_access2XS chunk mk_instr scale args k = OK c -> + eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2XS_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs. + unfold scale_of_chunk. + subst scale. + rewrite B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + Lemma transl_load_access_correct: forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, @@ -1971,21 +1997,65 @@ Proof. | eauto ]. Qed. -Lemma transl_load_memory_access2_ok: - forall addr trap chunk args dst k c rs a v m, - addr = Aindexed2 -> - transl_load trap chunk addr args dst k = OK c -> +Lemma transl_load_memory_access_ok_notrap2: + forall addr chunk args dst k c rs a m, + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> + transl_load NOTRAP chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr rd, + preg_of dst = IR rd + /\ transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs. +Proof. + intros until m. intros ADDR TR ? ?. + unfold transl_load in TR. destruct addr; try contradiction. + - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. +Qed. + +Lemma transl_load_memory_access2_ok: + forall trap chunk args dst k c rs a v m, + transl_load trap chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, args = mr0 :: mro :: nil /\ preg_of dst = IR rd /\ preg_of mro = IR ro - /\ transl_memory_access2 mk_instr addr args k = OK c + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro. Proof. - intros until m. intros ? TR ? ?. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity + | eauto]. +Qed. + + +Lemma transl_load_memory_access2_ok_notrap2: + forall chunk args dst k c rs a m, + transl_load NOTRAP chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity @@ -2014,6 +2084,28 @@ Proof. | eauto]. Qed. + +Lemma transl_load_memory_access2XS_ok_notrap2: + forall scale chunk args dst k c rs a m, + transl_load NOTRAP chunk (Aindexed2XS scale) args dst k = OK c -> + eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2XS chunk mk_instr scale args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto + | eauto]. +Qed. + Lemma transl_load_correct: forall trap chunk addr args dst k c (rs: regset) m a v, transl_load trap chunk addr args dst k = OK c -> @@ -2040,6 +2132,32 @@ Proof. eapply transl_load_access_correct; eauto with asmgen. Qed. +Lemma transl_load_correct_notrap2: + forall chunk addr args dst k c (rs: regset) m a, + transl_load NOTRAP chunk addr args dst k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = (concrete_default_notrap_load_value chunk) + /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until a; intros TR EV LOAD. destruct addr. + - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. +Qed. + Lemma transl_store_access2_correct: forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c r1 (rs: regset) m v mr1 mro ro m', args = mr1 :: mro :: nil -> -- cgit From be40bfa8516ab7c2b2f5d5c542af73a4f7b8148e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 16:02:28 +0200 Subject: more proofs on notrap2 --- mppa_k1c/Asmblockgenproof1.v | 62 +++++++++++++++++++++++++++++++++++++------- 1 file changed, 53 insertions(+), 9 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 55fca89a..c0a05ab3 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1901,6 +1901,29 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access2_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro) -> + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. +Qed. + Lemma transl_load_access2XS_correct: forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> @@ -1924,7 +1947,7 @@ Proof. unfold scale_of_chunk. subst scale. rewrite B, LOAD. reflexivity. Simpl. - split; intros; Simpl. auto. + split. trivial. intros. Simpl. Qed. Lemma transl_load_access2XS_correct_notrap2: @@ -1974,6 +1997,27 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access_correct_notrap2: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v; intros INSTR TR EV LOAD. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & ptr & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + Lemma transl_load_memory_access_ok: forall addr trap chunk args dst k c rs a v m, (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> @@ -2144,18 +2188,18 @@ Lemma transl_load_correct_notrap2: Proof. intros until a; intros TR EV LOAD. destruct addr. - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + rewrite rdEq. eapply transl_load_access2XS_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + rewrite rdEq. eapply transl_load_access2_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. + eapply transl_load_access_correct_notrap2; eauto with asmgen. Qed. Lemma transl_store_access2_correct: -- cgit From 7df2b7d824f3187f1936685629c06d1028fdc243 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 16:53:08 +0200 Subject: asmblockgen works --- mppa_k1c/Asmblockgenproof.v | 51 +++++++++++++++++++++++++++++++++++++++++---- mppa_k1c/Asmvliw.v | 2 +- 2 files changed, 48 insertions(+), 5 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 15655db6..6baca8c0 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1214,9 +1214,52 @@ Local Transparent destroyed_by_op. destruct t1 as [|h2 t2]; try discriminate. - (* MBload notrap2 TODO *) - simpl in EQ0. - admit. - + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + + destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. + { + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl; congruence. + } + { + exploit transl_load_correct_notrap2; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl; congruence. + } - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. @@ -1241,7 +1284,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Admitted. +Qed. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index bfe9d77b..9508bfbd 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -313,7 +313,7 @@ Inductive cf_instruction : Type := . (** Loads **) -Definition concrete_default_notrap_load_value chunk := +Definition concrete_default_notrap_load_value (chunk : memory_chunk) := match chunk with | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned | Mint32 => Vint Int.zero -- cgit From 6fa6e763ba241da7eeb8bd309344a118c6b1ec4a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 18:20:31 +0200 Subject: finished the proofs for non-trapping loads --- backend/Allocproof.v | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/backend/Allocproof.v b/backend/Allocproof.v index ab6f87b0..3d8fb451 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -2260,25 +2260,36 @@ Proof. eapply wt_exec_Iload_notrap; eauto. (* load regular notrap2 *) -- (* exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. +- 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]]. - - econstructor; split. + 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. eapply exec_Lload_notrap2 with (a := a'). rewrite <- F. + 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. - - generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS). intro WTRS'. - *) + } + { 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. + } - admit. - - (* load notrap2 dead *) exploit exec_moves; eauto. intros [ls1 [X Y]]. econstructor; split. @@ -2542,7 +2553,7 @@ Proof. eapply plus_left. constructor. eexact A. traceEq. econstructor; eauto. apply wt_regset_assign; auto. rewrite WTRES0; auto. -Admitted. +Qed. Lemma initial_states_simulation: forall st1, RTL.initial_state prog st1 -> -- cgit From 3696063f6645297402b7136dba5c4b6d9277d88c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Sep 2019 21:33:21 +0200 Subject: proof for Allnontrap --- backend/Allnontrapproof.v | 215 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 215 insertions(+) create mode 100644 backend/Allnontrapproof.v diff --git a/backend/Allnontrapproof.v b/backend/Allnontrapproof.v new file mode 100644 index 00000000..92e5a88c --- /dev/null +++ b/backend/Allnontrapproof.v @@ -0,0 +1,215 @@ +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 Allnontrap. + + +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 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 *) +- 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 4392758d3e9032edb1ea4a899b92fef886749fca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Sep 2019 22:34:21 +0200 Subject: -fall-loads-nontrap --- driver/Clflags.ml | 1 + driver/Compiler.v | 13 +++++++++++-- driver/Compopts.v | 3 +++ driver/Driver.ml | 1 + extraction/extraction.v | 4 ++++ 5 files changed, 20 insertions(+), 2 deletions(-) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index cf1220d1..fd8227c9 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -75,3 +75,4 @@ let option_fglobaladdroffset = ref false let option_fxsaddr = ref true let option_faddx = ref false let option_fcoalesce_mem = ref true +let option_all_loads_nontrap = ref false diff --git a/driver/Compiler.v b/driver/Compiler.v index 6d398327..d006a7d1 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -42,6 +42,7 @@ Require Constprop. Require CSE. Require Deadcode. Require Unusedglob. +Require Allnontrap. Require Allocation. Require Tunneling. Require Linearize. @@ -63,6 +64,7 @@ Require Constpropproof. Require CSEproof. Require Deadcodeproof. Require Unusedglobproof. +Require Allnontrapproof. Require Allocproof. Require Tunnelingproof. Require Linearizeproof. @@ -136,6 +138,8 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 7) @@@ time "Unused globals" Unusedglob.transform_program @@ print (print_RTL 8) + @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@ print (print_RTL 9) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -243,6 +247,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) ::: mkpass Unusedglobproof.match_prog + ::: mkpass (match_if Compopts.all_loads_nontrap Allnontrapproof.match_prog) ::: mkpass Allocproof.match_prog ::: mkpass Tunnelingproof.match_prog ::: mkpass Linearizeproof.match_prog @@ -286,7 +291,8 @@ Proof. destruct (partial_if optim_CSE CSE.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate. destruct (partial_if optim_redundancy Deadcode.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. destruct (Unusedglob.transform_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. - destruct (Allocation.transf_program p14) as [p15|e] eqn:P15; simpl in T; try discriminate. + set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. + destruct (Allocation.transf_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. set (p16 := Tunneling.tunnel_program p15) in *. destruct (Linearize.transf_program p16) as [p17|e] eqn:P17; simpl in T; try discriminate. set (p18 := CleanupLabels.transf_program p17) in *. @@ -307,6 +313,7 @@ Proof. exists p12; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. exists p13; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. exists p14; split. apply Unusedglobproof.transf_program_match; auto. + exists p14bis; split. apply total_if_match. apply Allnontrapproof.transf_program_match. exists p15; split. apply Allocproof.transf_program_match; auto. exists p16; split. apply Tunnelingproof.transf_program_match. exists p17; split. apply Linearizeproof.transf_program_match; auto. @@ -364,7 +371,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 p21)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p22)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -393,6 +400,8 @@ Ltac DestructM := eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Unusedglobproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Allnontrapproof.transf_program_correct. eapply compose_forward_simulations. eapply Allocproof.transf_program_correct; eassumption. eapply compose_forward_simulations. diff --git a/driver/Compopts.v b/driver/Compopts.v index 9c6448b7..26d888ae 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -62,3 +62,6 @@ Parameter thumb: unit -> bool. (** Flag -g. For insertion of debugging information. *) Parameter debug: unit -> bool. + +(** Flag -fall-loads-nontrap. Turn user loads into non trapping. *) +Parameter all_loads_nontrap: unit -> bool. \ No newline at end of file diff --git a/driver/Driver.ml b/driver/Driver.ml index 288bb436..59b7b222 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -391,6 +391,7 @@ let cmdline_actions = @ f_opt "xsaddr" option_fxsaddr @ f_opt "addx" option_faddx @ f_opt "coalesce-mem" option_fcoalesce_mem + @ f_opt "all-loads-nontrap" option_all_loads_nontrap (* Code generation options *) @ f_opt "fpu" option_ffpu @ f_opt "sse" option_ffpu (* backward compatibility *) diff --git a/extraction/extraction.v b/extraction/extraction.v index e4c1cb25..17925d8c 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -127,6 +127,10 @@ Extract Constant Compopts.optim_addx => "fun _ -> !Clflags.option_faddx". Extract Constant Compopts.optim_coalesce_mem => "fun _ -> !Clflags.option_fcoalesce_mem". +Extract Constant Compopts.va_strict => + "fun _ -> false". +Extract Constant Compopts.all_loads_nontrap => + "fun _ -> !Clflags.option_all_loads_nontrap". (* Compiler *) Extract Constant Compiler.print_Clight => "PrintClight.print_if". -- cgit From 1b44cdee7eef4e31f2fc6b8a2397017c2979f6d9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Sep 2019 23:02:43 +0200 Subject: missing file --- backend/Allnontrap.v | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 backend/Allnontrap.v diff --git a/backend/Allnontrap.v b/backend/Allnontrap.v new file mode 100644 index 00000000..acf03eca --- /dev/null +++ b/backend/Allnontrap.v @@ -0,0 +1,26 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. + + +Definition transf_ros (ros: reg + ident) : reg + ident := ros. + +Definition transf_instr (pc: node) (instr: instruction) := + match instr with + | Iload trap chunk addr args dst s => Iload NOTRAP chunk addr args dst s + | _ => instr + 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 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. + -- cgit From 5361fd9e5bfb9a1c80103cf83a06427b24b57369 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Sep 2019 15:22:34 +0200 Subject: Utilisation d'un intermédiaire xfunction contenant le revmap MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- backend/Duplicate.v | 46 +++++++++++++++++++-------- backend/Duplicateproof.v | 82 ++++++++++++++++++++++++++++-------------------- 2 files changed, 81 insertions(+), 47 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 743d62e4..5c0b1d58 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -1,48 +1,68 @@ (** RTL node duplication using external oracle. Used to form superblock structures *) -Require Import AST RTL Maps. +Require Import AST RTL Maps Globalenvs. Require Import Coqlib Errors. Local Open Scope error_monad_scope. (** External oracle returning the new RTL code (entry point unchanged), along with the new entrypoint, and a mapping of new nodes to old nodes *) -Axiom duplicate_aux: RTL.function -> RTL.code * node * (PTree.t nat). +Axiom duplicate_aux: function -> code * node * (PTree.t node). Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux". +Record xfunction : Type := + { fn_RTL: function; + fn_revmap: PTree.t node; + }. + +Definition xfundef := AST.fundef xfunction. +Definition xprogram := AST.program xfundef unit. +Definition xgenv := Genv.t xfundef unit. + +Definition fundef_RTL (fu: xfundef) : fundef := + match fu with + | Internal f => Internal (fn_RTL f) + | External ef => External ef + end. + (** * Verification of node duplications *) (** Verifies that the mapping [mp] is giving correct information *) -Definition verify_mapping (f: function) (tc: code) (tentry: node) (mp: PTree.t nat) : res unit := OK tt. (* TODO *) +Definition verify_mapping (xf: xfunction) (tc: code) (tentry: node) : res unit := OK tt. (* TODO *) (** * Entry points *) -Definition transf_function (f: function) : res function := +Definition transf_function (f: function) : res xfunction := let (tcte, mp) := duplicate_aux f in let (tc, te) := tcte in - do u <- verify_mapping f tc te mp; - OK (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te). + let xf := {| fn_RTL := (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te); fn_revmap := mp |} in + do u <- verify_mapping xf tc te; + OK xf. Theorem transf_function_preserves: - forall f tf, - transf_function f = OK tf -> - fn_sig f = fn_sig tf /\ fn_params f = fn_params tf /\ fn_stacksize f = fn_stacksize tf. + forall f xf, + transf_function f = OK xf -> + fn_sig f = fn_sig (fn_RTL xf) /\ fn_params f = fn_params (fn_RTL xf) /\ fn_stacksize f = fn_stacksize (fn_RTL xf). Proof. intros. unfold transf_function in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. repeat (split; try reflexivity). Qed. -Remark transf_function_fnsig: forall f tf, transf_function f = OK tf -> fn_sig f = fn_sig tf. +Remark transf_function_fnsig: forall f xf, transf_function f = OK xf -> fn_sig f = fn_sig (fn_RTL xf). Proof. apply transf_function_preserves. Qed. -Remark transf_function_fnparams: forall f tf, transf_function f = OK tf -> fn_params f = fn_params tf. +Remark transf_function_fnparams: forall f xf, transf_function f = OK xf -> fn_params f = fn_params (fn_RTL xf). Proof. apply transf_function_preserves. Qed. -Remark transf_function_fnstacksize: forall f tf, transf_function f = OK tf -> fn_stacksize f = fn_stacksize tf. +Remark transf_function_fnstacksize: forall f xf, transf_function f = OK xf -> fn_stacksize f = fn_stacksize (fn_RTL xf). Proof. apply transf_function_preserves. Qed. -Definition transf_fundef (f: fundef) : res fundef := +Definition transf_fundef_aux (f: fundef) : res xfundef := transf_partial_fundef transf_function f. +Definition transf_fundef (f: fundef): res fundef := + do xf <- transf_fundef_aux f; + OK (fundef_RTL xf). + Definition transf_program (p: program) : res program := transform_partial_program transf_fundef p. \ No newline at end of file diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 618009a1..1127a505 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -3,7 +3,7 @@ Require Import AST Linking Errors Globalenvs Smallstep. Require Import Coqlib Maps Events Values. Require Import Op RTL Duplicate. -Definition match_prog (p tp: program) := +Definition match_prog (p: program) (tp: program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. Lemma transf_program_match: @@ -36,31 +36,39 @@ Inductive match_inst (is_copy: node -> option node): instruction -> instruction match_inst is_copy (Ijumptable r ln) (Ijumptable r ln') | match_inst_return: forall or, match_inst is_copy (Ireturn or) (Ireturn or). -Axiom revmap: function -> node -> option node. (* mapping from nodes of [tprog], to nodes of [prog], for function [f] *) - -Axiom revmap_correct: forall f f' n n', - transf_function f = OK f' -> - revmap f n' = Some n -> - (forall i, (fn_code f)!n = Some i -> exists i', (fn_code f')!n' = Some i' /\ match_inst (revmap f) i i'). +Axiom revmap_correct: forall f xf n n', + transf_function f = OK xf -> + (fn_revmap xf)!n' = Some n -> + (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n => (fn_revmap xf)!n) i i'). Axiom revmap_entrypoint: - forall f f', transf_function f = OK f' -> revmap f (fn_entrypoint f') = Some (fn_entrypoint f). + forall f xf, transf_function f = OK xf -> (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f). Section PRESERVATION. Variable prog: program. Variable tprog: program. + Hypothesis TRANSL: 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 TRANSL). +Lemma symbols_preserved s: Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + rewrite <- (Genv.find_symbol_match TRANSL). reflexivity. +Qed. + +Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. +Proof. + unfold Senv.equiv. intuition congruence. +Qed. Lemma senv_preserved: Senv.equiv ge tge. -Proof (Genv.senv_match TRANSL). +Proof. + eapply (Genv.senv_match TRANSL). +Qed. Lemma functions_translated: forall (v: val) (f: fundef), @@ -68,7 +76,10 @@ Lemma functions_translated: exists tf cunit, transf_fundef f = OK tf /\ Genv.find_funct tge v = Some tf /\ linkorder cunit prog. Proof. intros. exploit (Genv.find_funct_match TRANSL); eauto. - intros (cu & tf & A & B & C). exists tf, cu. split; auto. + intros (cu & tf & A & B & C). + repeat eexists; intuition eauto. + + unfold incl; auto. + + eapply linkorder_refl. Qed. Lemma function_ptr_translated: @@ -76,14 +87,17 @@ Lemma function_ptr_translated: 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). +Proof. + intros. + exploit (Genv.find_funct_ptr_transf_partial TRANSL); eauto. +Qed. Lemma function_sig_translated: - forall f f', transf_fundef f = OK f' -> funsig f' = funsig f. + forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f. Proof. intros. destruct f. - - simpl in H. monadInv H. simpl. symmetry. apply transf_function_preserves. assumption. - - simpl in H. monadInv H. reflexivity. + - simpl in H. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_preserves. assumption. + - simpl in H. monadInv H. monadInv EQ. reflexivity. Qed. Lemma sig_preserved: @@ -92,41 +106,41 @@ Lemma sig_preserved: funsig tf = funsig f. Proof. unfold transf_fundef, transf_partial_fundef; intros. - destruct f. monadInv H. simpl. symmetry; apply transf_function_preserves. assumption. + destruct f. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_preserves. assumption. inv H. reflexivity. Qed. Lemma list_nth_z_revmap: forall ln f ln' (pc pc': node) val, list_nth_z ln val = Some pc -> - list_forall2 (fun n n' => revmap f n' = Some n) ln ln' -> + list_forall2 (fun n n' => (fn_revmap f)!n' = Some n) ln ln' -> exists pc', list_nth_z ln' val = Some pc' - /\ revmap f pc' = Some pc. + /\ (fn_revmap f)!pc' = Some pc. Proof. induction ln; intros until val; intros LNZ LFA. - inv LNZ. - inv LNZ. destruct (zeq val 0) eqn:ZEQ. + inv H0. destruct ln'; inv LFA. - simpl. exists n. split; auto. + simpl. exists p. split; auto. + inv LFA. simpl. rewrite ZEQ. exploit IHln. 2: eapply H0. all: eauto. intros (pc'1 & LNZ & REV). exists pc'1. split; auto. congruence. Qed. Inductive match_stackframes: stackframe -> stackframe -> Prop := | match_stackframe_intro: - forall res f sp pc rs f' pc' - (TRANSF: transf_function f = OK f') - (DUPLIC: revmap f pc' = Some pc), - match_stackframes (Stackframe res f sp pc rs) (Stackframe res f' sp pc' rs). + forall res f sp pc rs xf pc' + (TRANSF: transf_function f = OK xf) + (DUPLIC: (fn_revmap xf)!pc' = Some pc), + match_stackframes (Stackframe res f sp pc rs) (Stackframe res (fn_RTL xf) sp pc' rs). Inductive match_states: state -> state -> Prop := | match_states_intro: - forall st f sp pc rs m st' f' pc' + forall st f sp pc rs m st' xf pc' (STACKS: list_forall2 match_stackframes st st') - (TRANSF: transf_function f = OK f') - (DUPLIC: revmap f pc' = Some pc), - match_states (State st f sp pc rs m) (State st' f' sp pc' rs m) + (TRANSF: transf_function f = OK xf) + (DUPLIC: (fn_revmap xf)!pc' = Some pc), + match_states (State st f sp pc rs m) (State st' (fn_RTL xf) sp pc' rs m) | match_states_call: forall st st' f f' args m (STACKS: list_forall2 match_stackframes st st') @@ -150,8 +164,8 @@ Proof. symmetry. eapply match_program_main. eauto. + exploit function_ptr_translated; eauto. + destruct f. - * monadInv TRANSF. rewrite <- H3. symmetry; eapply transf_function_preserves. assumption. - * monadInv TRANSF. assumption. + * monadInv TRANSF. monadInv EQ. rewrite <- H3. symmetry; eapply transf_function_preserves. assumption. + * monadInv TRANSF. monadInv EQ. assumption. - constructor; eauto. constructor. Qed. @@ -265,12 +279,12 @@ Proof. + eapply exec_Ireturn; eauto. erewrite <- transf_function_fnstacksize; eauto. + constructor; auto. (* exec_function_internal *) - - monadInv TRANSF. eexists. split. - + econstructor. erewrite <- transf_function_fnstacksize; eauto. + - monadInv TRANSF. monadInv EQ. eexists. split. + + eapply exec_function_internal. erewrite <- transf_function_fnstacksize; eauto. + erewrite transf_function_fnparams; eauto. econstructor; eauto. apply revmap_entrypoint. assumption. (* exec_function_external *) - - monadInv TRANSF. eexists. split. + - monadInv TRANSF. monadInv EQ. eexists. split. + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + constructor. assumption. (* exec_return *) -- cgit From f3bdf0c70faa9e69359bd06b78570c60a569a7cb Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 11 Sep 2019 16:16:33 +0200 Subject: Asmgenproof1: useless unfolding in proof scripts causing "omega" to fail "omega" fails in Coq 8.7, but not in 8.8 and later. --- aarch64/Asmgenproof1.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index d60ad2bc..663ee50b 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -426,7 +426,7 @@ Lemma exec_addimm_aux_32: Proof. intros insn sem SEM ASSOC; intros. unfold addimm_aux. set (nlo := Zzero_ext 12 (Int.unsigned n)). set (nhi := Int.unsigned n - nlo). - assert (E: Int.unsigned n = nhi + nlo) by (unfold nlo, nhi; omega). + assert (E: Int.unsigned n = nhi + nlo) by (unfold nhi; omega). rewrite <- (Int.repr_unsigned n). destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. @@ -484,7 +484,7 @@ Lemma exec_addimm_aux_64: Proof. intros insn sem SEM ASSOC; intros. unfold addimm_aux. set (nlo := Zzero_ext 12 (Int64.unsigned n)). set (nhi := Int64.unsigned n - nlo). - assert (E: Int64.unsigned n = nhi + nlo) by (unfold nlo, nhi; omega). + assert (E: Int64.unsigned n = nhi + nlo) by (unfold nhi; omega). rewrite <- (Int64.repr_unsigned n). destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. @@ -1833,4 +1833,4 @@ Proof. intros. Simpl. Qed. -End CONSTRUCTORS. +End CONSTRUCTORS. \ No newline at end of file -- cgit From 417b6e77e5a0c4ea3431d5f379ff054a26b1e326 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Sep 2019 16:51:47 +0200 Subject: Fixing Linking problem --- backend/Duplicate.v | 30 +++++++++++++++--------------- backend/Duplicateproof.v | 32 ++++++++++++++++---------------- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 5c0b1d58..cb3936bb 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -34,35 +34,35 @@ Definition verify_mapping (xf: xfunction) (tc: code) (tentry: node) : res unit : (** * Entry points *) -Definition transf_function (f: function) : res xfunction := +Definition transf_function_aux (f: function) : res xfunction := let (tcte, mp) := duplicate_aux f in let (tc, te) := tcte in let xf := {| fn_RTL := (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te); fn_revmap := mp |} in do u <- verify_mapping xf tc te; OK xf. -Theorem transf_function_preserves: +Theorem transf_function_aux_preserves: forall f xf, - transf_function f = OK xf -> + transf_function_aux f = OK xf -> fn_sig f = fn_sig (fn_RTL xf) /\ fn_params f = fn_params (fn_RTL xf) /\ fn_stacksize f = fn_stacksize (fn_RTL xf). Proof. - intros. unfold transf_function in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. + intros. unfold transf_function_aux in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. repeat (split; try reflexivity). Qed. -Remark transf_function_fnsig: forall f xf, transf_function f = OK xf -> fn_sig f = fn_sig (fn_RTL xf). - Proof. apply transf_function_preserves. Qed. -Remark transf_function_fnparams: forall f xf, transf_function f = OK xf -> fn_params f = fn_params (fn_RTL xf). - Proof. apply transf_function_preserves. Qed. -Remark transf_function_fnstacksize: forall f xf, transf_function f = OK xf -> fn_stacksize f = fn_stacksize (fn_RTL xf). - Proof. apply transf_function_preserves. Qed. +Remark transf_function_aux_fnsig: forall f xf, transf_function_aux f = OK xf -> fn_sig f = fn_sig (fn_RTL xf). + Proof. apply transf_function_aux_preserves. Qed. +Remark transf_function_aux_fnparams: forall f xf, transf_function_aux f = OK xf -> fn_params f = fn_params (fn_RTL xf). + Proof. apply transf_function_aux_preserves. Qed. +Remark transf_function_aux_fnstacksize: forall f xf, transf_function_aux f = OK xf -> fn_stacksize f = fn_stacksize (fn_RTL xf). + Proof. apply transf_function_aux_preserves. Qed. -Definition transf_fundef_aux (f: fundef) : res xfundef := - transf_partial_fundef transf_function f. +Definition transf_function (f: function) : res function := + do xf <- transf_function_aux f; + OK (fn_RTL xf). -Definition transf_fundef (f: fundef): res fundef := - do xf <- transf_fundef_aux f; - OK (fundef_RTL xf). +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef transf_function f. Definition transf_program (p: program) : res program := transform_partial_program transf_fundef p. \ No newline at end of file diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 1127a505..a368174f 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -3,7 +3,7 @@ Require Import AST Linking Errors Globalenvs Smallstep. Require Import Coqlib Maps Events Values. Require Import Op RTL Duplicate. -Definition match_prog (p: program) (tp: program) := +Definition match_prog (p tp: program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. Lemma transf_program_match: @@ -37,12 +37,12 @@ Inductive match_inst (is_copy: node -> option node): instruction -> instruction | match_inst_return: forall or, match_inst is_copy (Ireturn or) (Ireturn or). Axiom revmap_correct: forall f xf n n', - transf_function f = OK xf -> + transf_function_aux f = OK xf -> (fn_revmap xf)!n' = Some n -> (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n => (fn_revmap xf)!n) i i'). Axiom revmap_entrypoint: - forall f xf, transf_function f = OK xf -> (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f). + forall f xf, transf_function_aux f = OK xf -> (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f). Section PRESERVATION. @@ -96,8 +96,8 @@ Lemma function_sig_translated: forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f. Proof. intros. destruct f. - - simpl in H. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_preserves. assumption. - - simpl in H. monadInv H. monadInv EQ. reflexivity. + - simpl in H. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_aux_preserves. assumption. + - simpl in H. monadInv H. (* monadInv EQ. *) reflexivity. Qed. Lemma sig_preserved: @@ -106,7 +106,7 @@ Lemma sig_preserved: funsig tf = funsig f. Proof. unfold transf_fundef, transf_partial_fundef; intros. - destruct f. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_preserves. assumption. + destruct f. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_aux_preserves. assumption. inv H. reflexivity. Qed. @@ -130,7 +130,7 @@ Qed. Inductive match_stackframes: stackframe -> stackframe -> Prop := | match_stackframe_intro: forall res f sp pc rs xf pc' - (TRANSF: transf_function f = OK xf) + (TRANSF: transf_function_aux f = OK xf) (DUPLIC: (fn_revmap xf)!pc' = Some pc), match_stackframes (Stackframe res f sp pc rs) (Stackframe res (fn_RTL xf) sp pc' rs). @@ -138,7 +138,7 @@ Inductive match_states: state -> state -> Prop := | match_states_intro: forall st f sp pc rs m st' xf pc' (STACKS: list_forall2 match_stackframes st st') - (TRANSF: transf_function f = OK xf) + (TRANSF: transf_function_aux f = OK xf) (DUPLIC: (fn_revmap xf)!pc' = Some pc), match_states (State st f sp pc rs m) (State st' (fn_RTL xf) sp pc' rs m) | match_states_call: @@ -164,8 +164,8 @@ Proof. symmetry. eapply match_program_main. eauto. + exploit function_ptr_translated; eauto. + destruct f. - * monadInv TRANSF. monadInv EQ. rewrite <- H3. symmetry; eapply transf_function_preserves. assumption. - * monadInv TRANSF. monadInv EQ. assumption. + * monadInv TRANSF. monadInv EQ. rewrite <- H3. symmetry; eapply transf_function_aux_preserves. assumption. + * monadInv TRANSF. (* monadInv EQ. *) assumption. - constructor; eauto. constructor. Qed. @@ -239,14 +239,14 @@ Proof. eexists. split. + eapply exec_Itailcall. eassumption. simpl. eassumption. apply function_sig_translated. assumption. - erewrite <- transf_function_fnstacksize; eauto. + erewrite <- transf_function_aux_fnstacksize; eauto. + repeat (constructor; auto). * simpl in H0. destruct (Genv.find_symbol _ _) eqn:GFS; try discriminate. apply function_ptr_translated in H0. destruct H0 as (tf & GFF & TF). eexists. split. + eapply exec_Itailcall. eassumption. simpl. rewrite symbols_preserved. rewrite GFS. eassumption. apply function_sig_translated. assumption. - erewrite <- transf_function_fnstacksize; eauto. + erewrite <- transf_function_aux_fnstacksize; eauto. + repeat (constructor; auto). (* Ibuiltin *) - eapply revmap_correct in DUPLIC; eauto. @@ -276,15 +276,15 @@ Proof. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. - + eapply exec_Ireturn; eauto. erewrite <- transf_function_fnstacksize; eauto. + + eapply exec_Ireturn; eauto. erewrite <- transf_function_aux_fnstacksize; eauto. + constructor; auto. (* exec_function_internal *) - monadInv TRANSF. monadInv EQ. eexists. split. - + eapply exec_function_internal. erewrite <- transf_function_fnstacksize; eauto. - + erewrite transf_function_fnparams; eauto. + + eapply exec_function_internal. erewrite <- transf_function_aux_fnstacksize; eauto. + + erewrite transf_function_aux_fnparams; eauto. econstructor; eauto. apply revmap_entrypoint. assumption. (* exec_function_external *) - - monadInv TRANSF. monadInv EQ. eexists. split. + - monadInv TRANSF. (* monadInv EQ. *) eexists. split. + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + constructor. assumption. (* exec_return *) -- cgit From 1ed5afe12dcf340d398637e2582ee5cd5a9eec1a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Sep 2019 17:38:57 +0200 Subject: Proof of first axiom --- backend/Duplicate.v | 18 +++++++++++++++--- backend/Duplicateproof.v | 11 ++++++++++- 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index cb3936bb..a18892cd 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -5,6 +5,7 @@ Require Import AST RTL Maps Globalenvs. Require Import Coqlib Errors. Local Open Scope error_monad_scope. +Local Open Scope positive_scope. (** External oracle returning the new RTL code (entry point unchanged), along with the new entrypoint, and a mapping of new nodes to old nodes *) @@ -29,8 +30,19 @@ Definition fundef_RTL (fu: xfundef) : fundef := (** * Verification of node duplications *) -(** Verifies that the mapping [mp] is giving correct information *) -Definition verify_mapping (xf: xfunction) (tc: code) (tentry: node) : res unit := OK tt. (* TODO *) +Definition verify_mapping_entrypoint (f: function) (xf: xfunction) : res unit := + match ((fn_revmap xf)!(fn_entrypoint (fn_RTL xf))) with + | None => Error (msg "verify_mapping: No node in xf revmap for entrypoint") + | Some n => match (Pos.compare n (fn_entrypoint f)) with + | Eq => OK tt + | _ => Error (msg "verify_mapping_entrypoint: xf revmap for entrypoint does not correspond to the entrypoint of f") + end + end. + +(** Verifies that the [fn_revmap] of the translated function [xf] is giving correct information in regards to [f] *) +Definition verify_mapping (f: function) (xf: xfunction) : res unit := + do u <- verify_mapping_entrypoint f xf; OK tt. +(* TODO - verify the other axiom *) (** * Entry points *) @@ -38,7 +50,7 @@ Definition transf_function_aux (f: function) : res xfunction := let (tcte, mp) := duplicate_aux f in let (tc, te) := tcte in let xf := {| fn_RTL := (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te); fn_revmap := mp |} in - do u <- verify_mapping xf tc te; + do u <- verify_mapping f xf; OK xf. Theorem transf_function_aux_preserves: diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index a368174f..fe26db55 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -3,6 +3,8 @@ Require Import AST Linking Errors Globalenvs Smallstep. Require Import Coqlib Maps Events Values. Require Import Op RTL Duplicate. +Local Open Scope positive_scope. + Definition match_prog (p tp: program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -41,8 +43,15 @@ Axiom revmap_correct: forall f xf n n', (fn_revmap xf)!n' = Some n -> (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n => (fn_revmap xf)!n) i i'). -Axiom revmap_entrypoint: +Theorem revmap_entrypoint: forall f xf, transf_function_aux f = OK xf -> (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f). +Proof. + intros. unfold transf_function_aux in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). + monadInv H. simpl. monadInv EQ. unfold verify_mapping_entrypoint in EQ0. simpl in EQ0. + destruct (mp ! te) eqn:PT; try discriminate. + destruct (n ?= fn_entrypoint f) eqn:EQ; try discriminate. inv EQ0. + apply Pos.compare_eq in EQ. congruence. +Qed. Section PRESERVATION. -- cgit From a7c8e4f4ef4a5f0a15283cd3f0999f3fa24e581d Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 12 Sep 2019 17:03:14 +0200 Subject: Reworked json export. The json export prints formatted json, which takes a lot of additional time, however the result is only consumed by other tools and not meant for human reading. This commit implements several small changes in order to speedup the json export: * Removal of usage of the Format Module * Replacing `fprintf` calls by calls to function that print directly, such as `output_string`, etc. * Replacing list of all instruction names by a set of all instructions --- arm/AsmToJSON.ml | 40 ++++++++++++++++++--------------- backend/Json.ml | 52 +++++++++++++++++++++++++------------------ backend/JsonAST.ml | 12 +++++----- backend/JsonAST.mli | 2 +- powerpc/AsmToJSON.ml | 63 ++++++++++++++++++++++++++-------------------------- 5 files changed, 91 insertions(+), 78 deletions(-) diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml index 6ba3f1bc..e850fed6 100644 --- a/arm/AsmToJSON.ml +++ b/arm/AsmToJSON.ml @@ -19,21 +19,25 @@ open BinNums open Camlcoq open Json -let mnemonic_names = [ "Padc"; "Padd"; "Padds"; "Pand";"Pannot"; "Pasr"; "Pb"; "Pbc"; "Pbic"; "Pblreg"; - "Pblsymb"; "Pbne"; "Pbreg"; "Pbsymb"; "Pbtbl"; "Pclz"; "Pcmp"; "Pcmn"; "Pconstants"; "Pfcpy_iif"; - "Pfcpy_fii"; "Pfcpy_fi"; "Pfcpy_sf"; "Pflid_lbl"; "Pflis_lbl"; "Pdmb"; "Pdsb"; "Peor"; "Pfabsd"; - "Pfabss"; "Pfaddd"; "Pfadds"; "Pfcmpd"; "Pfcmps"; "Pfcmpzd"; "Pfcmpzs"; - "Pfcpyd"; "Pfcpy_fs"; "Pfcpy_if";"Pfcvtds"; "Pfcvtsd"; "Pfdivd"; "Pfdivs"; "Pfldd"; - "Pflid"; "Pflds"; "Pflid_imm"; "Pflis_imm"; "Pfmuld"; "Pfmuls"; "Pfnegd"; - "Pfnegs"; "Pfsitod"; "Pfsitos"; "Pfsqrt"; "Pfstd"; - "Pfsts"; "Pfsubd"; "Pfsubs"; "Pftosizd"; "Pftosizs"; "Pftouizd"; - "Pftouizs"; "Pfuitod"; "Pfuitos"; "Pinlineasm"; "Pisb"; "Plabel"; "Pldr"; - "Ploadsymbol_lbl"; "Pldr_p"; "Pldrb"; "Pldrb_p"; "Pldrh"; "Pldrh_p"; "Pldrsb"; - "Pldrsh"; "Plsl"; "Plsr"; "Pmla"; "Pmov"; "Pmovite"; "Pfmovite"; - "Pmovt"; "Pmovw"; "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Pnop"; "Porr"; - "Ppush"; "Prev"; "Prev16"; "Prsb"; "Prsbs"; "Prsc"; "Psbc"; "Psbfx"; "Psdiv"; "Psmull"; - "Pstr"; "Pstr_p"; "Pstrb"; "Pstrb_p"; "Pstrh"; "Pstrh_p"; "Psub"; "Psubs"; "Pudiv"; - "Pumull" ] +module StringSet = Set.Make(String) + +let mnemonic_names = StringSet.of_list + [ "Padc"; "Padd"; "Padds"; "Pand";"Pannot"; "Pasr"; "Pb"; "Pbc"; "Pbic"; + "Pblreg"; "Pblsymb"; "Pbne"; "Pbreg"; "Pbsymb"; "Pbtbl"; "Pclz"; "Pcmp"; + "Pcmn"; "Pconstants"; "Pfcpy_iif"; "Pfcpy_fii"; "Pfcpy_fi"; "Pfcpy_sf"; + "Pflid_lbl"; "Pflis_lbl"; "Pdmb"; "Pdsb"; "Peor"; "Pfabsd"; "Pfabss"; + "Pfaddd"; "Pfadds"; "Pfcmpd"; "Pfcmps"; "Pfcmpzd"; "Pfcmpzs"; "Pfcpyd"; + "Pfcpy_fs"; "Pfcpy_if";"Pfcvtds"; "Pfcvtsd"; "Pfdivd"; "Pfdivs"; "Pfldd"; + "Pflid"; "Pflds"; "Pflid_imm"; "Pflis_imm"; "Pfmuld"; "Pfmuls"; "Pfnegd"; + "Pfnegs"; "Pfsitod"; "Pfsitos"; "Pfsqrt"; "Pfstd"; "Pfsts"; "Pfsubd"; + "Pfsubs"; "Pftosizd"; "Pftosizs"; "Pftouizd"; "Pftouizs"; "Pfuitod"; + "Pfuitos"; "Pinlineasm"; "Pisb"; "Plabel"; "Pldr"; "Ploadsymbol_lbl"; + "Pldr_p"; "Pldrb"; "Pldrb_p"; "Pldrh"; "Pldrh_p"; "Pldrsb"; "Pldrsh"; + "Plsl"; "Plsr"; "Pmla"; "Pmov"; "Pmovite"; "Pfmovite"; "Pmovt"; "Pmovw"; + "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Pnop"; "Porr"; "Ppush"; "Prev"; + "Prev16"; "Prsb"; "Prsbs"; "Prsc"; "Psbc"; "Psbfx"; "Psdiv"; "Psmull"; + "Pstr"; "Pstr_p"; "Pstrb"; "Pstrb_p"; "Pstrh"; "Pstrh_p"; "Psub"; "Psubs"; + "Pudiv";"Pumull" ] type instruction_arg = | ALabel of positive @@ -143,7 +147,7 @@ let pp_instructions pp ic = | _ -> true) ic in let instruction pp n args = - assert (List.mem n mnemonic_names); + assert (StringSet.mem n mnemonic_names); pp_jobject_start pp; pp_jmember ~first:true pp "Instruction Name" pp_jstring n; pp_jmember pp "Args" (pp_jarray pp_arg) args; @@ -313,8 +317,8 @@ let print_if prog sourcename = | Some f -> let f = Filename.concat !sdump_folder f in let oc = open_out_bin f in - JsonAST.pp_ast (Format.formatter_of_out_channel oc) pp_instructions prog sourcename; + JsonAST.pp_ast oc pp_instructions prog sourcename; close_out oc let pp_mnemonics pp = - JsonAST.pp_mnemonics pp mnemonic_names + JsonAST.pp_mnemonics pp (StringSet.elements mnemonic_names) diff --git a/backend/Json.ml b/backend/Json.ml index b8f66c08..bd4d6ff9 100644 --- a/backend/Json.ml +++ b/backend/Json.ml @@ -10,7 +10,6 @@ (* *) (* *********************************************************************) -open Format open Camlcoq @@ -18,16 +17,21 @@ open Camlcoq (* Print a string as json string *) let pp_jstring oc s = - fprintf oc "\"%s\"" s + output_string oc "\""; + output_string oc s; + output_string oc "\"" (* Print a bool as json bool *) -let pp_jbool oc = fprintf oc "%B" +let pp_jbool oc b = output_string oc (string_of_bool b) (* Print an int as json int *) -let pp_jint oc = fprintf oc "%d" +let pp_jint oc i = output_string oc (string_of_int i) (* Print an int32 as json int *) -let pp_jint32 oc = fprintf oc "%ld" +let pp_jint32 oc i = output_string oc (Int32.to_string i) + +(* Print an int64 as json int *) +let pp_jint64 oc i = output_string oc (Int64.to_string i) (* Print optional value *) let pp_jopt pp_elem oc = function @@ -36,15 +40,19 @@ let pp_jopt pp_elem oc = function (* Print opening and closing curly braces for json dictionaries *) let pp_jobject_start pp = - fprintf pp "@[{" + output_string pp "\n{" let pp_jobject_end pp = - fprintf pp "@;<0 -1>}@]" + output_string pp "}" (* Print a member of a json dictionary *) let pp_jmember ?(first=false) pp name pp_mem mem = - let sep = if first then "" else "," in - fprintf pp "%s@ \"%s\": %a" sep name pp_mem mem + if not first then output_string pp ","; + output_string pp " "; + pp_jstring pp name; + output_string pp " :"; + pp_mem pp mem; + output_string pp "\n" (* Print singleton object *) let pp_jsingle_object pp name pp_mem mem = @@ -54,29 +62,31 @@ let pp_jsingle_object pp name pp_mem mem = (* Print a list as json array *) let pp_jarray elem pp l = - match l with - | [] -> fprintf pp "[]"; + let pp_sep () = output_string pp ", " in + output_string pp "["; + begin match l with + | [] -> () | hd::tail -> - fprintf pp "@[["; - fprintf pp "%a" elem hd; - List.iter (fun l -> fprintf pp ",@ %a" elem l) tail; - fprintf pp "@;<0 -1>]@]" + elem pp hd; + List.iter (fun l -> pp_sep (); elem pp l) tail; + end; + output_string pp "]" (* Helper functions for printing coq integer and floats *) let pp_int pp i = - fprintf pp "%ld" (camlint_of_coqint i) + pp_jint32 pp (camlint_of_coqint i) let pp_int64 pp i = - fprintf pp "%Ld" (camlint64_of_coqint i) + pp_jint64 pp (camlint64_of_coqint i) let pp_float32 pp f = - fprintf pp "%ld" (camlint_of_coqint (Floats.Float32.to_bits f)) + pp_jint32 pp (camlint_of_coqint (Floats.Float32.to_bits f)) let pp_float64 pp f = - fprintf pp "%Ld" (camlint64_of_coqint (Floats.Float.to_bits f)) + pp_jint64 pp (camlint64_of_coqint (Floats.Float.to_bits f)) let pp_z pp z = - fprintf pp "%s" (Z.to_string z) + output_string pp (Z.to_string z) (* Helper functions for printing assembler constructs *) let pp_atom pp a = @@ -106,4 +116,4 @@ let reset_id () = let pp_id_const pp () = let i = next_id () in - pp_jsingle_object pp "Integer" (fun pp i -> fprintf pp "%d" i) i + pp_jsingle_object pp "Integer" pp_jint i diff --git a/backend/JsonAST.ml b/backend/JsonAST.ml index 4e57106f..8905e252 100644 --- a/backend/JsonAST.ml +++ b/backend/JsonAST.ml @@ -15,7 +15,6 @@ open Asm open AST open C2C open Json -open Format open Sections @@ -54,8 +53,8 @@ let pp_section pp sec = | Section_ais_annotation -> () (* There should be no info in the debug sections *) let pp_int_opt pp = function - | None -> fprintf pp "0" - | Some i -> fprintf pp "%d" i + | None -> output_string pp "0" + | Some i -> pp_jint pp i let pp_fundef pp_inst pp (name,fn) = let alignment = atom_alignof name @@ -119,9 +118,8 @@ let pp_program pp pp_inst prog = pp_jobject_end pp let pp_mnemonics pp mnemonic_names = - let mnemonic_names = List.sort (String.compare) mnemonic_names in - let new_line pp () = pp_print_string pp "\n" in - pp_print_list ~pp_sep:new_line pp_print_string pp mnemonic_names + let new_line pp () = Format.pp_print_string pp "\n" in + Format.pp_print_list ~pp_sep:new_line Format.pp_print_string pp mnemonic_names let jdump_magic_number = "CompCertJDUMPRelease: " ^ Version.version @@ -153,4 +151,4 @@ let pp_ast pp pp_inst ast sourcename = pp_jmember pp "Compilation Unit" pp_jstring sourcename; pp_jmember pp "Asm Ast" (fun pp prog -> pp_program pp pp_inst prog) ast; pp_jobject_end pp; - Format.pp_print_flush pp () + flush pp diff --git a/backend/JsonAST.mli b/backend/JsonAST.mli index 7afdce51..c32439e4 100644 --- a/backend/JsonAST.mli +++ b/backend/JsonAST.mli @@ -13,4 +13,4 @@ val pp_mnemonics : Format.formatter -> string list -> unit -val pp_ast : Format.formatter -> (Format.formatter -> Asm.code -> unit) -> (Asm.coq_function AST.fundef, 'a) AST.program -> string -> unit +val pp_ast : out_channel -> (out_channel -> Asm.code -> unit) -> (Asm.coq_function AST.fundef, 'a) AST.program -> string -> unit diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index 99c51e43..f4d4285a 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -17,12 +17,10 @@ open AST open BinNums open Camlcoq open Json -open Format open JsonAST let pp_reg pp t n = - let s = sprintf "%s%s" t n in - pp_jsingle_object pp "Register" pp_jstring s + pp_jsingle_object pp "Register" pp_jstring (t ^ n) let pp_ireg pp reg = pp_reg pp "r" (TargetPrinter.int_reg_name reg) @@ -31,8 +29,8 @@ let pp_freg pp reg = pp_reg pp "f" (TargetPrinter.float_reg_name reg) let preg_annot = function - | IR r -> sprintf "r%s" (TargetPrinter.int_reg_name r) - | FR r -> sprintf "f%s" (TargetPrinter.float_reg_name r) + | IR r -> "r" ^ (TargetPrinter.int_reg_name r) + | FR r -> "f" ^ (TargetPrinter.float_reg_name r) | _ -> assert false let pp_constant pp c = @@ -86,28 +84,31 @@ let pp_arg pp = function | Atom a -> pp_atom_constant pp a | String s -> pp_jsingle_object pp "String" pp_jstring s -let mnemonic_names =["Padd"; "Paddc"; "Padde"; "Paddi"; "Paddic"; "Paddis"; "Paddze"; "Pand_"; - "Pandc"; "Pandi_"; "Pandis_"; "Pannot"; "Pb"; "Pbctr"; "Pbctrl"; "Pbdnz"; - "Pbf"; "Pbl"; "Pblr"; "Pbs"; "Pbt"; "Pbtbl"; "Pcmpb"; "Pcmpd"; "Pcmpdi"; - "Pcmpld"; "Pcmpldi"; "Pcmplw"; "Pcmplwi"; "Pcmpw"; "Pcmpwi"; "Pcntlzd"; - "Pcntlzw"; "Pcreqv"; "Pcror"; "Pcrxor"; "Pdcbf"; "Pdcbi"; "Pdcbt"; - "Pdcbtls"; "Pdcbtst"; "Pdcbz"; "Pdivd"; "Pdivdu"; "Pdivw"; "Pdivwu"; - "Peieio"; "Peqv"; "Pextsb"; "Pextsh"; "Pextsw"; "Pfabs"; "Pfadd"; "Pfadds"; - "Pfcfid"; "Pfcmpu"; "Pfctidz"; "Pfctiw"; "Pfctiwz"; "Pfdiv"; "Pfdivs"; - "Pfmadd"; "Pfmr"; "Pfmsub"; "Pfmul"; "Pfmuls"; "Pfneg"; "Pfnmadd"; - "Pfnmsub"; "Pfres"; "Pfrsp"; "Pfrsqrte"; "Pfsel"; "Pfsqrt"; "Pfsub"; - "Pfsubs"; "Picbi"; "Picbtls"; "Pinlineasm"; "Pisel"; "Pisync"; "Plabel"; - "Plbz"; "Plbzx"; "Pld"; "Pldbrx"; "Pldi"; "Pldx"; "Plfd"; "Plfdx"; "Plfi"; "Plfis"; - "Plfs"; "Plfsx"; "Plha"; "Plhax"; "Plhbrx"; "Plhz"; "Plhzx"; "Plwarx"; - "Plwbrx"; "Plwsync"; "Plwz"; "Plwzu"; "Plwzx"; "Pmbar"; "Pmfcr"; "Pmflr"; - "Pmfspr"; "Pmr"; "Pmtctr"; "Pmtlr"; "Pmtspr"; "Pmulhd"; "Pmulhdu"; "Pmulhw"; - "Pmulhwu"; "Pmulld"; "Pmulli"; "Pmullw"; "Pnand"; "Pnor"; "Por"; "Porc"; - "Pori"; "Poris"; "Prldicl"; "Prldimi"; "Prldinm"; "Prlwimi"; "Prlwinm"; - "Psld"; "Pslw"; "Psrad"; "Psradi"; "Psraw"; "Psrawi"; "Psrd"; "Psrw"; - "Pstb"; "Pstbx"; "Pstd"; "Pstdbrx"; "Pstdu"; "Pstdx"; "Pstfd"; "Pstfdu"; "Pstfdx"; - "Pstfs"; "Pstfsx"; "Psth"; "Psthbrx"; "Psthx"; "Pstw"; "Pstwbrx"; "Pstwcx_"; - "Pstwu"; "Pstwux"; "Pstwx"; "Psubfc"; "Psubfe"; "Psubfic"; "Psubfze"; - "Psync"; "Ptrap"; "Pxor"; "Pxori"; "Pxoris"] +module StringSet = Set.Make(String) + +let mnemonic_names = StringSet.of_list + ["Padd"; "Paddc"; "Padde"; "Paddi"; "Paddic"; "Paddis"; "Paddze"; "Pand_"; + "Pandc"; "Pandi_"; "Pandis_"; "Pannot"; "Pb"; "Pbctr"; "Pbctrl"; "Pbdnz"; + "Pbf"; "Pbl"; "Pblr"; "Pbs"; "Pbt"; "Pbtbl"; "Pcmpb"; "Pcmpd"; "Pcmpdi"; + "Pcmpld"; "Pcmpldi"; "Pcmplw"; "Pcmplwi"; "Pcmpw"; "Pcmpwi"; "Pcntlzd"; + "Pcntlzw"; "Pcreqv"; "Pcror"; "Pcrxor"; "Pdcbf"; "Pdcbi"; "Pdcbt"; + "Pdcbtls"; "Pdcbtst"; "Pdcbz"; "Pdivd"; "Pdivdu"; "Pdivw"; "Pdivwu"; + "Peieio"; "Peqv"; "Pextsb"; "Pextsh"; "Pextsw"; "Pfabs"; "Pfadd"; "Pfadds"; + "Pfcfid"; "Pfcmpu"; "Pfctidz"; "Pfctiw"; "Pfctiwz"; "Pfdiv"; "Pfdivs"; + "Pfmadd"; "Pfmr"; "Pfmsub"; "Pfmul"; "Pfmuls"; "Pfneg"; "Pfnmadd"; + "Pfnmsub"; "Pfres"; "Pfrsp"; "Pfrsqrte"; "Pfsel"; "Pfsqrt"; "Pfsub"; + "Pfsubs"; "Picbi"; "Picbtls"; "Pinlineasm"; "Pisel"; "Pisync"; "Plabel"; + "Plbz"; "Plbzx"; "Pld"; "Pldbrx"; "Pldi"; "Pldx"; "Plfd"; "Plfdx"; "Plfi"; + "Plfis"; "Plfs"; "Plfsx"; "Plha"; "Plhax"; "Plhbrx"; "Plhz"; "Plhzx"; + "Plwarx"; "Plwbrx"; "Plwsync"; "Plwz"; "Plwzu"; "Plwzx"; "Pmbar"; "Pmfcr"; + "Pmflr"; "Pmfspr"; "Pmr"; "Pmtctr"; "Pmtlr"; "Pmtspr"; "Pmulhd"; "Pmulhdu"; + "Pmulhw"; "Pmulhwu"; "Pmulld"; "Pmulli"; "Pmullw"; "Pnand"; "Pnor"; "Por"; + "Porc"; "Pori"; "Poris"; "Prldicl"; "Prldimi"; "Prldinm"; "Prlwimi"; + "Prlwinm"; "Psld"; "Pslw"; "Psrad"; "Psradi"; "Psraw"; "Psrawi"; "Psrd"; + "Psrw"; "Pstb"; "Pstbx"; "Pstd"; "Pstdbrx"; "Pstdu"; "Pstdx"; "Pstfd"; + "Pstfdu"; "Pstfdx"; "Pstfs"; "Pstfsx"; "Psth"; "Psthbrx"; "Psthx"; "Pstw"; + "Pstwbrx"; "Pstwcx_"; "Pstwu"; "Pstwux"; "Pstwx"; "Psubfc"; "Psubfe"; + "Psubfic"; "Psubfze"; "Psync"; "Ptrap"; "Pxor"; "Pxori"; "Pxoris"] let pp_instructions pp ic = let ic = List.filter (fun s -> match s with @@ -126,7 +127,7 @@ let pp_instructions pp ic = | Pcfi_rel_offset _ -> false | _ -> true) ic in let instruction pp n args = - assert (List.mem n mnemonic_names); + assert (StringSet.mem n mnemonic_names); pp_jobject_start pp; pp_jmember ~first:true pp "Instruction Name" pp_jstring n; pp_jmember pp "Args" (pp_jarray pp_arg) args; @@ -251,7 +252,7 @@ let pp_instructions pp ic = | Plhbrx (ir1,ir2,ir3) -> instruction pp "Plhbrx" [Ireg ir1; Ireg ir2; Ireg ir3] | Plhz (ir1,c,ir2) -> instruction pp "Plhz" [Ireg ir1; Constant c; Ireg ir2] | Plhzx (ir1,ir2,ir3) -> instruction pp "Plhzx" [Ireg ir1; Ireg ir2; Ireg ir3] - | Pldi (ir,c) -> instruction pp "Pldi" [Ireg ir; Long c] (* FIXME Cint is too small, we need Clong *) + | Pldi (ir,c) -> instruction pp "Pldi" [Ireg ir; Long c] | Plmake _ (* Should not occur *) | Pllo _ (* Should not occur *) | Plhi _ -> assert false (* Should not occur *) @@ -385,8 +386,8 @@ let print_if prog sourcename = | Some f -> let f = Filename.concat !sdump_folder f in let oc = open_out_bin f in - pp_ast (formatter_of_out_channel oc) pp_instructions prog sourcename; + pp_ast oc pp_instructions prog sourcename; close_out oc let pp_mnemonics pp = - pp_mnemonics pp mnemonic_names + pp_mnemonics pp (StringSet.elements mnemonic_names) -- cgit From 3d25d06ec58f0527b6f0eee7e0df19c18f7133ed Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sat, 14 Sep 2019 19:37:28 +0200 Subject: clightgen -dclight: print function parameters correctly The Clight output of clightgen is Clight version 2, after SimplLocals conversion, where function parameters are temporary variables, not variables. This commit makes sure the function parameters are printed as temporary variables and not as variables. In passing, it generalizes the Clight pretty-printer so that it can print both Clight version 1 and Clight version 2. Closes: #314 --- cfrontend/PrintClight.ml | 41 ++++++++++++++++++++++++++++++----------- cfrontend/PrintCsyntax.ml | 8 ++++---- exportclight/Clightgen.ml | 2 +- 3 files changed, 35 insertions(+), 16 deletions(-) diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml index ca378c11..e63067a9 100644 --- a/cfrontend/PrintClight.ml +++ b/cfrontend/PrintClight.ml @@ -236,10 +236,20 @@ and print_stmt_for p s = | _ -> fprintf p "({ %a })" print_stmt s -let print_function p id f = +(* There are two versions of Clight, Clight1 and Clight2, that differ + only in the meaning of function parameters: + - in Clight1, function parameters are variables + - in Clight2, function parameters are temporaries. +*) + +type clight_version = Clight1 | Clight2 + +let name_param = function Clight1 -> extern_atom | Clight2 -> temp_name + +let print_function ver p id f = fprintf p "%s@ " - (name_cdecl (name_function_parameters (extern_atom id) - f.fn_params f.fn_callconv) + (name_cdecl (name_function_parameters (name_param ver) + (extern_atom id) f.fn_params f.fn_callconv) f.fn_return); fprintf p "@[{@ "; List.iter @@ -253,12 +263,12 @@ let print_function p id f = print_stmt p f.fn_body; fprintf p "@;<0 -2>}@]@ @ " -let print_fundef p id fd = +let print_fundef ver p id fd = match fd with | Ctypes.External(_, _, _, _) -> () | Internal f -> - print_function p id f + print_function ver p id f let print_fundecl p id fd = match fd with @@ -271,9 +281,9 @@ let print_fundecl p id fd = fprintf p "%s;@ " (name_cdecl (extern_atom id) (Clight.type_of_function f)) -let print_globdef p (id, gd) = +let print_globdef var p (id, gd) = match gd with - | AST.Gfun f -> print_fundef p id f + | AST.Gfun f -> print_fundef var p id f | AST.Gvar v -> print_globvar p id v (* from PrintCsyntax *) let print_globdecl p (id, gd) = @@ -281,20 +291,29 @@ let print_globdecl p (id, gd) = | AST.Gfun f -> print_fundecl p id f | AST.Gvar v -> () -let print_program p prog = +let print_program ver p prog = fprintf p "@["; List.iter (declare_composite p) prog.prog_types; List.iter (define_composite p) prog.prog_types; List.iter (print_globdecl p) prog.prog_defs; - List.iter (print_globdef p) prog.prog_defs; + List.iter (print_globdef ver p) prog.prog_defs; fprintf p "@]@." let destination : string option ref = ref None -let print_if prog = +let print_if_gen ver prog = match !destination with | None -> () | Some f -> let oc = open_out f in - print_program (formatter_of_out_channel oc) prog; + print_program ver (formatter_of_out_channel oc) prog; close_out oc + +(* print_if is called from driver/Compiler.v between the SimplExpr + and SimplLocals passes. It receives Clight1 syntax. *) +let print_if prog = print_if_gen Clight1 prog + +(* print_if_2 is called from clightgen/Clightgen.ml, after the + SimplLocals pass. It receives Clight2 syntax. *) +let print_if_2 prog = print_if_gen Clight2 prog + diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index 3a44796c..1c9729c5 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -391,7 +391,7 @@ and print_stmt_for p s = | _ -> fprintf p "({ %a })" print_stmt s -let name_function_parameters fun_name params cconv = +let name_function_parameters name_param fun_name params cconv = let b = Buffer.create 20 in Buffer.add_string b fun_name; Buffer.add_char b '('; @@ -404,7 +404,7 @@ let name_function_parameters fun_name params cconv = if cconv.cc_vararg then Buffer.add_string b ",..." | (id, ty) :: rem -> if not first then Buffer.add_string b ", "; - Buffer.add_string b (name_cdecl (extern_atom id) ty); + Buffer.add_string b (name_cdecl (name_param id) ty); add_params false rem in add_params true params end; @@ -413,8 +413,8 @@ let name_function_parameters fun_name params cconv = let print_function p id f = fprintf p "%s@ " - (name_cdecl (name_function_parameters (extern_atom id) - f.fn_params f.fn_callconv) + (name_cdecl (name_function_parameters extern_atom + (extern_atom id) f.fn_params f.fn_callconv) f.fn_return); fprintf p "@[{@ "; List.iter diff --git a/exportclight/Clightgen.ml b/exportclight/Clightgen.ml index 4209975a..f7279a5e 100644 --- a/exportclight/Clightgen.ml +++ b/exportclight/Clightgen.ml @@ -45,7 +45,7 @@ let compile_c_ast sourcename csyntax ofile = | Errors.Error msg -> fatal_error loc "%a" print_error msg in (* Dump Clight in C syntax if requested *) - PrintClight.print_if clight; + PrintClight.print_if_2 clight; (* Print Clight in Coq syntax *) let oc = open_out ofile in ExportClight.print_program (Format.formatter_of_out_channel oc) -- cgit From 8ac255f207b6864fa22552a48f84ffcf23f747b4 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sat, 14 Sep 2019 19:42:25 +0200 Subject: -dclight output: use nicer names for temporary variables The temporary variables introduced by SimplLocals reuse the same integer identifiers as the local variables they come from. This commit ensures that these variables are printed as "$var", where "var" is the original variable name, instead of "$NNN" as before. The "$NNN" form is retained for temporary variables that do not correspond to a source-level local variable, such as the temporary variables introduced by SimplExpr. This commit should make no difference for "ccomp -dclight", because the Clight that is printed is the Clight version 1 produced by SimplExpr, where every temporary is fresh and does not correspond to a source-level local variable. This commit does change the output of "clightgen -dclight", because the Clight that is printed is the Clight version 2 produced by SimplLocals. The printed Clight is much more legible thanks to the more meaningful temporary variable names. --- cfrontend/PrintClight.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml index e63067a9..0e735d2d 100644 --- a/cfrontend/PrintClight.ml +++ b/cfrontend/PrintClight.ml @@ -23,9 +23,18 @@ open Cop open PrintCsyntax open Clight -(* Naming temporaries *) +(* Naming temporaries. + Some temporaries are obtained by lifting variables in SimplLocals. + For these we use a meaningful name "$var", as found in the table of + atoms. Other temporaries are generated during SimplExpr, and are + not in the table of atoms. We print them as "$NNN" (a unique + integer). *) -let temp_name (id: AST.ident) = "$" ^ Z.to_string (Z.Zpos id) +let temp_name (id: AST.ident) = + try + "$" ^ Hashtbl.find string_of_atom id + with Not_found -> + Printf.sprintf "$%d" (P.to_int id) (* Declarator (identifier + type) -- reuse from PrintCsyntax *) -- cgit From 1b2e0534cc60ea45b17e5e1c70c8a28be682c266 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 16 Sep 2019 15:50:31 +0200 Subject: Updates in preparation for release 3.6 --- Changelog | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ VERSION | 2 +- 2 files changed, 63 insertions(+), 1 deletion(-) diff --git a/Changelog b/Changelog index e5e701d0..935f77f2 100644 --- a/Changelog +++ b/Changelog @@ -1,3 +1,65 @@ +Release 3.6, 2019-09-17 +======================= + +New features and optimizations: +- New port targeting the AArch64 architecture: ARMv8 in 64-bit mode. +- New optimization: if-conversion. Some `if`/`else` statements + and `a ? b : c` conditional expressions are compiled to branchless + conditional move instructions, when supported by the target processor +- New optimization flag: `-Obranchless`, to favor the generation of + branchless instruction sequences, even if probably slower than branches. +- Built-in functions can now be given a formal semantics within + CompCert, instead of being treated as I/O interactions. + Currently, `__builtin_fsqrt` and `__builtin_bswap*` have semantics. +- Extend constant propagation and CSE optimizations to built-in + functions that have known semantics. +- New "polymorphic" built-in function: `__builtin_sel(a,b,c)`. + Similar to `a ? b : c` but `b` and `c` are always evaluated, + and a branchless conditional move instruction is produced if possible. +- x86 64 bits: faster, branchless instruction sequences are produced + for conversions between `double` and `unsigned int`. +- `__builtin_bswap64` is now available for all platforms. + +Usability and diagnostics: +- Improved the DWARF debug information generated in -g mode. +- Added options -fcommon and -fno-common to control the generation + of "common" declarations for uninitialized global. +- Check for reserved keywords `_Complex` and `_Imaginary`. +- Reject function declarations with multiple `void` parameters. +- Define macros `__COMPCERT_MAJOR__`, `__COMPCERT_MINOR__`, and + `__COMPCERT_VERSION__` with CompCert's version number. (#284) +- Prepend `$(DESTDIR)` to the installation target. (#169) +- Extended inline asm: print register names according to the + types of the corresponding arguments (e.g. for x86_64, + `%eax` if int and `%rax` if long). + +Bug fixing: +- Introduce distinct scopes for iteration and selection statements, + as required by ISO C99. +- Handle dependencies in sequences of declarations + (e.g. `int * x, sz = sizeof(x);`). (#267) +- Corrected the check for overflow in integer literals. +- On x86, __builtin_fma was producing wrong code in some cases. +- `float` arguments to `__builtin_annot` and `__builtin_ais_annot` + were uselessly promoted to type `double`. + +Coq formalization and development: +- Improved C parser based on Menhir version 20190626: + fewer run-time checks, faster validation, no axioms. (#276) +- Compatibility with Coq versions 8.9.1 and 8.10.0. +- Compatibility with OCaml versions 4.08.0 and 4.08.1. +- Updated to Flocq version 3.1. +- Revised the construction of NaN payloads in processor descriptions + so as to accommodate FMA. +- Removed some definitions and lemmas from lib/Coqlib.v, using Coq's + standard library instead. + +The clightgen tool: +- Fix normalization of Clight `switch` statements. (#285) +- Add more tracing options: `-dprepro`, `-dall`. (#298) +- Fix the output of `-dclight`. (#314) + + Release 3.5, 2019-02-27 ======================= diff --git a/VERSION b/VERSION index d4563a62..92686b06 100644 --- a/VERSION +++ b/VERSION @@ -1,3 +1,3 @@ -version=3.5 +version=3.6 buildnr= tag= -- cgit From db96b0e2b156cfa527493f5890cd805f8aa4543a Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 25 Aug 2019 19:22:03 +0200 Subject: Revise the "bench" entries of the test suite Initially, the "bench" entries of the test suite used a "xtime" utility developed in-house and not publically available. This commit adds a version of "xtime" written in OCaml (tools/xtime.ml) and updates the "bench" entries of the test/*/Makefile to use it. --- test/c/Makefile | 7 ++-- test/compression/Makefile | 5 +-- test/raytracer/Makefile | 4 +- test/spass/Makefile | 5 +-- tools/xtime.ml | 101 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 110 insertions(+), 12 deletions(-) create mode 100644 tools/xtime.ml diff --git a/test/c/Makefile b/test/c/Makefile index 51a8f105..4b521bb5 100644 --- a/test/c/Makefile +++ b/test/c/Makefile @@ -7,8 +7,7 @@ CFLAGS=-O1 -Wall LIBS=$(LIBMATH) -TIME=xtime -o /dev/null -mintime 2.0 # Xavier's hack -#TIME=time >/dev/null # Otherwise +TIME=ocaml unix.cma ../../tools/xtime.ml -o /dev/null -mintime 2.0 -minruns 4 PROGS=fib integr qsort fft fftsp fftw sha1 sha3 aes almabench \ lists binarytrees fannkuch knucleotide mandelbrot nbody \ @@ -48,12 +47,12 @@ test_gcc: bench_gcc: @for i in $(PROGS); do \ - echo -n "$$i: "; $(TIME) ./$$i.gcc; \ + $(TIME) -name $$i -- ./$$i.gcc; \ done bench: @for i in $(PROGS); do \ - echo -n "$$i: "; $(TIME) ./$$i.compcert; \ + $(TIME) -name $$i -- ./$$i.compcert; \ done clean: diff --git a/test/compression/Makefile b/test/compression/Makefile index 2e14e646..e8f3cf4d 100644 --- a/test/compression/Makefile +++ b/test/compression/Makefile @@ -3,7 +3,7 @@ include ../../Makefile.config CC=../../ccomp CFLAGS=$(CCOMPOPTS) -U__GNUC__ -stdlib ../../runtime -dclight -dasm LIBS= -TIME=xtime -o /dev/null -mintime 1.0 +TIME=ocaml unix.cma ../../tools/xtime.ml -mintime 2.0 -minruns 2 EXE=arcode lzw lzss @@ -48,8 +48,7 @@ test: bench: @rm -f $(TESTCOMPR) @for i in $(EXE); do \ - echo -n "$$i: "; \ - $(TIME) sh -c "./$$i -c -i $(TESTFILE) -o $(TESTCOMPR) && ./$$i -d -i $(TESTCOMPR) -o /dev/null"; \ + $(TIME) -name $$i -- sh -c "./$$i -c -i $(TESTFILE) -o $(TESTCOMPR) && ./$$i -d -i $(TESTCOMPR) -o /dev/null"; \ done @rm -f $(TESTCOMPR) diff --git a/test/raytracer/Makefile b/test/raytracer/Makefile index 8f6541a1..24461bd1 100644 --- a/test/raytracer/Makefile +++ b/test/raytracer/Makefile @@ -3,7 +3,7 @@ include ../../Makefile.config CC=../../ccomp CFLAGS=$(CCOMPOPTS) -stdlib ../../runtime -dparse -dclight -dasm -fstruct-return LIBS=$(LIBMATH) -TIME=xtime +TIME=ocaml unix.cma ../../tools/xtime.ml -mintime 2.0 -minruns 4 OBJS=memory.o gmllexer.o gmlparser.o eval.o \ arrays.o vector.o matrix.o object.o intersect.o surface.o light.o \ @@ -30,4 +30,4 @@ test: fi bench: - @echo -n "raytracer: "; $(TIME) sh -c './render < kal.gml' + @$(TIME) -name raytracer -- sh -c './render < kal.gml' diff --git a/test/spass/Makefile b/test/spass/Makefile index 0e89d6d1..d512ea95 100644 --- a/test/spass/Makefile +++ b/test/spass/Makefile @@ -24,11 +24,10 @@ clean: test: $(SIMU) ./spass small_problem.dfg | grep 'Proof found' -TIME=xtime -o /dev/null # Xavier's hack -#TIME=time >/dev/null # Otherwise +TIME=ocaml unix.cma ../../tools/xtime.ml -o /dev/null -mintime 5.0 bench: - @echo -n "spass: "; $(TIME) ./spass problem.dfg + @$(TIME) -name spass -- ./spass problem.dfg depend: gcc -MM $(SRCS) > .depend diff --git a/tools/xtime.ml b/tools/xtime.ml new file mode 100644 index 00000000..fbb25a49 --- /dev/null +++ b/tools/xtime.ml @@ -0,0 +1,101 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Timing the execution of a command, with more options than the + standard Unix "time" utility. *) + +open Printf + +let outfile = ref "" +let errfile = ref "" +let command_name = ref "" +let num_runs = ref 1 +let min_runs = ref 0 +let min_time = ref 0.0 +let print_sys = ref false + +let error fmt = + eprintf "Error: "; kfprintf (fun _ -> exit 2) stderr fmt + +let open_file out dfl = + if out = "" + then dfl + else Unix.(openfile out [O_WRONLY; O_CREAT; O_TRUNC] 0o666) + +let close_file out fd = + if out <> "" then Unix.close fd + +let run1 (cmd, args) = + let fd_out = open_file !outfile Unix.stdout in + let fd_err = open_file !errfile Unix.stderr in + let pid = + Unix.create_process cmd (Array.of_list (cmd :: args)) + Unix.stdin fd_out fd_err in + close_file !outfile fd_out; + close_file !errfile fd_err; + let (_, st) = Unix.waitpid [] pid in + match st with + | Unix.WEXITED 127 -> error "cannot execute '%s'\n" cmd + | Unix.WSIGNALED signo -> error "terminated by signal %d\n" signo + | _ -> () + +let run (cmd, arg) = + let rec repeat n = + run1 (cmd, arg); + if (!min_time > 0.0 && Unix.((times()).tms_cutime) < !min_time) + || (!min_runs > 0 && n < !min_runs) + || n < !num_runs + then repeat (n + 1) + else n in + let n = repeat 1 in + let ts = Unix.times() in + let cmdname = if !command_name <> "" then !command_name else cmd in + if !print_sys then + Printf.printf "%.3f usr + %.3f sys %s\n" + (ts.Unix.tms_cutime /. float n) + (ts.Unix.tms_cstime /. float n) + cmdname + else + Printf.printf "%.3f %s\n" + (ts.Unix.tms_cutime /. float n) + cmdname + +let _ = + let cmd_and_args = ref [] in + Arg.parse [ + "-o", Arg.Set_string outfile, + " Redirect standard output of command to "; + "-e", Arg.Set_string outfile, + " Redirect standard error of command to "; + "-name", Arg.Set_string command_name, + " Name of command to report along with the time"; + "-repeat", Arg.Int (fun n -> num_runs := n), + " Run the command N times"; + "-mintime", Arg.Float (fun f -> min_time := f), + " Repeatedly run the command for a total duration of at least T seconds"; + "-minruns", Arg.Int (fun n -> num_runs := n), + " Run the command at least N times (to be used in conjunction with -mintime)"; + "-sys", Arg.Set print_sys, + " Print system time (spent in the OS) in addition to user time (spent in the command)"; + "--", Arg.Rest (fun s -> cmd_and_args := s :: !cmd_and_args), + " Specify the executable to time, with its arguments" + ] + (fun s -> raise (Arg.Bad (sprintf "Don't know what to do with '%s'" s))) + "Usage: xtime [options] -- [arguments].\n\nOptions are:"; + match List.rev !cmd_and_args with + | [] -> + error "No command to execute\n" + | cmd :: args -> + Unix.handle_unix_error run (cmd, args) -- cgit From e1725209b2b4401adc63ce5238fa5db7c134609c Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 17 Sep 2019 14:45:59 +0200 Subject: Update for release 3.6 --- doc/index.html | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/index.html b/doc/index.html index edb3accd..3a4cf6ba 100644 --- a/doc/index.html +++ b/doc/index.html @@ -24,7 +24,7 @@ a:active {color : Red; text-decoration : underline; }

The CompCert verified compiler

Commented Coq development

-

Version 3.5, 2019-02-27

+

Version 3.6, 2019-09-17

Introduction

@@ -180,7 +180,8 @@ code. - Recognition of operators
and addressing modes + Recognition of operators
and addressing modes;
+ if-conversion Cminor to CminorSel Selection
SelectOp
-- cgit From f1637021cd51505796e878a21d1b30df0b42e236 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 17 Sep 2019 19:44:22 +0200 Subject: Model GPR0 in isel (#199) If the first argument to `isel` is GPR0, it reads as the constant 0. This cannot occur in code generated by CompCert, due to the fact that GPR0 is not available as register for register allocation. However the assembler semantics should be as close as possible to the actual hardware. --- powerpc/Asm.v | 2 +- powerpc/Asmgenproof1.v | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/powerpc/Asm.v b/powerpc/Asm.v index b9300fd7..4fb38ff8 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -864,7 +864,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pisel rd r1 r2 bit => let v := match rs#(reg_of_crbit bit) with - | Vint n => if Int.eq n Int.zero then rs#r2 else rs#r1 + | Vint n => if Int.eq n Int.zero then rs#r2 else (gpr_or_zero rs r1) | _ => Vundef end in Next (nextinstr (rs #rd <- v #GPR0 <- Vundef)) m diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 884d5366..20cf9c1d 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -1284,7 +1284,9 @@ Proof. reflexivity. + Simpl. rewrite <- (C r1), <- (C r2) by auto. - rewrite B. destruct dir; destruct ob as [[]|]; simpl; auto using Val.lessdef_normalize. + rewrite B, gpr_or_zero_not_zero. + destruct dir; destruct ob as [[]|]; simpl; auto using Val.lessdef_normalize. + destruct dir; intros e; subst; discriminate. + intros. Simpl. Qed. -- cgit From c5b3084dbb231fd8a97789799fd99d7012d59bed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 16:38:43 +0200 Subject: extraction problems --- extraction/extraction.v | 1 - mppa_k1c/Asmgen.v | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extraction/extraction.v b/extraction/extraction.v index ee45b756..e4c1cb25 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -136,7 +136,6 @@ Extract Constant Compiler.print_LTL => "PrintLTL.print_if". 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 Asmgen.time => "Timing.time_coq". (*Extraction Inline Compiler.apply_total Compiler.apply_partial.*) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index c3588871..e64e3df3 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -22,7 +22,8 @@ Require Import Errors String. Local Open Scope error_monad_scope. -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := + Compiler.time. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := (time "Machblock generation" Machblockgen.transf_program) p in -- cgit From adc142066720798ca2e6f7709de6fba93559a336 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 17:07:16 +0200 Subject: fix compiling --- driver/Compopts.v | 4 ++++ extraction/extraction.v | 1 + mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof.v | 2 +- 4 files changed, 8 insertions(+), 3 deletions(-) diff --git a/driver/Compopts.v b/driver/Compopts.v index 9c6448b7..4f86901b 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -62,3 +62,7 @@ Parameter thumb: unit -> bool. (** Flag -g. For insertion of debugging information. *) Parameter debug: 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/extraction/extraction.v b/extraction/extraction.v index e4c1cb25..23d4520f 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -136,6 +136,7 @@ Extract Constant Compiler.print_LTL => "PrintLTL.print_if". 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.*) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index e64e3df3..8875a4ac 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -19,11 +19,11 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. Require Import Errors String. +Require Compopts. Local Open Scope error_monad_scope. -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := - Compiler.time. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := Compopts.time name f. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := (time "Machblock generation" Machblockgen.transf_program) p in diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 5d7bb81f..7388f6da 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -35,7 +35,7 @@ Proof. intros p tp H. unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. inversion_clear H. apply bind_inversion in H1. destruct H1. - inversion_clear H. inversion H2. unfold time in *. remember (Machblockgen.transf_program p) as mbp. + inversion_clear H. inversion H2. unfold time, Compopts.time in *. remember (Machblockgen.transf_program p) as mbp. unfold match_prog; simpl. exists mbp; split. apply Machblockgenproof.transf_program_match; auto. exists x; split. apply Asmblockgenproof.transf_program_match; auto. -- cgit From 24406a351e9d64c2953b0b9fc7ef0b3d79db9b85 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 18:51:54 +0200 Subject: fix compiling for aarch64 --- aarch64/Machregsaux.ml | 5 +++++ aarch64/SelectLongproof.v | 7 +++++-- aarch64/SelectOp.vp | 7 +++++++ aarch64/SelectOpproof.v | 27 +++++++++++++++++++++++++-- 4 files changed, 42 insertions(+), 4 deletions(-) diff --git a/aarch64/Machregsaux.ml b/aarch64/Machregsaux.ml index d7f10b9b..f13a9ff5 100644 --- a/aarch64/Machregsaux.ml +++ b/aarch64/Machregsaux.ml @@ -33,3 +33,8 @@ let register_by_name s = Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) let can_reserve_register r = Conventions1.is_callee_save r + +let class_of_type = function + | AST.Tint | AST.Tlong -> 0 + | AST.Tfloat | AST.Tsingle -> 1 + | AST.Tany32 | AST.Tany64 -> assert false diff --git a/aarch64/SelectLongproof.v b/aarch64/SelectLongproof.v index b051369c..60dc1a12 100644 --- a/aarch64/SelectLongproof.v +++ b/aarch64/SelectLongproof.v @@ -16,6 +16,7 @@ Require Import Coqlib Zbits. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Cminor Op CminorSel. Require Import SelectOp SelectLong SelectOpproof. +Require Import OpHelpers OpHelpersproof. Local Open Scope cminorsel_scope. Local Transparent Archi.ptr64. @@ -23,8 +24,10 @@ Local Transparent Archi.ptr64. (** * Correctness of the smart constructors *) Section CMCONSTR. - -Variable ge: genv. +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. diff --git a/aarch64/SelectOp.vp b/aarch64/SelectOp.vp index 5bd96987..f9e5a1c4 100644 --- a/aarch64/SelectOp.vp +++ b/aarch64/SelectOp.vp @@ -547,6 +547,13 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | _ => (Aindexed Int64.zero, e:::Enil) end. +(* floats *) +Definition divf_base (e1: expr) (e2: expr) := + Eop Odivf (e1 ::: e2 ::: Enil). + +Definition divfs_base (e1: expr) (e2: expr) := + Eop Odivfs (e1 ::: e2 ::: Enil). + (** ** Arguments of builtins *) Nondetfunction builtin_arg (e: expr) := diff --git a/aarch64/SelectOpproof.v b/aarch64/SelectOpproof.v index b78a5ed8..54c6a9fd 100644 --- a/aarch64/SelectOpproof.v +++ b/aarch64/SelectOpproof.v @@ -16,6 +16,7 @@ Require Import Coqlib Zbits. Require Import AST Integers Floats Values Memory Builtins Globalenvs. Require Import Cminor Op CminorSel. Require Import SelectOp. +Require Import OpHelpers OpHelpersproof. Local Open Scope cminorsel_scope. Local Transparent Archi.ptr64. @@ -74,8 +75,10 @@ Ltac TrivialExists := (** * Correctness of the smart constructors *) Section CMCONSTR. - -Variable ge: genv. +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. @@ -1055,6 +1058,26 @@ Proof. - constructor; auto. Qed. +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. + TrivialExists. +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. + TrivialExists. +Qed. + (** Platform-specific known builtins *) Theorem eval_platform_builtin: -- cgit From 3e32784577f1a33d0a4cd19d92ccc971996a73ec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 20:10:15 +0200 Subject: fix Focus -> { ... } --- mppa_k1c/lib/Machblockgenproof.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 02d154c7..91be5e2e 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -723,13 +723,13 @@ Proof. exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - Focus 10. exists (add_to_new_bblock (MB_basic bi)::nil). exists b. + 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. rewrite Heqti. eapply Tr_end_block; eauto. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. + simpl in H5; congruence. } all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From 4e0258fcb21aa0d23c04d4b58dbd4d34672234c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 20:39:43 +0200 Subject: to v3.6 --- driver/Compopts.v | 6 +++++- extraction/extraction.v | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/driver/Compopts.v b/driver/Compopts.v index 26d888ae..6e3b0d62 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -64,4 +64,8 @@ Parameter thumb: unit -> bool. Parameter debug: unit -> bool. (** Flag -fall-loads-nontrap. Turn user loads into non trapping. *) -Parameter all_loads_nontrap: unit -> bool. \ No newline at end of file +Parameter all_loads_nontrap: 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/extraction/extraction.v b/extraction/extraction.v index 994d41a4..828d0dac 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -140,7 +140,7 @@ Extract Constant Compiler.print_LTL => "PrintLTL.print_if". 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 Asmgen.time => "Timing.time_coq". +Extract Constant Compopts.time => "Timing.time_coq". (*Extraction Inline Compiler.apply_total Compiler.apply_partial.*) -- cgit From a8e2039a772da0fcfd484b7445de8cc093be5d2b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 23 Sep 2019 14:17:12 +0200 Subject: is_trapping_op_sound --- mppa_k1c/Op.v | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 7aea2929..92061d04 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1030,6 +1030,34 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + constructor. Qed. +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivl | Odivu | Odivlu + | Omod | Omodl | Omodu | Omodlu + | Oshrximm _ | Oshrxlimm _ + | Ointoffloat | Ointuoffloat + | Ointofsingle | Ointuofsingle + | Olongoffloat | Olonguoffloat + | Olongofsingle | Olonguofsingle + | Osingleofint | Osingleofintu + | Osingleoflong | Osingleoflongu + | Ofloatoflong | Ofloatoflongu => true + | _ => false + end. + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) -- cgit From c7156a4fd9c449c7610942a2fbf1e0908459b7f6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 23 Sep 2019 19:48:20 +0200 Subject: add: non trapping ops --- arm/Op.v | 26 ++++++++++++++++++++++++++ x86/Op.v | 31 +++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+) diff --git a/arm/Op.v b/arm/Op.v index 9de365e9..671bdbe4 100644 --- a/arm/Op.v +++ b/arm/Op.v @@ -518,6 +518,32 @@ Proof with (try exact I; try reflexivity). unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I. Qed. + +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivu + | Oshrximm _ + | Ointoffloat | Ointuoffloat + | Ointofsingle | Ointuofsingle + | Ofloatofint | Ofloatofintu + | Osingleofint | Osingleofintu => true + | _ => false + end. + + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) diff --git a/x86/Op.v b/x86/Op.v index a7176ce4..15672bbe 100644 --- a/x86/Op.v +++ b/x86/Op.v @@ -742,6 +742,37 @@ Proof with (try exact I; try reflexivity). unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I. Qed. + +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivl | Odivu | Odivlu + | Omod | Omodl | Omodu | Omodlu + | Oshrximm _ | Oshrxlimm _ + | Ointoffloat + | Ointofsingle + | Olongoffloat + | Olongofsingle + | Osingleofint + | Osingleoflong + | Ofloatofint + | Ofloatoflong + | Olea _ | Oleal _ (* TODO this is suboptimal *) => true + | _ => false + end. + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) -- cgit From d315994f2d3dbec0bf66a430284eab00dd1d4a18 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Sep 2019 16:51:11 +0200 Subject: trapping ops --- powerpc/Op.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/powerpc/Op.v b/powerpc/Op.v index cbd0291b..b73cb14b 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -581,6 +581,30 @@ Proof with (try exact I; try reflexivity). unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I. Qed. +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivl | Odivu | Odivlu + | Oshrximm _ | Oshrxlimm _ + | Ointoffloat | Ointuoffloat + | Ofloatofint | Ofloatofintu + | Olongoffloat + | Ofloatoflong => true + | _ => false + end. + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) -- cgit From 070d3ba2930e69c83a064ef49f1af0a3fb555e18 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Sep 2019 17:23:53 +0200 Subject: trapping ops --- aarch64/Op.v | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/aarch64/Op.v b/aarch64/Op.v index bf33ab0d..c0b9d435 100644 --- a/aarch64/Op.v +++ b/aarch64/Op.v @@ -921,6 +921,36 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - unfold Val.select. destruct (eval_condition cond vl m). apply Val.normalize_type. exact I. Qed. + +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivu | Odivl | Odivlu + | Oshrximm _ | Oshrlximm _ + | Ointoffloat | Ointuoffloat + | Ointofsingle | Ointuofsingle + | Ofloatofint | Ofloatofintu + | Osingleofint | Osingleofintu + | Olongoffloat | Olonguoffloat + | Olongofsingle | Olonguofsingle + | Ofloatoflong | Ofloatoflongu + | Osingleoflong | Osingleoflongu => true + | _ => false + end. + + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) -- cgit From 3f98eba95b1d0bcb64a07f3188e3623954dc7db3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Sep 2019 21:05:42 +0200 Subject: trapping ops on rv --- riscV/Op.v | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/riscV/Op.v b/riscV/Op.v index 97bc301a..a71696c7 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -666,6 +666,36 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct (eval_condition cond vl m)... destruct b... 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 + | Ofloatofint | Ofloatofintu + | Ofloatoflong | Ofloatoflongu => true + | _ => false + end. + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) -- cgit From b5b154620e454ba947957eb1164acbffff1cb5bd Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 25 Sep 2019 16:45:42 +0200 Subject: Functions that are extern should stay extern (#201) In ISO C, inline functions behaves differently whether they have been declared `extern` at least once or not (i.e. all the declarations have no `extern` and no `static` modifier). Hence, functions that have been declared / defined `extern` once should remain `extern` when redeclared without `extern`. This gives the ISO C behavior for inline functions and has no impact for non-inline functions. --- cparser/Elab.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 3797164d..50346324 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -172,7 +172,7 @@ let combine_toplevel_definitions loc env s old_sto old_ty sto ty = error loc "static declaration of '%s' follows non-static declaration" s; sto | Storage_static,_ -> Storage_static (* Static stays static *) - | Storage_extern,_ -> sto + | Storage_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"; -- cgit From a8586f12b75687061a6d8df9d23696d35f4472f0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 30 Sep 2019 17:26:21 +0200 Subject: Added .gitattributes file. Treat doc as documentation and tests as vendored for github linguist --- .gitattributes | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 .gitattributes diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..02ab53c1 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,3 @@ +# Files that should be ignored by Github linguist +test/* linguist-vendored +doc/* linguist-documentation -- cgit From d09786a563c7cbea8aa27c0e7da0dff4231b9253 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 30 Sep 2019 17:27:23 +0200 Subject: Various improvements for diagnostics. * Extend check for incomplete type. Extended the check to also include a check for variables with incomplete object type that are not arrays, that have an initializer. Furthermore the warning includes the type and variable name. * Warning for incomplete type in compound literals. Incomplete types are not allowed for compound literals, except for array types. * Extend type printing function. The type of a typedeof of an anonymous type should not be printed. Furthermore added '' to the printing of anonymous types. * Unify incomplete type errors message. The incomplete type error messages should all look the same including name of the variable, parameter, etc. and then the incomplete type. --- cparser/Cutil.ml | 6 ++++++ cparser/Cutil.mli | 2 ++ cparser/Elab.ml | 36 ++++++++++++++++++++++++++---------- 3 files changed, 34 insertions(+), 10 deletions(-) diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 7a2f4828..3467c092 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -836,6 +836,12 @@ let is_anonymous_composite = function | TUnion (id,_) -> id.C.name = "" | _ -> false +let is_anonymous_type = function + | TEnum (id,_) + | TStruct (id,_) + | TUnion (id,_) -> id.C.name = "" + | _ -> false + let is_function_pointer_type env t = match unroll env t with | TPtr (ty, _) -> is_function_type env ty diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index f6c4627d..2ddee78c 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -174,6 +174,8 @@ val is_function_pointer_type : Env.t -> typ -> bool (* Is type a pointer to function type? *) val is_anonymous_composite : typ -> bool (* Is type an anonymous composite? *) +val is_anonymous_type : typ -> bool + (* Is the type an anonymous composite or enum *) val is_qualified_array : typ -> bool (* Does the type contain a qualified array type (e.g. int[const 5])? *) val pointer_arithmetic_ok : Env.t -> typ -> bool diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 50346324..bc276b9e 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -39,7 +39,16 @@ let warning loc = let print_typ env fmt ty = match ty with | TNamed _ -> - Format.fprintf fmt "'%a' (aka '%a')" Cprint.typ_raw ty Cprint.typ_raw (unroll env ty) + Format.fprintf fmt "'%a'" Cprint.typ_raw ty; + let ty' = unroll env ty in + if not (is_anonymous_type ty') + then Format.fprintf fmt " (aka '%a')" Cprint.typ_raw ty' + | TStruct (id,_) when id.C.name = "" -> + Format.fprintf fmt "'struct '" + | TUnion (id,_) when id.C.name = "" -> + Format.fprintf fmt "'union '" + | TEnum (id,_) when id.C.name = "" -> + Format.fprintf fmt "'enum '" | _ -> Format.fprintf fmt "'%a'" Cprint.typ_raw ty let pp_field fmt id = @@ -1056,7 +1065,7 @@ and elab_struct_or_union_info kind loc env members attrs = | fld :: rem -> if wrap incomplete_type loc env' fld.fld_typ then (* Must be fatal otherwise we get problems constructing the init *) - fatal_error loc "member '%a' has incomplete type" pp_field fld.fld_name; + fatal_error loc "member '%a' has incomplete type '%a'" pp_field fld.fld_name (print_typ env) fld.fld_typ; if wrap contains_flex_array_mem loc env' fld.fld_typ && kind = Struct then warning loc Flexible_array_extensions "%a may not be used as a struct member due to flexible array member" (print_typ env) fld.fld_typ; check_reduced_alignment loc env' fld.fld_typ; @@ -1611,7 +1620,7 @@ end; try elab_item (I.top env root ty_root) ie [] with No_default_init -> - error loc "variable has incomplete type %a" Cprint.typ ty_root; + error loc "variable has incomplete type %a" (print_typ env) ty_root; raise Exit (* Elaboration of a top-level initializer *) @@ -1909,6 +1918,8 @@ let elab_expr ctx loc env a = | CAST ((spec, dcl), ie) -> let (ty, env) = elab_type loc env spec dcl in + if not (is_array_type env ty) && incomplete_type env ty then + fatal_error "ill-formed compound literal with incomplete type %a" (print_typ env) ty; begin match elab_initializer loc env "" ty ie with | (ty', Some i) -> { edesc = ECompound(ty', i); etyp = ty' },env | (ty', None) -> fatal_error "ill-formed compound literal" @@ -2425,9 +2436,10 @@ let enter_typedef loc env sto (s, ty, init) = let enter_decdef local nonstatic_inline loc sto (decls, env) (s, ty, init) = let isfun = is_function_type env ty in + let has_init = init <> NO_INIT in if sto = Storage_register && has_std_alignas env ty then error loc "alignment specified for 'register' object '%s'" s; - if sto = Storage_extern && init <> NO_INIT then + if sto = Storage_extern && has_init then error loc "'extern' declaration variable has an initializer"; if local && isfun then begin match sto with @@ -2451,10 +2463,14 @@ let enter_decdef local nonstatic_inline loc sto (decls, env) (s, ty, init) = initializer can refer to the ident *) let (id, sto', env1, ty, linkage) = enter_or_refine_ident local loc env s sto1 ty in - if init <> NO_INIT && not local then + if has_init && not local then add_global_define loc s; - if not isfun && is_void_type env ty then - fatal_error loc "'%s' has incomplete type" s; + (* check if the type is void or incomplete and the declaration is initialized *) + if not isfun then begin + let incomplete_init = not (is_array_type env1 ty) && wrap incomplete_type loc env1 ty && has_init in + if is_void_type env1 ty || incomplete_init then + fatal_error loc "variable '%s' has incomplete type %a" s (print_typ env) ty; + end; (* process the initializer *) let (ty', init') = elab_initializer loc env1 s ty init in (* update environment with refined type *) @@ -2465,7 +2481,7 @@ let enter_decdef local nonstatic_inline loc sto (decls, env) (s, ty, init) = warning loc Tentative_incomplete_static "tentative static definition with incomplete type"; end else if local && sto' <> Storage_extern then - error loc "variable has incomplete type %a" (print_typ env) ty'; + error loc "variable '%s' has incomplete type %a" s (print_typ env) ty'; (* check if alignment is reduced *) check_reduced_alignment loc env ty'; (* check for static variables in nonstatic inline functions *) @@ -2659,10 +2675,10 @@ let elab_fundef genv spec name defs body loc = and additionally they should have an identifier. In both cases a fatal error is raised in order to avoid problems at later places. *) let add_param env (id, ty) = - if wrap incomplete_type loc env ty then - fatal_error loc "parameter has incomplete type"; if id.C.name = "" then fatal_error loc "parameter name omitted"; + if wrap incomplete_type loc env ty then + fatal_error loc "parameter '%s' has incomplete type '%a'" id.C.name (print_typ env) ty; Env.add_ident env id Storage_default ty in (* Enter parameters and extra declarations in the local environment. -- cgit From 8caef13011cb21377b4f6d3734109fb41d1f81bd Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 30 Sep 2019 09:51:15 +0200 Subject: Use pointer type for evaluated constants. --- cparser/Ceval.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cparser/Ceval.ml b/cparser/Ceval.ml index 58dea5f4..ecf83779 100644 --- a/cparser/Ceval.ml +++ b/cparser/Ceval.ml @@ -271,7 +271,7 @@ let constant_expr env ty e = try match unroll env ty, cast env ty (expr env e) with | TInt(ik, _), I n -> Some(CInt(n, ik, "")) - | TPtr(_, _), I n -> Some(CInt(n, IInt, "")) + | TPtr(_, _), I n -> Some(CInt(n, ptr_t_ikind (), "")) | (TArray(_, _, _) | TPtr(_, _)), S s -> Some(CStr s) | (TArray(_, _, _) | TPtr(_, _)), WS s -> Some(CWStr s) | TEnum(_, _), I n -> Some(CInt(n, enum_ikind, "")) -- cgit From ca5f8a7629a6e31cc287139ad0a69b8154514260 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 1 Oct 2019 14:36:51 +0200 Subject: Remove duplicated ticks. --- cparser/Elab.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index bc276b9e..2b04340e 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -1065,7 +1065,7 @@ and elab_struct_or_union_info kind loc env members attrs = | fld :: rem -> if wrap incomplete_type loc env' fld.fld_typ then (* Must be fatal otherwise we get problems constructing the init *) - fatal_error loc "member '%a' has incomplete type '%a'" pp_field fld.fld_name (print_typ env) fld.fld_typ; + fatal_error loc "member '%a' has incomplete type %a" pp_field fld.fld_name (print_typ env) fld.fld_typ; if wrap contains_flex_array_mem loc env' fld.fld_typ && kind = Struct then warning loc Flexible_array_extensions "%a may not be used as a struct member due to flexible array member" (print_typ env) fld.fld_typ; check_reduced_alignment loc env' fld.fld_typ; @@ -2678,7 +2678,7 @@ let elab_fundef genv spec name defs body loc = if id.C.name = "" then fatal_error loc "parameter name omitted"; if wrap incomplete_type loc env ty then - fatal_error loc "parameter '%s' has incomplete type '%a'" id.C.name (print_typ env) ty; + fatal_error loc "parameter '%s' has incomplete type %a" id.C.name (print_typ env) ty; Env.add_ident env id Storage_default ty in (* Enter parameters and extra declarations in the local environment. -- cgit From 222cb525b22394077e32fa4e107b033ca2cb6d39 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 16:58:20 +0200 Subject: Asmblockgenproof renaming fpok --> ep --- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c44ef3ff..156354c4 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -354,7 +354,7 @@ Record codestate := pbody1: list basic; pbody2: list basic; pctl: option control; - fpok: bool; + ep: bool; rem: list AB.bblock; cur: option bblock }. @@ -379,7 +379,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := pbody1 := tbc; pbody2 := (extract_basic tbi); pctl := extract_ctl tbi; - fpok := ep; + ep := ep; rem := tc; cur := Some tbb |} @@ -400,7 +400,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := pbody1 := tbdy; pbody2 := extract_basic tex; pctl := extract_ctl tex; - fpok := ep; + ep := ep; rem := tc; cur := Some tbb |} (Asmvliw.State rs m) @@ -422,7 +422,7 @@ Lemma transl_blocks_nonil: transl_blocks f (bb::c) ep = OK tc -> exists tbb tc', tc = tbb :: tc'. Proof. - intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. + intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. destruct (extract_ctl x2). - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - destruct x1; simpl; eauto. @@ -469,7 +469,7 @@ Lemma transl_blocks_distrib: -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) /\ transl_blocks f c false = OK tc. Proof. - intros until ep. intros TLBS Hbuiltin. + intros until ep0. intros TLBS Hbuiltin. destruct bb as [hd bdy ex]. monadInv TLBS. monadInv EQ. exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. @@ -611,7 +611,7 @@ Proof. eapply transl_instr_control_nobuiltin; eauto. intros (Hth & Htbdy & Htexit). exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; - pctl := extract_ctl x0; fpok := ep; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep. + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep0. repeat split. 1-2: econstructor; eauto. { destruct (MB.header bb). eauto. discriminate. } eauto. unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. @@ -1032,7 +1032,7 @@ Lemma step_simu_basic: match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> (exists rs2 m2 l cs2 tbdy', cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; - pctl := pctl cs1; fpok := fp_is_parent (fpok cs1) bi; rem := rem cs1; cur := cur cs1 |} + pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} /\ tbdy = l ++ tbdy' /\ exec_body tge l rs1 m1 = Next rs2 m2 /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). @@ -1098,7 +1098,7 @@ Proof. (* Opaque loadind. *) (* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. - destruct ep eqn:EPeq. + destruct ep0 eqn:EPeq. (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. @@ -1253,7 +1253,7 @@ Qed. Inductive exec_header: codestate -> codestate -> Prop := | exec_header_cons: forall cs1, exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; - pctl := pctl cs1; fpok := (if pheader cs1 then fpok cs1 else false); rem := rem cs1; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) cur := cur cs1 |}. @@ -1293,14 +1293,14 @@ Lemma step_simu_body: match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> (exists rs2 m2 cs2 ep, cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; - pctl := pctl cs1; fpok := ep; rem := rem cs1; cur := cur cs1 |} + pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). Proof. intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. - exists rs1, m1, cs1, (fpok cs1). + exists rs1, m1, cs1, (ep cs1). inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). econstructor; eauto. - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. -- cgit From c229731bdd49255cfb69536ec758eb3004554ce0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 16:58:32 +0200 Subject: Tiny clean --- mppa_k1c/Archi.v | 1 - 1 file changed, 1 deletion(-) diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index cdcf58c3..69b32c7c 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -17,7 +17,6 @@ (** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) Require Import ZArith List. -(*From Flocq*) Require Import Binary Bits. Definition ptr64 := true. -- cgit From 541e60e0570b70813c2ace604a1535bb4d79aa2b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 17:29:40 +0200 Subject: Asmblockgenproof : cur rewriting --- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 156354c4..1c5ad19c 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -356,7 +356,7 @@ Record codestate := pctl: option control; ep: bool; rem: list AB.bblock; - cur: option bblock }. + cur: bblock }. (* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) @@ -381,7 +381,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := pctl := extract_ctl tbi; ep := ep; rem := tc; - cur := Some tbb + cur := tbb |} . @@ -402,7 +402,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := pctl := extract_ctl tex; ep := ep; rem := tc; - cur := Some tbb |} + cur := tbb |} (Asmvliw.State rs m) . @@ -596,7 +596,7 @@ Theorem match_state_codestate: /\ transl_blocks f (bb::c) ep = OK (tbb::tc) /\ body tbb = pbody1 cs ++ pbody2 cs /\ exit tbb = pctl cs - /\ cur cs = Some tbb /\ rem cs = tc + /\ cur cs = tbb /\ rem cs = tc /\ pstate cs = abs. Proof. intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. @@ -611,7 +611,7 @@ Proof. eapply transl_instr_control_nobuiltin; eauto. intros (Hth & Htbdy & Htexit). exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; - pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep0. + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. repeat split. 1-2: econstructor; eauto. { destruct (MB.header bb). eauto. discriminate. } eauto. unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. @@ -719,7 +719,7 @@ Theorem step_simu_control: Genv.find_funct_ptr tge fb = Some (Internal fn) -> pstate cs2 = (Asmvliw.State rs2 m2) -> pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> - cur cs2 = Some tbb -> + cur cs2 = tbb -> match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> @@ -731,7 +731,7 @@ Proof. intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. inv ESTEP. - inv MCS. inv MAS. simpl in *. - inv Hcur. inv Hpstate. + inv Hpstate. destruct ctl. + (* MBcall *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. @@ -962,7 +962,7 @@ Proof. econstructor; eauto. unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. inv Hcur. + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. (* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) intros (TLB & TLBS). *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. @@ -1446,8 +1446,8 @@ Proof. 9: eapply MCS'. all: simpl. 10: eapply ESTEP. all: simpl; eauto. - rewrite Hpbody2. rewrite Hpctl. rewrite Hcur. - { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmstate_some; eauto. + rewrite Hpbody2. rewrite Hpctl. + { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. erewrite exec_body_pc; eauto. } intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). @@ -1472,7 +1472,7 @@ Proof. assert (f1 = f0) by congruence. subst f0. rewrite PCeq in Hrs1pc. inv Hrs1pc. exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. - inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. inv Hcur. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. eapply find_bblock_tail; eauto. Qed. -- cgit From 4c240f12eba480b807bdaafbf817739d9ccf6b23 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 2 Oct 2019 14:14:16 +0200 Subject: Intégration de GLPK MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- test/monniaux/glpk-4.65/Makefile | 39 +++------------------------------------ test/monniaux/rules.mk | 5 ++++- 2 files changed, 7 insertions(+), 37 deletions(-) diff --git a/test/monniaux/glpk-4.65/Makefile b/test/monniaux/glpk-4.65/Makefile index a0ab40dc..eaa3f4b0 100644 --- a/test/monniaux/glpk-4.65/Makefile +++ b/test/monniaux/glpk-4.65/Makefile @@ -1,39 +1,6 @@ ALL_CFLAGS += -I src/amd -I src/colamd -I src/mpl -I src/simplex -I src/api -I src/intopt -I src/minisat -I src/npp -I src/zlib -I src/bflib -I src/env -I src/misc -I src/draft -I src - -include ../rules.mk - -LIBS = -lm - -src=examples/glpsol.c $(wildcard src/*/*.c) - -PRODUCTS?=glpsol.gcc.host glpsol.ccomp.host glpsol.gcc.k1c glpsol.gcc.o1.k1c glpsol.ccomp.k1c -PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS)) - -all: $(PRODUCTS) - -.PHONY: -run: measures.csv - - -glpsol.gcc.host: $(src:.c=.gcc.host.o) ../clock.gcc.host.o - $(CC) $(CFLAGS) $+ $(LIBS) -o $@ -glpsol.ccomp.host: $(src:.c=.ccomp.host.o) ../clock.gcc.host.o - $(CCOMP) $(CCOMPFLAGS) $+ $(LIBS) -o $@ -glpsol.gcc.k1c: $(src:.c=.gcc.k1c.o) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ $(LIBS) -o $@ -glpsol.gcc.o1.k1c: $(src:.c=.gcc.o1.k1c.o) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS_O1) $+ $(LIBS) -o $@ -glpsol.ccomp.k1c: $(src:.c=.ccomp.k1c.o) ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ $(LIBS) -o $@ - +ALL_CFILES=examples/glpsol.c $(wildcard src/*/*.c) +TARGET=glpk EXECUTE_ARGS=--math examples/prod.mod -measures.csv: $(PRODUCTS_OUT) - echo "benches, gcc host,ccomp host,gcc k1c,gcc o1 k1c,ccomp k1c" > $@ - -.SECONDARY: - -.PHONY: -clean: - rm -f *.o *.s *.k1c *.csv - +include ../rules.mk diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index 9d05b4d6..079606e6 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -7,6 +7,9 @@ ALL_CFILES?=$(wildcard *.c) # Name of the target TARGET?=toto +# Arguments of execution +EXECUTE_ARGS?= + # Name of the clock object CLOCK=../clock @@ -92,7 +95,7 @@ obj/%.o: asm/%.s out/%.out: bin/%.bin @mkdir -p $(@D) - $(EXECUTE_CYCLES) $< | tee $@ + $(EXECUTE_CYCLES) $< $(EXECUTE_ARGS) | tee $@ ## # Generating the rules for all the compiler/flags.. -- cgit From 372d91916521d6e2f15e4baae37b66d2dcbb4f23 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 2 Oct 2019 14:18:55 +0200 Subject: (forgot to add glpk to benches.sh) --- test/monniaux/benches.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/benches.sh b/test/monniaux/benches.sh index 2365063a..f932d9c2 100644 --- a/test/monniaux/benches.sh +++ b/test/monniaux/benches.sh @@ -1,3 +1,3 @@ -benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat" +benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65" # Removed for now : ternary -- cgit From 6f181968dde1359e5710131e1360965439220457 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 2 Oct 2019 14:23:39 +0200 Subject: Updating test/monniaux/README.md --- test/monniaux/README.md | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/test/monniaux/README.md b/test/monniaux/README.md index dbb3f337..f2af67fb 100644 --- a/test/monniaux/README.md +++ b/test/monniaux/README.md @@ -37,6 +37,7 @@ float_mat c3, 1504675, 751514, 553235, 1929369, 1372441 - `K1C_CC`: GCC compiler (default k1-cos-gcc) - `K1C_CCOMP`: compcert compiler (default ccomp) - `EXECUTE_CYCLES`: running command (default `k1-cluster` with some options) +- `EXECUTE_ARGS`: execution arguments - `GCCiFLAGS` with i from 0 to 4: the wanted optimizations. If one of these flags is empty, nothing is done. Same for `CCOMPiFLAGS`. For now, the default values: ``` # You can define up to GCC4FLAGS and CCOMP4FLAGS @@ -68,4 +69,10 @@ The `PREFIX` are the prefixes to add to the .s, .o, etc.. You should be careful Assembly files will be generated in `asm/`, objects in `obj/`, binaries in `bin/` and outputs in `out/`. -To compile and execute all the benches : `make` +To compile and execute all the benches : `make` while in the `monniaux` directory (without any `-j` flag). + +To compile and/or execute a single bench, `cd` to the bench directory, then: +- `make` for compiling the bench +- `make run` for running it + +You can use `-j` flag when in a single bench directory -- cgit From 9017c0c0299097cd324b29ac328d0314fd8b05e5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 2 Oct 2019 14:25:11 +0200 Subject: Adding picosat to the benches --- test/monniaux/benches.sh | 2 +- test/monniaux/picosat-965/Makefile | 40 +++++++------------------------------- 2 files changed, 8 insertions(+), 34 deletions(-) diff --git a/test/monniaux/benches.sh b/test/monniaux/benches.sh index f932d9c2..da00c52f 100644 --- a/test/monniaux/benches.sh +++ b/test/monniaux/benches.sh @@ -1,3 +1,3 @@ -benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65" +benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965" # Removed for now : ternary diff --git a/test/monniaux/picosat-965/Makefile b/test/monniaux/picosat-965/Makefile index 991278ff..a887c0de 100644 --- a/test/monniaux/picosat-965/Makefile +++ b/test/monniaux/picosat-965/Makefile @@ -1,37 +1,11 @@ EXECUTE_ARGS=sudoku.sat - -include ../rules.mk - -#ALL_CFLAGS = -DNDEBUG ALL_CFLAGS = -DNALARM -DNZIP -DNGETRUSAGE -DNDEBUG -K1C_CFLAGS += $(EMBEDDED_CFLAGS) -K1C_CCOMPFLAGS += $(EMBEDDED_CFLAGS) -CCOMPFLAGS += -fbitfields -K1C_CCOMPFLAGS += -fbitfields # -fno-if-conversion - -K1C_CFLAGS += $(ALL_CFLAGS) -K1C_CCOMPFLAGS += $(ALL_CFLAGS) -CCOMPFLAGS += $(ALL_CFLAGS) -CFLAGS += $(ALL_CFLAGS) - -all: picosat.ccomp.k1c.s version.ccomp.k1c.s app.ccomp.k1c.s main.ccomp.k1c.s picosat.gcc.k1c.s version.gcc.k1c.s app.gcc.k1c.s main.gcc.k1c.s picosat.ccomp.k1c.out picosat.gcc.o1.k1c.out picosat.gcc.k1c.out picosat picosat.ccomp.host.out picosat.gcc.host.out - -picosat.ccomp.k1c : picosat.ccomp.k1c.s version.ccomp.k1c.s app.ccomp.k1c.s main.ccomp.k1c.s ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ +ALL_CCOMPFLAGS += -fbitfields # -fno-if-conversion +TARGET=picosat +ALL_CFILES=picosat.c version.c app.c main.c -picosat.gcc.k1c : picosat.gcc.k1c.s version.gcc.k1c.s app.gcc.k1c.s main.gcc.k1c.s ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ - -picosat.gcc.o1.k1c : picosat.gcc.o1.k1c.s version.gcc.o1.k1c.s app.gcc.o1.k1c.s main.gcc.o1.k1c.s ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS_O1) $+ -o $@ - -picosat.ccomp.host : picosat.ccomp.host.s version.ccomp.host.s app.ccomp.host.s main.ccomp.host.s ../clock.gcc.host.o - $(CCOMP) $(CCOMPFLAGS) $+ -o $@ - -picosat.gcc.host : picosat.gcc.host.s version.gcc.host.s app.gcc.host.s main.gcc.host.s ../clock.gcc.host.o - $(CC) $(FLAGS) $+ -o $@ - -clean: - -rm -f *.s *.k1c *.out +include ../rules.mk -.PHONY: clean +# FIXME - what were these for? +#K1C_CFLAGS += $(EMBEDDED_CFLAGS) +#K1C_CCOMPFLAGS += $(EMBEDDED_CFLAGS) -- cgit From f04af83c9f1a1e2920bbc14fa7149ce6ae32faca Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 2 Oct 2019 15:06:06 +0200 Subject: genann added --- test/monniaux/benches.sh | 2 +- test/monniaux/genann/Makefile | 4 ++++ test/monniaux/genann/make.proto | 2 -- 3 files changed, 5 insertions(+), 3 deletions(-) create mode 100644 test/monniaux/genann/Makefile delete mode 100644 test/monniaux/genann/make.proto diff --git a/test/monniaux/benches.sh b/test/monniaux/benches.sh index da00c52f..6014f628 100644 --- a/test/monniaux/benches.sh +++ b/test/monniaux/benches.sh @@ -1,3 +1,3 @@ -benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965" +benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann" # Removed for now : ternary diff --git a/test/monniaux/genann/Makefile b/test/monniaux/genann/Makefile new file mode 100644 index 00000000..2e76ec63 --- /dev/null +++ b/test/monniaux/genann/Makefile @@ -0,0 +1,4 @@ +ALL_CFILES= example4shorter.c genann.c +TARGET=genann4 + +include ../rules.mk diff --git a/test/monniaux/genann/make.proto b/test/monniaux/genann/make.proto deleted file mode 100644 index 7c4248bf..00000000 --- a/test/monniaux/genann/make.proto +++ /dev/null @@ -1,2 +0,0 @@ -sources: example4shorter.c genann.c -target: genann4 \ No newline at end of file -- cgit From c22d994917d6a67efc065c1205ede4d448445c10 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 2 Oct 2019 15:14:04 +0200 Subject: Identity oracle realizing verify_mapping_entrypoint --- backend/Duplicateaux.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index a272ac85..70726c4a 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,4 +1,7 @@ open RTL open Maps -let duplicate_aux f = (((fn_code f), (fn_entrypoint f)), PTree.empty) +(* For now, identity function *) +let duplicate_aux f = + let pTreeEntry = PTree.set (fn_entrypoint f) (fn_entrypoint f) PTree.empty + in (((fn_code f), (fn_entrypoint f)), pTreeEntry) -- cgit From 57fce9febbd616becc8f120447de9c40318bcbfa Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 2 Oct 2019 16:00:38 +0200 Subject: Starting implementing the verificator --- backend/Duplicate.v | 33 +++++++++++++++++++++++++++++++++ backend/Duplicateproof.v | 2 +- 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index a18892cd..07577704 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -39,6 +39,39 @@ Definition verify_mapping_entrypoint (f: function) (xf: xfunction) : res unit := end end. +Definition verify_is_copy revmap n n' := + match revmap!n' with + | None => Error(msg "verify_is_copy None") + | Some revn => match (Pos.compare n revn) with Eq => OK tt | _ => Error(msg "verify_is_copy invalid map") end + end. + +Definition verify_match_inst revmap inst tinst := + match inst with + | Inop n => match tinst with Inop n' => do u <- verify_is_copy revmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end + | _ => Error(msg "not implemented") + end. + +Definition verify_mapping_mn f xf (m: positive*positive) := + let (tn, n) := m in + match (fn_code f)!n with + | None => Error (msg "verify_mapping_mn: Could not get an instruction at (fn_code f)!n") + | Some inst => match (fn_code (fn_RTL xf))!tn with + | None => Error (msg "verify_mapping_mn: Could not get an instruction at (fn_code xf)!tn") + | Some tinst => verify_match_inst (fn_revmap xf) inst tinst + end + end. + +Fixpoint verify_mapping_mn_rec f xf lm := + match lm with + | nil => OK tt + | m :: lm => do u <- verify_mapping_mn f xf m; + do u2 <- verify_mapping_mn_rec f xf lm; + OK tt + end. + +Definition verify_mapping_match_nodes (f: function) (xf: xfunction) : res unit := + verify_mapping_mn_rec f xf (PTree.elements (fn_revmap xf)). + (** Verifies that the [fn_revmap] of the translated function [xf] is giving correct information in regards to [f] *) Definition verify_mapping (f: function) (xf: xfunction) : res unit := do u <- verify_mapping_entrypoint f xf; OK tt. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index fe26db55..4ffd2c5d 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -41,7 +41,7 @@ Inductive match_inst (is_copy: node -> option node): instruction -> instruction Axiom revmap_correct: forall f xf n n', transf_function_aux f = OK xf -> (fn_revmap xf)!n' = Some n -> - (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n => (fn_revmap xf)!n) i i'). + (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n' => (fn_revmap xf)!n') i i'). Theorem revmap_entrypoint: forall f xf, transf_function_aux f = OK xf -> (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f). -- cgit From b7374d225af55ecc6f5d6aa8f3684bfae99ff465 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 2 Oct 2019 19:23:51 +0200 Subject: Make explicit the use of hints from OrderedType (#316) Some hints will move from the core database to the `ordered_type` database (see https://github.com/coq/coq/pull/9772). This commit prepares for this move by adding `with ordered_type` to the invocations of `auto` and `eauto` that use the hints in question. --- backend/Inliningproof.v | 8 ++++---- backend/ValueAnalysis.v | 8 ++++---- lib/Heaps.v | 6 +++--- lib/Ordered.v | 10 ++++++---- 4 files changed, 17 insertions(+), 15 deletions(-) diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 181f40bf..cc84b1cc 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -744,7 +744,7 @@ Lemma match_stacks_free_right: match_stacks F m m1' stk stk' sp. Proof. intros. eapply match_stacks_invariant; eauto. - intros. eapply Mem.perm_free_1; eauto. + intros. eapply Mem.perm_free_1; eauto with ordered_type. intros. eapply Mem.perm_free_3; eauto. Qed. @@ -1043,7 +1043,7 @@ Proof. eapply match_stacks_bound with (bound := sp'). eapply match_stacks_invariant; eauto. intros. eapply Mem.perm_free_3; eauto. - intros. eapply Mem.perm_free_1; eauto. + intros. eapply Mem.perm_free_1; eauto with ordered_type. intros. eapply Mem.perm_free_3; eauto. erewrite Mem.nextblock_free; eauto. red in VB; xomega. eapply agree_val_regs; eauto. @@ -1135,7 +1135,7 @@ Proof. eapply match_stacks_bound with (bound := sp'). eapply match_stacks_invariant; eauto. intros. eapply Mem.perm_free_3; eauto. - intros. eapply Mem.perm_free_1; eauto. + intros. eapply Mem.perm_free_1; eauto with ordered_type. intros. eapply Mem.perm_free_3; eauto. erewrite Mem.nextblock_free; eauto. red in VB; xomega. destruct or; simpl. apply agree_val_reg; auto. auto. @@ -1182,7 +1182,7 @@ Proof. subst b1. rewrite D in H8; inv H8. eelim Plt_strict; eauto. intros. eapply Mem.perm_alloc_1; eauto. intros. exploit Mem.perm_alloc_inv. eexact A. eauto. - rewrite dec_eq_false; auto. + rewrite dec_eq_false; auto with ordered_type. auto. auto. auto. eauto. auto. rewrite H5. apply agree_regs_init_regs. eauto. auto. inv H1; auto. congruence. auto. eapply Mem.valid_new_block; eauto. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 8dbb67a7..2b233900 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -1148,10 +1148,10 @@ Proof. - constructor. - assert (Plt sp bound') by eauto with va. eapply sound_stack_public_call; eauto. apply IHsound_stack; intros. - apply INV. xomega. rewrite SAME; auto. xomega. auto. auto. + apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto. - assert (Plt sp bound') by eauto with va. eapply sound_stack_private_call; eauto. apply IHsound_stack; intros. - apply INV. xomega. rewrite SAME; auto. xomega. auto. auto. + apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto. apply bmatch_ext with m; auto. intros. apply INV. xomega. auto. auto. auto. Qed. @@ -1362,7 +1362,7 @@ Proof. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. - rewrite C; auto. + rewrite C; auto with ordered_type. exact AA. * (* public builtin call *) exploit anonymize_stack; eauto. @@ -1381,7 +1381,7 @@ Proof. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. - rewrite C; auto. + rewrite C; auto with ordered_type. exact AA. } unfold transfer_builtin in TR. diff --git a/lib/Heaps.v b/lib/Heaps.v index 9fa07a1d..85343998 100644 --- a/lib/Heaps.v +++ b/lib/Heaps.v @@ -256,14 +256,14 @@ Proof. eapply gt_heap_trans with y; eauto. red; auto. - intuition. eapply lt_heap_trans; eauto. red; auto. - eapply gt_heap_trans; eauto. red; auto. + eapply gt_heap_trans; eauto. red; auto with ordered_type. - intuition. eapply gt_heap_trans; eauto. red; auto. - rewrite e3 in *; simpl in *. intuition. eapply lt_heap_trans with y; eauto. red; auto. eapply gt_heap_trans; eauto. red; auto. - intuition. eapply lt_heap_trans with y; eauto. red; auto. - eapply gt_heap_trans; eauto. red; auto. + eapply gt_heap_trans; eauto. red; auto with ordered_type. eapply gt_heap_trans with x; eauto. red; auto. - rewrite e3 in *; simpl in *; intuition. eapply gt_heap_trans; eauto. red; auto. @@ -308,7 +308,7 @@ Proof. intros. unfold insert. case_eq (partition x h). intros a b EQ; simpl. assert (E.eq y x \/ ~E.eq y x). - destruct (E.compare y x); auto. + destruct (E.compare y x); auto with ordered_type. right; red; intros. elim (E.lt_not_eq l). apply E.eq_sym; auto. destruct H0. tauto. diff --git a/lib/Ordered.v b/lib/Ordered.v index bcf24cbd..1adbd330 100644 --- a/lib/Ordered.v +++ b/lib/Ordered.v @@ -21,6 +21,8 @@ Require Import Coqlib. Require Import Maps. Require Import Integers. +Create HintDb ordered_type. + (** The ordered type of positive numbers *) Module OrderedPositive <: OrderedType. @@ -173,17 +175,17 @@ Definition eq (x y: t) := Lemma eq_refl : forall x : t, eq x x. Proof. - intros; split; auto. + intros; split; auto with ordered_type. Qed. Lemma eq_sym : forall x y : t, eq x y -> eq y x. Proof. - unfold eq; intros. intuition auto. + unfold eq; intros. intuition auto with ordered_type. Qed. Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. Proof. - unfold eq; intros. intuition eauto. + unfold eq; intros. intuition eauto with ordered_type. Qed. Definition lt (x y: t) := @@ -201,7 +203,7 @@ Proof. case (A.compare (fst x) (fst z)); intro. assumption. generalize (A.lt_not_eq H2); intro. elim H5. - apply A.eq_trans with (fst z). auto. auto. + apply A.eq_trans with (fst z). auto. auto with ordered_type. generalize (@A.lt_not_eq (fst z) (fst y)); intro. elim H5. apply A.lt_trans with (fst x); auto. apply A.eq_sym; auto. -- cgit From 537857a59def9c9fb16035ac81c121b1ae176b66 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 3 Oct 2019 11:32:56 +0200 Subject: Duplicate - Proof of verificator for Inop --- backend/Duplicate.v | 3 +- backend/Duplicateproof.v | 84 ++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 83 insertions(+), 4 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 07577704..ce6c436f 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -74,7 +74,8 @@ Definition verify_mapping_match_nodes (f: function) (xf: xfunction) : res unit : (** Verifies that the [fn_revmap] of the translated function [xf] is giving correct information in regards to [f] *) Definition verify_mapping (f: function) (xf: xfunction) : res unit := - do u <- verify_mapping_entrypoint f xf; OK tt. + do u <- verify_mapping_entrypoint f xf; + do v <- verify_mapping_match_nodes f xf; OK tt. (* TODO - verify the other axiom *) (** * Entry points *) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 4ffd2c5d..3a6d6920 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -38,10 +38,88 @@ Inductive match_inst (is_copy: node -> option node): instruction -> instruction match_inst is_copy (Ijumptable r ln) (Ijumptable r ln') | match_inst_return: forall or, match_inst is_copy (Ireturn or) (Ireturn or). -Axiom revmap_correct: forall f xf n n', +Lemma verify_mapping_mn_rec_step: + forall lb b f xf, + In b lb -> + verify_mapping_mn_rec f xf lb = OK tt -> + verify_mapping_mn f xf b = OK tt. +Proof. + induction lb; intros. + - monadInv H0. inversion H. + - inversion H. + + subst. monadInv H0. destruct x. assumption. + + monadInv H0. destruct x0. eapply IHlb; assumption. +Qed. + +Lemma verify_is_copy_correct: + forall xf n n', + verify_is_copy (fn_revmap xf) n n' = OK tt -> + match_inst (fun nn => (fn_revmap xf) ! nn) (Inop n) (Inop n'). +Proof. + intros. unfold verify_is_copy in H. destruct (_ ! n') eqn:REVM; [|inversion H]. + destruct (n ?= p) eqn:NP; try (inversion H; fail). clear H. + eapply Pos.compare_eq in NP. subst. + constructor; eauto. +Qed. + +Lemma verify_match_inst_correct: + forall xf i i', + verify_match_inst (fn_revmap xf) i i' = OK tt -> + match_inst (fun nn => (fn_revmap xf) ! nn) i i'. +Proof. + intros. unfold verify_match_inst in H. + destruct i; try (inversion H; fail). +(* Inop *) + - destruct i'; try (inversion H; fail). monadInv H. eapply verify_is_copy_correct. destruct x. assumption. +Qed. + +Lemma verify_mapping_mn_correct: + forall mp n n' i f xf tc, + mp ! n' = Some n -> + (fn_code f) ! n = Some i -> + (fn_code (fn_RTL xf)) = tc -> + fn_revmap xf = mp -> + verify_mapping_mn f xf (n', n) = OK tt -> + exists i', + tc ! n' = Some i' + /\ match_inst (fun nn => mp ! nn) i i'. +Proof. + intros. unfold verify_mapping_mn in H3. rewrite H0 in H3. clear H0. rewrite H1 in H3. clear H1. + destruct (tc ! n') eqn:TCN; [| inversion H3]. + exists i0. split; auto. rewrite <- H2. + eapply verify_match_inst_correct. assumption. +Qed. + + +Lemma verify_mapping_mn_rec_correct: + forall mp n n' i f xf tc, + mp ! n' = Some n -> + (fn_code f) ! n = Some i -> + (fn_code (fn_RTL xf)) = tc -> + fn_revmap xf = mp -> + verify_mapping_mn_rec f xf (PTree.elements mp) = OK tt -> + exists i', + tc ! n' = Some i' + /\ match_inst (fun nn => mp ! nn) i i'. +Proof. + intros. exploit PTree.elements_correct. eapply H. intros IN. + eapply verify_mapping_mn_rec_step in H3; eauto. + eapply verify_mapping_mn_correct; eauto. +Qed. + + +Theorem revmap_correct: forall f xf n n', transf_function_aux f = OK xf -> (fn_revmap xf)!n' = Some n -> (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n' => (fn_revmap xf)!n') i i'). +Proof. + intros until n'. intros TRANSF REVM i FNC. + unfold transf_function_aux in TRANSF. destruct (duplicate_aux f) as (tcte & mp). destruct tcte as (tc & te). monadInv TRANSF. + simpl in *. monadInv EQ. clear EQ0. + unfold verify_mapping_match_nodes in EQ. simpl in EQ. destruct x1. + eapply verify_mapping_mn_rec_correct. 5: eapply EQ. all: eauto. +Qed. + Theorem revmap_entrypoint: forall f xf, transf_function_aux f = OK xf -> (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f). @@ -49,8 +127,8 @@ Proof. intros. unfold transf_function_aux in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. simpl. monadInv EQ. unfold verify_mapping_entrypoint in EQ0. simpl in EQ0. destruct (mp ! te) eqn:PT; try discriminate. - destruct (n ?= fn_entrypoint f) eqn:EQ; try discriminate. inv EQ0. - apply Pos.compare_eq in EQ. congruence. + destruct (n ?= fn_entrypoint f) eqn:EQQ; try discriminate. inv EQ0. + apply Pos.compare_eq in EQQ. congruence. Qed. Section PRESERVATION. -- cgit From b59eb881ad3fd72b8743fb48d90e2751dc996e77 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 3 Oct 2019 16:13:07 +0200 Subject: Preparing the terrain for the rest of the instructions with one successor --- backend/Duplicateproof.v | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 3a6d6920..f3218f5f 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -51,15 +51,26 @@ Proof. + monadInv H0. destruct x0. eapply IHlb; assumption. Qed. -Lemma verify_is_copy_correct: - forall xf n n', +Inductive rtl_one_successor : node -> node -> instruction -> instruction -> Prop := + | inop_one_succ : forall n n', rtl_one_successor n n' (Inop n) (Inop n') + | iop_one_succ : forall op lr r n n', rtl_one_successor n n' (Iop op lr r n) (Iop op lr r n') + | iload_one_succ : forall m a lr r n n', rtl_one_successor n n' (Iload m a lr r n) (Iload m a lr r n') + | istore_one_succ : forall m a lr r n n', rtl_one_successor n n' (Istore m a lr r n) (Istore m a lr r n') + | icall_one_succ : forall s ri lr r n n', rtl_one_successor n n' (Icall s ri lr r n) (Icall s ri lr r n') + | ibuiltin_one_succ : forall ef lbr br n n', rtl_one_successor n n' (Ibuiltin ef lbr br n) (Ibuiltin ef lbr br n') +. + +Lemma verify_is_copy_correct_one: + forall xf n n' i i', verify_is_copy (fn_revmap xf) n n' = OK tt -> - match_inst (fun nn => (fn_revmap xf) ! nn) (Inop n) (Inop n'). + rtl_one_successor n n' i i' -> + match_inst (fun nn => (fn_revmap xf) ! nn) i i'. Proof. intros. unfold verify_is_copy in H. destruct (_ ! n') eqn:REVM; [|inversion H]. destruct (n ?= p) eqn:NP; try (inversion H; fail). clear H. eapply Pos.compare_eq in NP. subst. - constructor; eauto. + inv H0. + all: constructor; eauto. Qed. Lemma verify_match_inst_correct: @@ -70,7 +81,8 @@ Proof. intros. unfold verify_match_inst in H. destruct i; try (inversion H; fail). (* Inop *) - - destruct i'; try (inversion H; fail). monadInv H. eapply verify_is_copy_correct. destruct x. assumption. + - destruct i'; try (inversion H; fail). monadInv H. eapply verify_is_copy_correct_one. destruct x. eassumption. + constructor; eauto. Qed. Lemma verify_mapping_mn_correct: -- cgit From 6f05c86e614797b76d92bc3dbbd4c0ece683168e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 3 Oct 2019 16:31:03 +0200 Subject: Proof for Iop --- backend/Duplicate.v | 14 +++++++++++++- backend/Duplicateproof.v | 7 +++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index ce6c436f..a96d0826 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -2,7 +2,7 @@ structures *) Require Import AST RTL Maps Globalenvs. -Require Import Coqlib Errors. +Require Import Coqlib Errors Op. Local Open Scope error_monad_scope. Local Open Scope positive_scope. @@ -45,9 +45,21 @@ Definition verify_is_copy revmap n n' := | Some revn => match (Pos.compare n revn) with Eq => OK tt | _ => Error(msg "verify_is_copy invalid map") end end. + Definition verify_match_inst revmap inst tinst := match inst with | Inop n => match tinst with Inop n' => do u <- verify_is_copy revmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end + | Iop op lr r n => match tinst with + Iop op' lr' r' n' => + do u <- verify_is_copy revmap n n'; + if (eq_operation op op') then + if (list_eq_dec Pos.eq_dec lr lr') then + if (Pos.eq_dec r r') then + OK tt + else Error (msg "Different r in Iop") + else Error (msg "Different lr in Iop") + else Error(msg "Different operations in Iop") + | _ => Error(msg "verify_match_inst Inop") end | _ => Error(msg "not implemented") end. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index f3218f5f..d8ca9cd1 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -83,6 +83,13 @@ Proof. (* Inop *) - destruct i'; try (inversion H; fail). monadInv H. eapply verify_is_copy_correct_one. destruct x. eassumption. constructor; eauto. +(* Iop *) + - destruct i'; try (inversion H; fail). monadInv H. + destruct (eq_operation _ _) eqn:EQO; try discriminate. + destruct (list_eq_dec _ _ _) eqn:LEQ; try discriminate. + destruct (Pos.eq_dec _ _) eqn:POS; try discriminate. clear EQ0. subst. + eapply verify_is_copy_correct_one. destruct x. eassumption. + constructor. Qed. Lemma verify_mapping_mn_correct: -- cgit From 6e159e4c2e0978116522f3b6f42a7cbe6b204fe4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 3 Oct 2019 16:44:29 +0200 Subject: Iload and Istore --- backend/Duplicate.v | 24 ++++++++++++++++++++++++ backend/Duplicateproof.v | 22 +++++++++++++++++++--- 2 files changed, 43 insertions(+), 3 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index a96d0826..465b1538 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -60,6 +60,30 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different lr in Iop") else Error(msg "Different operations in Iop") | _ => Error(msg "verify_match_inst Inop") end + | Iload m a lr r n => match tinst with + | Iload m' a' lr' r' n' => + do u <- verify_is_copy revmap n n'; + if (chunk_eq m m') then + if (eq_addressing a a') then + if (list_eq_dec Pos.eq_dec lr lr') then + if (Pos.eq_dec r r') then OK tt + else Error (msg "Different r in Iload") + else Error (msg "Different lr in Iload") + else Error (msg "Different addressing in Iload") + else Error (msg "Different mchunk in Iload") + | _ => Error (msg "verify_match_inst Iload") end + | Istore m a lr r n => match tinst with + | Istore m' a' lr' r' n' => + do u <- verify_is_copy revmap n n'; + if (chunk_eq m m') then + if (eq_addressing a a') then + if (list_eq_dec Pos.eq_dec lr lr') then + if (Pos.eq_dec r r') then OK tt + else Error (msg "Different r in Istore") + else Error (msg "Different lr in Istore") + else Error (msg "Different addressing in Istore") + else Error (msg "Different mchunk in Istore") + | _ => Error (msg "verify_match_inst Istore") end | _ => Error(msg "not implemented") end. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index d8ca9cd1..c2bdf10d 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -85,9 +85,25 @@ Proof. constructor; eauto. (* Iop *) - destruct i'; try (inversion H; fail). monadInv H. - destruct (eq_operation _ _) eqn:EQO; try discriminate. - destruct (list_eq_dec _ _ _) eqn:LEQ; try discriminate. - destruct (Pos.eq_dec _ _) eqn:POS; try discriminate. clear EQ0. subst. + destruct (eq_operation _ _); try discriminate. + destruct (list_eq_dec _ _ _); try discriminate. + destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst. + eapply verify_is_copy_correct_one. destruct x. eassumption. + constructor. +(* Iload *) + - destruct i'; try (inversion H; fail). monadInv H. + destruct (chunk_eq _ _); try discriminate. + destruct (eq_addressing _ _); try discriminate. + destruct (list_eq_dec _ _ _); try discriminate. + destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst. + eapply verify_is_copy_correct_one. destruct x. eassumption. + constructor. +(* Istore *) + - destruct i'; try (inversion H; fail). monadInv H. + destruct (chunk_eq _ _); try discriminate. + destruct (eq_addressing _ _); try discriminate. + destruct (list_eq_dec _ _ _); try discriminate. + destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst. eapply verify_is_copy_correct_one. destruct x. eassumption. constructor. Qed. -- cgit From 79d48fa72a3ac0cd2b84dc8c70eb9170088e0353 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 3 Oct 2019 17:09:03 +0200 Subject: Icall --- backend/Duplicate.v | 19 +++++++++++++++++++ backend/Duplicateproof.v | 8 ++++++++ 2 files changed, 27 insertions(+) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 465b1538..a5e7d92a 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -45,6 +45,13 @@ Definition verify_is_copy revmap n n' := | Some revn => match (Pos.compare n revn) with Eq => OK tt | _ => Error(msg "verify_is_copy invalid map") end end. +Lemma product_eq {A B: Type} : + (forall (a b: A), {a=b} + {a<>b}) -> + (forall (c d: B), {c=d} + {c<>d}) -> + forall (x y: A+B), {x=y} + {x<>y}. +Proof. + intros H H'. intros. decide equality. +Qed. Definition verify_match_inst revmap inst tinst := match inst with @@ -84,6 +91,18 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different addressing in Istore") else Error (msg "Different mchunk in Istore") | _ => Error (msg "verify_match_inst Istore") end + | Icall s ri lr r n => match tinst with + | Icall s' ri' lr' r' n' => + do u <- verify_is_copy revmap n n'; + if (signature_eq s s') then + if (product_eq Pos.eq_dec ident_eq ri ri') then + if (list_eq_dec Pos.eq_dec lr lr') then + if (Pos.eq_dec r r') then OK tt + else Error (msg "Different r r' in Icall") + else Error (msg "Different lr in Icall") + else Error (msg "Different ri in Icall") + else Error (msg "Different signatures in Icall") + | _ => Error (msg "verify_match_inst Icall") end | _ => Error(msg "not implemented") end. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index c2bdf10d..e9799f08 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -106,6 +106,14 @@ Proof. destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst. eapply verify_is_copy_correct_one. destruct x. eassumption. constructor. +(* Icall *) + - destruct i'; try (inversion H; fail). monadInv H. + destruct (signature_eq _ _); try discriminate. + destruct (product_eq _ _ _ _); try discriminate. + destruct (list_eq_dec _ _ _); try discriminate. + destruct (Pos.eq_dec _ _); try discriminate. + eapply verify_is_copy_correct_one. destruct x. eassumption. subst. + constructor. Qed. Lemma verify_mapping_mn_correct: -- cgit From 655c6a861b426db3e5da942faaef7f5caed224e3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 4 Oct 2019 11:38:12 +0200 Subject: Adding decidable equality for int --- lib/Integers.v | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/lib/Integers.v b/lib/Integers.v index f4213332..fca44b1e 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -16,7 +16,7 @@ (** Formalizations of machine integers modulo $2^N$ #2N#. *) Require Import Eqdep_dec Zquot Zwf. -Require Import Coqlib Zbits. +Require Import Coqlib Zbits Axioms. Require Archi. (** * Comparisons *) @@ -101,6 +101,17 @@ Hint Resolve modulus_pos: ints. Record int: Type := mkint { intval: Z; intrange: -1 < intval < modulus }. +Definition int_eq: forall (i1 i2: int), {i1=i2} + {i1<>i2}. +Proof. + generalize Z.eq_dec. intros. + destruct i1. destruct i2. generalize (H intval0 intval1). intro. + inversion H0. + - subst. left. assert (intrange0 = intrange1) by (apply proof_irr). congruence. + - right. intro. inversion H2. contradiction. +Qed. + +(* TODO - continue for the rest *) + (** Fast normalization modulo [2^wordsize] *) Definition Z_mod_modulus (x: Z) : Z := -- cgit From 7b4e6a522bcf1f247ef9b3517af328b5da670a98 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 4 Oct 2019 17:57:25 +0200 Subject: Ibuiltin proof --- backend/Duplicate.v | 24 ++++++++++++++++++ backend/Duplicateproof.v | 7 ++++++ common/AST.v | 19 ++++++++++++++- lib/Floats.v | 63 +++++++++++++++++++++++++++++++++++++++++++++++- lib/Integers.v | 38 ++++++++++++++++++++--------- 5 files changed, 138 insertions(+), 13 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index a5e7d92a..c313e3fa 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -53,6 +53,20 @@ Proof. intros H H'. intros. decide equality. Qed. +(** FIXME Ideally i would like to put this in AST.v but i get an "illegal application" + * error when doing so *) +Remark builtin_arg_eq_pos: forall (a b: builtin_arg positive), {a=b} + {a<>b}. +Proof. + intros. + apply (builtin_arg_eq Pos.eq_dec). +Defined. +Global Opaque builtin_arg_eq_pos. + +Remark builtin_res_eq_pos: forall (a b: builtin_res positive), {a=b} + {a<>b}. +Proof. intros. apply (builtin_res_eq Pos.eq_dec). Qed. +Global Opaque builtin_res_eq_pos. + + Definition verify_match_inst revmap inst tinst := match inst with | Inop n => match tinst with Inop n' => do u <- verify_is_copy revmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end @@ -103,6 +117,16 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different ri in Icall") else Error (msg "Different signatures in Icall") | _ => Error (msg "verify_match_inst Icall") end + | Ibuiltin ef lbar brr n => match tinst with + | Ibuiltin ef' lbar' brr' n' => + do u <- verify_is_copy revmap n n'; + if (external_function_eq ef ef') then + if (list_eq_dec builtin_arg_eq_pos lbar lbar') then + if (builtin_res_eq_pos brr brr') then OK tt + else Error (msg "Different brr in Ibuiltin") + else Error (msg "Different lbar in Ibuiltin") + else Error (msg "Different ef in Ibuiltin") + | _ => Error (msg "verify_match_inst Ibuiltin") end | _ => Error(msg "not implemented") end. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index e9799f08..7369c3ea 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -114,6 +114,13 @@ Proof. destruct (Pos.eq_dec _ _); try discriminate. eapply verify_is_copy_correct_one. destruct x. eassumption. subst. constructor. +(* Ibuiltin *) + - destruct i'; try (inversion H; fail). monadInv H. + destruct (external_function_eq _ _); try discriminate. + destruct (list_eq_dec _ _ _); try discriminate. + destruct (builtin_res_eq_pos _ _); try discriminate. + eapply verify_is_copy_correct_one. destruct x. eassumption. subst. + constructor. Qed. Lemma verify_mapping_mn_correct: diff --git a/common/AST.v b/common/AST.v index a91138c9..7ffe355d 100644 --- a/common/AST.v +++ b/common/AST.v @@ -17,7 +17,7 @@ the abstract syntax trees of many of the intermediate languages. *) Require Import String. -Require Import Coqlib Maps Errors Integers Floats. +Require Import Coqlib Maps Errors Integers Floats BinPos. Require Archi. Set Implicit Arguments. @@ -630,11 +630,28 @@ Inductive builtin_arg (A: Type) : Type := | BA_splitlong (hi lo: builtin_arg A) | BA_addptr (a1 a2: builtin_arg A). +Definition builtin_arg_eq {A: Type}: + (forall x y : A, {x = y} + {x <> y}) -> + forall (ba1 ba2: (builtin_arg A)), {ba1=ba2} + {ba1<>ba2}. +Proof. + intro. generalize Integers.int_eq int64_eq float_eq float32_eq chunk_eq ptrofs_eq ident_eq. + decide equality. +Defined. +Global Opaque builtin_arg_eq. + Inductive builtin_res (A: Type) : Type := | BR (x: A) | BR_none | BR_splitlong (hi lo: builtin_res A). +Definition builtin_res_eq {A: Type}: + (forall x y : A, {x = y} + {x <> y}) -> + forall (a b: builtin_res A), {a=b} + {a<>b}. +Proof. + intro. decide equality. +Defined. +Global Opaque builtin_res_eq. + Fixpoint globals_of_builtin_arg (A: Type) (a: builtin_arg A) : list ident := match a with | BA_loadglobal chunk id ofs => id :: nil diff --git a/lib/Floats.v b/lib/Floats.v index 13350dd0..272efa52 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -16,7 +16,7 @@ (** Formalization of floating-point numbers, using the Flocq library. *) -Require Import Coqlib Zbits Integers. +Require Import Coqlib Zbits Integers Axioms. (*From Flocq*) Require Import Binary Bits Core. Require Import IEEE754_extra. @@ -27,8 +27,69 @@ Close Scope R_scope. Open Scope Z_scope. Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *) + +Definition float_eq: forall (i1 i2: float), {i1=i2} + {i1<>i2}. +Proof. + intros. destruct i1. +(* B754_zero *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ. + + apply eqb_prop in BEQ. subst. left. reflexivity. + + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction. +(* B754_infinity *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ. + + apply eqb_prop in BEQ. subst. left. reflexivity. + + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction. +(* B754_nan *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ. + + generalize (Pos.eq_dec pl pl0). intro. inv H. + ++ left. apply eqb_prop in BEQ. subst. + assert (e = e0) by (apply proof_irr). congruence. + ++ right. intro. inv H. contradiction. + + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction. +(* B754_finite *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ; [apply eqb_prop in BEQ | apply eqb_false_iff in BEQ]. + generalize (Pos.eq_dec m m0). intro. inv H. + generalize (Z.eq_dec e e1). intro. inv H. + 1: { left. assert (e0 = e2) by (apply proof_irr). congruence. } + all: right; intro; inv H; contradiction. +Qed. + Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *) +Definition float32_eq: forall (i1 i2: float32), {i1=i2} + {i1<>i2}. +Proof. + intros. destruct i1. +(* B754_zero *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ. + + apply eqb_prop in BEQ. subst. left. reflexivity. + + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction. +(* B754_infinity *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ. + + apply eqb_prop in BEQ. subst. left. reflexivity. + + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction. +(* B754_nan *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ. + + generalize (Pos.eq_dec pl pl0). intro. inv H. + ++ left. apply eqb_prop in BEQ. subst. + assert (e = e0) by (apply proof_irr). congruence. + ++ right. intro. inv H. contradiction. + + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction. +(* B754_finite *) + - destruct i2; try (right; discriminate). + destruct (eqb s s0) eqn:BEQ; [apply eqb_prop in BEQ | apply eqb_false_iff in BEQ]. + generalize (Pos.eq_dec m m0). intro. inv H. + generalize (Z.eq_dec e e1). intro. inv H. + 1: { left. assert (e0 = e2) by (apply proof_irr). congruence. } + all: right; intro; inv H; contradiction. +Qed. + (** Boolean-valued comparisons *) Definition cmp_of_comparison (c: comparison) (x: option Datatypes.comparison) : bool := diff --git a/lib/Integers.v b/lib/Integers.v index fca44b1e..9c6fcf1d 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -101,17 +101,6 @@ Hint Resolve modulus_pos: ints. Record int: Type := mkint { intval: Z; intrange: -1 < intval < modulus }. -Definition int_eq: forall (i1 i2: int), {i1=i2} + {i1<>i2}. -Proof. - generalize Z.eq_dec. intros. - destruct i1. destruct i2. generalize (H intval0 intval1). intro. - inversion H0. - - subst. left. assert (intrange0 = intrange1) by (apply proof_irr). congruence. - - right. intro. inversion H2. contradiction. -Qed. - -(* TODO - continue for the rest *) - (** Fast normalization modulo [2^wordsize] *) Definition Z_mod_modulus (x: Z) : Z := @@ -4167,8 +4156,26 @@ End Int64. Strategy 0 [Wordsize_64.wordsize]. +Definition int_eq: forall (i1 i2: int), {i1=i2} + {i1<>i2}. +Proof. + generalize Z.eq_dec. intros. + destruct i1. destruct i2. generalize (H intval intval0). intro. + inversion H0. + - subst. left. assert (intrange = intrange0) by (apply proof_irr). congruence. + - right. intro. inversion H2. contradiction. +Qed. + Notation int64 := Int64.int. +Definition int64_eq: forall (i1 i2: int64), {i1=i2} + {i1<>i2}. +Proof. + generalize Z.eq_dec. intros. + destruct i1. destruct i2. generalize (H intval intval0). intro. + inversion H0. + - subst. left. assert (intrange = intrange0) by (apply proof_irr). congruence. + - right. intro. inversion H2. contradiction. +Qed. + Global Opaque Int.repr Int64.repr Byte.repr. (** * Specialization to offsets in pointer values *) @@ -4445,6 +4452,15 @@ Strategy 0 [Wordsize_Ptrofs.wordsize]. Notation ptrofs := Ptrofs.int. +Definition ptrofs_eq: forall (i1 i2: ptrofs), {i1=i2} + {i1<>i2}. +Proof. + generalize Z.eq_dec. intros. + destruct i1. destruct i2. generalize (H intval intval0). intro. + inversion H0. + - subst. left. assert (intrange = intrange0) by (apply proof_irr). congruence. + - right. intro. inversion H2. contradiction. +Qed. + Global Opaque Ptrofs.repr. Hint Resolve Int.modulus_pos Int.eqm_refl Int.eqm_refl2 Int.eqm_sym Int.eqm_trans -- cgit From e7da402f36d030484d11960cf12581fd1c1f159a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Oct 2019 14:51:43 +0200 Subject: Ireturn --- backend/Duplicate.v | 6 +++++- backend/Duplicateproof.v | 4 ++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index c313e3fa..ec03009d 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -66,7 +66,6 @@ Remark builtin_res_eq_pos: forall (a b: builtin_res positive), {a=b} + {a<>b}. Proof. intros. apply (builtin_res_eq Pos.eq_dec). Qed. Global Opaque builtin_res_eq_pos. - Definition verify_match_inst revmap inst tinst := match inst with | Inop n => match tinst with Inop n' => do u <- verify_is_copy revmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end @@ -127,6 +126,11 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different lbar in Ibuiltin") else Error (msg "Different ef in Ibuiltin") | _ => Error (msg "verify_match_inst Ibuiltin") end + | Ireturn or => match tinst with + | Ireturn or' => + if (option_eq Pos.eq_dec or or') then OK tt + else Error (msg "Different or in Ireturn") + | _ => Error (msg "verify_match_inst Ireturn") end | _ => Error(msg "not implemented") end. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 7369c3ea..37c583df 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -121,6 +121,10 @@ Proof. destruct (builtin_res_eq_pos _ _); try discriminate. eapply verify_is_copy_correct_one. destruct x. eassumption. subst. constructor. +(* Ireturn *) + - destruct i'; try (inversion H; fail). + destruct (option_eq _ _ _); try discriminate. subst. clear H. + constructor. Qed. Lemma verify_mapping_mn_correct: -- cgit From 2a5715729f6454a9e664fcce52f269ee8c13e9e1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Oct 2019 14:57:24 +0200 Subject: Itailcall --- backend/Duplicate.v | 9 +++++++++ backend/Duplicateproof.v | 10 ++++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index ec03009d..24fb8e78 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -116,6 +116,15 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different ri in Icall") else Error (msg "Different signatures in Icall") | _ => Error (msg "verify_match_inst Icall") end + | Itailcall s ri lr => match tinst with + | Itailcall s' ri' lr' => + if (signature_eq s s') then + if (product_eq Pos.eq_dec ident_eq ri ri') then + if (list_eq_dec Pos.eq_dec lr lr') then OK tt + else Error (msg "Different lr in Itailcall") + else Error (msg "Different ri in Itailcall") + else Error (msg "Different signatures in Itailcall") + | _ => Error (msg "verify_match_inst Itailcall") end | Ibuiltin ef lbar brr n => match tinst with | Ibuiltin ef' lbar' brr' n' => do u <- verify_is_copy revmap n n'; diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 37c583df..aa605bea 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -26,8 +26,8 @@ Inductive match_inst (is_copy: node -> option node): instruction -> instruction is_copy n' = (Some n) -> match_inst is_copy (Istore m a lr r n) (Istore m a lr r n') | match_inst_call: forall n n' s ri lr r, is_copy n' = (Some n) -> match_inst is_copy (Icall s ri lr r n) (Icall s ri lr r n') - | match_inst_tailcall: forall n n' s ri lr, - is_copy n' = (Some n) -> match_inst is_copy (Itailcall s ri lr) (Itailcall s ri lr) + | match_inst_tailcall: forall s ri lr, + match_inst is_copy (Itailcall s ri lr) (Itailcall s ri lr) | match_inst_builtin: forall n n' ef la br, is_copy n' = (Some n) -> match_inst is_copy (Ibuiltin ef la br n) (Ibuiltin ef la br n') | match_inst_cond: forall ifso ifso' ifnot ifnot' c lr, @@ -114,6 +114,12 @@ Proof. destruct (Pos.eq_dec _ _); try discriminate. eapply verify_is_copy_correct_one. destruct x. eassumption. subst. constructor. +(* Itailcall *) + - destruct i'; try (inversion H; fail). + destruct (signature_eq _ _); try discriminate. + destruct (product_eq _ _ _ _); try discriminate. + destruct (list_eq_dec _ _ _); try discriminate. subst. clear H. + constructor. (* Ibuiltin *) - destruct i'; try (inversion H; fail). monadInv H. destruct (external_function_eq _ _); try discriminate. -- cgit From bd4fbff2badea3922bf0e144777ae8ecfdc30e74 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Oct 2019 15:09:55 +0200 Subject: Fixing identity PTree in Duplicateaux oracle --- backend/Duplicateaux.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 70726c4a..9ff2ae55 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,7 +1,13 @@ open RTL open Maps +let rec make_identity_ptree_rec = function +| [] -> PTree.empty +| m::lm -> let (n, _) = m in PTree.set n n (make_identity_ptree_rec lm) + +let make_identity_ptree f = make_identity_ptree_rec (PTree.elements (fn_code f)) + (* For now, identity function *) let duplicate_aux f = - let pTreeEntry = PTree.set (fn_entrypoint f) (fn_entrypoint f) PTree.empty - in (((fn_code f), (fn_entrypoint f)), pTreeEntry) + let pTreeId = make_identity_ptree f + in (((fn_code f), (fn_entrypoint f)), pTreeId) -- cgit From 5ffa8534d09272e5f44c51193e74cffdbc2b043c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Oct 2019 15:44:20 +0200 Subject: Icond --- backend/Duplicate.v | 17 +++++++++++++++++ backend/Duplicateproof.v | 9 +++++++++ lib/Integers.v | 5 +++++ mppa_k1c/Op.v | 6 ++++++ 4 files changed, 37 insertions(+) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 24fb8e78..0f3c2ba9 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -69,6 +69,7 @@ Global Opaque builtin_res_eq_pos. Definition verify_match_inst revmap inst tinst := match inst with | Inop n => match tinst with Inop n' => do u <- verify_is_copy revmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end + | Iop op lr r n => match tinst with Iop op' lr' r' n' => do u <- verify_is_copy revmap n n'; @@ -80,6 +81,7 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different lr in Iop") else Error(msg "Different operations in Iop") | _ => Error(msg "verify_match_inst Inop") end + | Iload m a lr r n => match tinst with | Iload m' a' lr' r' n' => do u <- verify_is_copy revmap n n'; @@ -92,6 +94,7 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different addressing in Iload") else Error (msg "Different mchunk in Iload") | _ => Error (msg "verify_match_inst Iload") end + | Istore m a lr r n => match tinst with | Istore m' a' lr' r' n' => do u <- verify_is_copy revmap n n'; @@ -104,6 +107,7 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different addressing in Istore") else Error (msg "Different mchunk in Istore") | _ => Error (msg "verify_match_inst Istore") end + | Icall s ri lr r n => match tinst with | Icall s' ri' lr' r' n' => do u <- verify_is_copy revmap n n'; @@ -116,6 +120,7 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different ri in Icall") else Error (msg "Different signatures in Icall") | _ => Error (msg "verify_match_inst Icall") end + | Itailcall s ri lr => match tinst with | Itailcall s' ri' lr' => if (signature_eq s s') then @@ -125,6 +130,7 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different ri in Itailcall") else Error (msg "Different signatures in Itailcall") | _ => Error (msg "verify_match_inst Itailcall") end + | Ibuiltin ef lbar brr n => match tinst with | Ibuiltin ef' lbar' brr' n' => do u <- verify_is_copy revmap n n'; @@ -135,6 +141,17 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different lbar in Ibuiltin") else Error (msg "Different ef in Ibuiltin") | _ => Error (msg "verify_match_inst Ibuiltin") end + + | Icond cond lr n1 n2 => match tinst with + | Icond cond' lr' n1' n2' => + do u1 <- verify_is_copy revmap n1 n1'; + do u2 <- verify_is_copy revmap n2 n2'; + if (condition_eq cond cond') then + if (list_eq_dec Pos.eq_dec lr lr') then OK tt + else Error (msg "Different lr in Icond") + else Error (msg "Different cond in Icond") + | _ => Error (msg "verify_match_inst Icond") end + | Ireturn or => match tinst with | Ireturn or' => if (option_eq Pos.eq_dec or or') then OK tt diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index aa605bea..ba1fecc1 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -127,6 +127,15 @@ Proof. destruct (builtin_res_eq_pos _ _); try discriminate. eapply verify_is_copy_correct_one. destruct x. eassumption. subst. constructor. +(* Icond *) + - destruct i'; try (inversion H; fail). monadInv H. + unfold verify_is_copy in EQ, EQ1. + destruct (_ ! n1) eqn:REVM; [|inversion EQ]. + destruct (n ?= p) eqn:NP; try (inversion EQ; fail). eapply Pos.compare_eq in NP. subst. inv EQ. + destruct (_ ! n2) eqn:REVMM; [|inversion EQ1]. + destruct (n0 ?= p0) eqn:NP0; try (inversion EQ1; fail). eapply Pos.compare_eq in NP0. subst. inv EQ1. + destruct (condition_eq _ _); try discriminate. + destruct (list_eq_dec _ _ _); try discriminate. subst. constructor; assumption. (* Ireturn *) - destruct i'; try (inversion H; fail). destruct (option_eq _ _ _); try discriminate. subst. clear H. diff --git a/lib/Integers.v b/lib/Integers.v index 9c6fcf1d..08a416c1 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -29,6 +29,11 @@ Inductive comparison : Type := | Cgt : comparison (**r greater than *) | Cge : comparison. (**r greater than or equal *) +Definition comparison_eq: forall (x y: comparison), {x = y} + {x <> y}. +Proof. + decide equality. +Defined. + Definition negate_comparison (c: comparison): comparison := match c with | Ceq => Cne diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index f9a774e8..ce9a5dcd 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -51,6 +51,12 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) +Definition condition_eq: forall (x y: condition), {x = y} + {x <> y}. +Proof. + generalize comparison_eq int_eq int64_eq. + decide equality. +Defined. + Inductive condition0 : Type := | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) -- cgit From cb7d444a5a97626a794f2167c2a4bc4d51f4ed67 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Oct 2019 17:06:06 +0200 Subject: Finished Duplicate proof. --- backend/Duplicate.v | 19 +++++++++++- backend/Duplicateproof.v | 75 ++++++++++++++++++++++++++---------------------- 2 files changed, 58 insertions(+), 36 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 0f3c2ba9..d1458bd4 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -45,6 +45,17 @@ Definition verify_is_copy revmap n n' := | Some revn => match (Pos.compare n revn) with Eq => OK tt | _ => Error(msg "verify_is_copy invalid map") end end. +Fixpoint verify_is_copy_list revmap ln ln' := + match ln with + | n::ln => match ln' with + | n'::ln' => do u <- verify_is_copy revmap n n'; + verify_is_copy_list revmap ln ln' + | nil => Error (msg "verify_is_copy_list: ln' bigger than ln") end + | nil => match ln' with + | n :: ln' => Error (msg "verify_is_copy_list: ln bigger than ln'") + | nil => OK tt end + end. + Lemma product_eq {A B: Type} : (forall (a b: A), {a=b} + {a<>b}) -> (forall (c d: B), {c=d} + {c<>d}) -> @@ -152,12 +163,18 @@ Definition verify_match_inst revmap inst tinst := else Error (msg "Different cond in Icond") | _ => Error (msg "verify_match_inst Icond") end + | Ijumptable r ln => match tinst with + | Ijumptable r' ln' => + do u <- verify_is_copy_list revmap ln ln'; + if (Pos.eq_dec r r') then OK tt + else Error (msg "Different r in Ijumptable") + | _ => Error (msg "verify_match_inst Ijumptable") end + | Ireturn or => match tinst with | Ireturn or' => if (option_eq Pos.eq_dec or or') then OK tt else Error (msg "Different or in Ireturn") | _ => Error (msg "verify_match_inst Ireturn") end - | _ => Error(msg "not implemented") end. Definition verify_mapping_mn f xf (m: positive*positive) := diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index ba1fecc1..54dd6196 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -51,26 +51,26 @@ Proof. + monadInv H0. destruct x0. eapply IHlb; assumption. Qed. -Inductive rtl_one_successor : node -> node -> instruction -> instruction -> Prop := - | inop_one_succ : forall n n', rtl_one_successor n n' (Inop n) (Inop n') - | iop_one_succ : forall op lr r n n', rtl_one_successor n n' (Iop op lr r n) (Iop op lr r n') - | iload_one_succ : forall m a lr r n n', rtl_one_successor n n' (Iload m a lr r n) (Iload m a lr r n') - | istore_one_succ : forall m a lr r n n', rtl_one_successor n n' (Istore m a lr r n) (Istore m a lr r n') - | icall_one_succ : forall s ri lr r n n', rtl_one_successor n n' (Icall s ri lr r n) (Icall s ri lr r n') - | ibuiltin_one_succ : forall ef lbr br n n', rtl_one_successor n n' (Ibuiltin ef lbr br n) (Ibuiltin ef lbr br n') -. - -Lemma verify_is_copy_correct_one: - forall xf n n' i i', +Lemma verify_is_copy_correct: + forall xf n n', verify_is_copy (fn_revmap xf) n n' = OK tt -> - rtl_one_successor n n' i i' -> - match_inst (fun nn => (fn_revmap xf) ! nn) i i'. + (fn_revmap xf) ! n' = Some n. Proof. intros. unfold verify_is_copy in H. destruct (_ ! n') eqn:REVM; [|inversion H]. - destruct (n ?= p) eqn:NP; try (inversion H; fail). clear H. + destruct (n ?= n0) eqn:NP; try (inversion H; fail). eapply Pos.compare_eq in NP. subst. - inv H0. - all: constructor; eauto. + reflexivity. +Qed. + +Lemma verify_is_copy_list_correct: + forall xf ln ln', + verify_is_copy_list (fn_revmap xf) ln ln' = OK tt -> + list_forall2 (fun n n' => (fn_revmap xf) ! n' = Some n) ln ln'. +Proof. + induction ln. + - intros. destruct ln'; monadInv H. constructor. + - intros. destruct ln'; monadInv H. destruct x. apply verify_is_copy_correct in EQ. + eapply IHln in EQ0. constructor; assumption. Qed. Lemma verify_match_inst_correct: @@ -81,39 +81,40 @@ Proof. intros. unfold verify_match_inst in H. destruct i; try (inversion H; fail). (* Inop *) - - destruct i'; try (inversion H; fail). monadInv H. eapply verify_is_copy_correct_one. destruct x. eassumption. + - destruct i'; try (inversion H; fail). monadInv H. + destruct x. eapply verify_is_copy_correct in EQ. constructor; eauto. (* Iop *) - destruct i'; try (inversion H; fail). monadInv H. + destruct x. eapply verify_is_copy_correct in EQ. destruct (eq_operation _ _); try discriminate. destruct (list_eq_dec _ _ _); try discriminate. destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst. - eapply verify_is_copy_correct_one. destruct x. eassumption. - constructor. + constructor. assumption. (* Iload *) - destruct i'; try (inversion H; fail). monadInv H. + destruct x. eapply verify_is_copy_correct in EQ. destruct (chunk_eq _ _); try discriminate. destruct (eq_addressing _ _); try discriminate. destruct (list_eq_dec _ _ _); try discriminate. destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst. - eapply verify_is_copy_correct_one. destruct x. eassumption. - constructor. + constructor. assumption. (* Istore *) - destruct i'; try (inversion H; fail). monadInv H. + destruct x. eapply verify_is_copy_correct in EQ. destruct (chunk_eq _ _); try discriminate. destruct (eq_addressing _ _); try discriminate. destruct (list_eq_dec _ _ _); try discriminate. destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst. - eapply verify_is_copy_correct_one. destruct x. eassumption. - constructor. + constructor. assumption. (* Icall *) - destruct i'; try (inversion H; fail). monadInv H. + destruct x. eapply verify_is_copy_correct in EQ. destruct (signature_eq _ _); try discriminate. destruct (product_eq _ _ _ _); try discriminate. destruct (list_eq_dec _ _ _); try discriminate. - destruct (Pos.eq_dec _ _); try discriminate. - eapply verify_is_copy_correct_one. destruct x. eassumption. subst. - constructor. + destruct (Pos.eq_dec _ _); try discriminate. subst. + constructor. assumption. (* Itailcall *) - destruct i'; try (inversion H; fail). destruct (signature_eq _ _); try discriminate. @@ -122,26 +123,30 @@ Proof. constructor. (* Ibuiltin *) - destruct i'; try (inversion H; fail). monadInv H. + destruct x. eapply verify_is_copy_correct in EQ. destruct (external_function_eq _ _); try discriminate. destruct (list_eq_dec _ _ _); try discriminate. - destruct (builtin_res_eq_pos _ _); try discriminate. - eapply verify_is_copy_correct_one. destruct x. eassumption. subst. - constructor. + destruct (builtin_res_eq_pos _ _); try discriminate. subst. + constructor. assumption. (* Icond *) - destruct i'; try (inversion H; fail). monadInv H. - unfold verify_is_copy in EQ, EQ1. - destruct (_ ! n1) eqn:REVM; [|inversion EQ]. - destruct (n ?= p) eqn:NP; try (inversion EQ; fail). eapply Pos.compare_eq in NP. subst. inv EQ. - destruct (_ ! n2) eqn:REVMM; [|inversion EQ1]. - destruct (n0 ?= p0) eqn:NP0; try (inversion EQ1; fail). eapply Pos.compare_eq in NP0. subst. inv EQ1. + destruct x. eapply verify_is_copy_correct in EQ. + destruct x0. eapply verify_is_copy_correct in EQ1. destruct (condition_eq _ _); try discriminate. - destruct (list_eq_dec _ _ _); try discriminate. subst. constructor; assumption. + destruct (list_eq_dec _ _ _); try discriminate. subst. + constructor; assumption. +(* Ijumptable *) + - destruct i'; try (inversion H; fail). monadInv H. + destruct x. eapply verify_is_copy_list_correct in EQ. + destruct (Pos.eq_dec _ _); try discriminate. subst. + constructor. assumption. (* Ireturn *) - destruct i'; try (inversion H; fail). destruct (option_eq _ _ _); try discriminate. subst. clear H. constructor. Qed. + Lemma verify_mapping_mn_correct: forall mp n n' i f xf tc, mp ! n' = Some n -> -- cgit From 45e689e558d839b512d39b0e25083b5928f5dd58 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 9 Oct 2019 17:09:13 +0200 Subject: Removing Coq 8.7.* in configure (not compatible with "3: {..}" directives) --- configure | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure b/configure index 626bf3aa..51dc3e41 100755 --- a/configure +++ b/configure @@ -541,14 +541,14 @@ 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.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10) + 8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" 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.10, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" + echo "Error: CompCert requires one of the following Coq versions: 8.10, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0" missingtools=true fi;; "") -- cgit From 284318e533d3f2a659b65722f7d354f59396ab06 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 9 Oct 2019 17:11:03 +0200 Subject: [BROKEN] Implementing trace selection from Chang & Hwu 1988, to be debugged --- backend/Duplicateaux.ml | 165 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 163 insertions(+), 2 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 9ff2ae55..d0df9b23 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,5 +1,162 @@ open RTL open Maps +open Camlcoq + +(* TTL : IR emphasizing the preferred next node *) +module TTL = struct + type instruction = + | Tleaf of RTL.instruction + | Tnext of node * RTL.instruction + + type code = instruction PTree.t +end;; + +open TTL + +(** RTL to TTL *) + +(* FIXME - for now, random choice *) + +let select_one n n' = if Random.bool () then n else n' + +let to_ttl_inst = function +| Ireturn o -> Tleaf (Ireturn o) +| Inop n -> Tnext (n, Inop n) +| Iop (op, lr, r, n) -> Tnext (n, Iop(op, lr, r, n)) +| Iload (m, a, lr, r, n) -> Tnext (n, Iload(m, a, lr, r, n)) +| Istore (m, a, lr, r, n) -> Tnext (n, Istore(m, a, lr, r, n)) +| Icall (s, ri, lr, r, n) -> Tnext (n, Icall(s, ri, lr, r, n)) +| Itailcall (s, ri, lr) -> Tleaf (Itailcall(s, ri, lr)) +| Ibuiltin (ef, lbr, br, n) -> Tnext (n, Ibuiltin(ef, lbr, br, n)) +| Icond (cond, lr, n, n') -> Tnext (select_one n n', Icond(cond, lr, n, n')) +| Ijumptable (r, ln) -> Tnext (List.hd ln, Ijumptable(r, ln)) + +let rec to_ttl_code_rec = function +| [] -> PTree.empty +| m::lm -> let (n, i) = m in PTree.set n (to_ttl_inst i) (to_ttl_code_rec lm) + +let to_ttl_code code = begin + Random.init(0); (* using same seed to make it deterministic *) + to_ttl_code_rec (PTree.elements code) +end + +(** Trace selection on TTL *) + +let rec exists_false_rec = function + | [] -> false + | m::lm -> let (_, b) = m in if b then exists_false_rec lm else true + +let exists_false boolmap = exists_false_rec (PTree.elements boolmap) + +let get_some = function +| None -> failwith "Did not get some" +| Some thing -> thing + +(* FIXME - heuristic : starting from entrypoint, then going downward *) +let bfs code entrypoint = + let visited = ref (PTree.map (fun n i -> false) code) in + let rec bfs_list code = function + | [] -> [] + | node :: ln -> + let node_bfs = + if not (get_some @@ PTree.get node !visited) then begin + visited := PTree.set node true !visited; + match PTree.get node code with + | None -> failwith "No such node" + | Some ti -> [node] @ match ti with + | Tleaf i -> [] + | Tnext (n,i) -> (bfs_list code [n]) @ match i with + | Icond (_, _, n1, n2) -> bfs_list code [n1; n2] + | Ijumptable (_, ln) -> bfs_list code ln + | _ -> [] + end + else [] + in node_bfs @ (bfs_list code ln) + in bfs_list code [entrypoint] + +let rec select_unvisited_node is_visited = function +| [] -> failwith "Empty list" +| n :: ln -> if (get_some @@ PTree.get n is_visited) then n else select_unvisited_node is_visited ln + +let best_successor_of node code = + match (PTree.get node code) with + | None -> failwith "No such node in the code" + | Some ti -> match ti with + | Tleaf _ -> None + | Tnext (n,_) -> Some n + +let best_predecessor_of node predecessors order = + match (PTree.get node predecessors) with + | None -> failwith "No predecessor list found" + | Some lp -> try Some (List.find (fun n -> List.mem n lp) order) + with Not_found -> None + +let get_predecessors 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 + +(* Algorithm from Chang and Hwu 1988 + * "Trace Selection for Compiling Large C Application Programs to Microcode" *) +let select_trace code entrypoint = + let order = bfs code entrypoint in + let predecessors = get_predecessors code in + let trace = ref [] in + let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *) + while exists_false !is_visited do (* while (there are unvisited nodes) *) + let seed = select_unvisited_node !is_visited order in + let current = ref seed in begin + is_visited := PTree.set seed true !is_visited; (* mark seed visited *) + let quit_loop = ref false in begin + while not !quit_loop do + let s = best_successor_of !current code in + match s with + | None -> quit_loop := true (* if (s==0) exit loop *) + | Some succ -> begin + trace := succ :: !trace; (* FIXME - reverse append *) + is_visited := PTree.set succ true !is_visited; (* mark s visited *) + current := succ + end + done; + current := seed; + quit_loop := false; + while not !quit_loop do + let s = best_predecessor_of !current predecessors order in + match s with + | None -> quit_loop := true (* if (s==0) exit loop *) + | Some pred -> begin + trace := pred :: !trace; + is_visited := PTree.set pred true !is_visited; (* mark s visited *) + current := pred + end + done + end + end + done; + !trace + end + +(* for debugging *) +let print_trace trace = + let rec f = function + | [] -> () + | n::ln -> (Printf.printf "%d " (P.to_int n); f ln) + in begin + Printf.printf "Trace: ["; + f trace; + Printf.printf "]\n" + end let rec make_identity_ptree_rec = function | [] -> PTree.empty @@ -9,5 +166,9 @@ let make_identity_ptree f = make_identity_ptree_rec (PTree.elements (fn_code f)) (* For now, identity function *) let duplicate_aux f = - let pTreeId = make_identity_ptree f - in (((fn_code f), (fn_entrypoint f)), pTreeId) + let pTreeId = make_identity_ptree f in + let trace = select_trace (to_ttl_code @@ fn_code f) (fn_entrypoint f) + in begin + print_trace trace; + (((fn_code f), (fn_entrypoint f)), pTreeId) + end -- cgit From 75326127cbb4d57d435b28651ef65dcd2a0b8ce5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Oct 2019 11:49:31 +0200 Subject: Fixing fp_is_parent too weak (#165) --- mppa_k1c/Asmblockgen.v | 4 +- mppa_k1c/Asmblockgenproof.v | 3605 ++++++++++++++++++++++--------------------- 2 files changed, 1811 insertions(+), 1798 deletions(-) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ade84e7b..bbe24fec 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1111,10 +1111,12 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := match i with + | MBgetstack ofs ty dst => before && negb (mreg_eq dst MFP) | MBsetstack src ofs ty => before | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) | MBop op args res => before && negb (mreg_eq res MFP) - | _ => false + | MBload chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBstore chunk addr args res => before end. (** This is the naive definition, which is not tail-recursive unlike the other backends *) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 1c5ad19c..ad4d2932 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,1797 +1,1808 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for RISC-V generation: main proof. *) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. -Require Import Axioms. - -Module MB := Machblock. -Module AB := Asmvliw. - -Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Section PRESERVATION. - -Variable prog: Machblock.program. -Variable tprog: Asmvliw.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -(** * Properties of control flow *) - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - omega. -Qed. - -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. - -Lemma gen_bblocks_label: - forall hd bdy ex tbb tc, - gen_bblocks hd bdy ex = tbb::tc -> - header tbb = hd. -Proof. - intros until tc. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Lemma gen_bblocks_label2: - forall hd bdy ex tbb1 tbb2, - gen_bblocks hd bdy ex = tbb1::tbb2::nil -> - header tbb2 = nil. -Proof. - intros until tbb2. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Lemma in_dec_transl: - forall lbl hd, - (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). -Proof. - intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. -Qed. - -Lemma transl_is_label: - forall lbl bb tbb f ep tc, - transl_block f bb ep = OK (tbb::tc) -> - is_label lbl tbb = MB.is_label lbl bb. -Proof. - intros until tc. intros TLB. - destruct tbb as [thd tbdy tex]; simpl in *. - monadInv TLB. - unfold is_label. simpl. - apply gen_bblocks_label in H0. simpl in H0. subst. - rewrite in_dec_transl. auto. -Qed. - -Lemma transl_is_label_false2: - forall lbl bb f ep tbb1 tbb2, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb2 = false. -Proof. - intros until tbb2. intros TLB. - destruct tbb2 as [thd tbdy tex]; simpl in *. - monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. - apply is_label_correct_false. simpl. auto. -Qed. - -Lemma transl_is_label2: - forall f bb ep tbb1 tbb2 lbl, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb1 = MB.is_label lbl bb - /\ is_label lbl tbb2 = false. -Proof. - intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. -Qed. - -Lemma transl_block_nonil: - forall f c ep tc, - transl_block f c ep = OK tc -> - tc <> nil. -Proof. - intros. monadInv H. unfold gen_bblocks. - destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. - all: discriminate. -Qed. - -Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, - ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). -Proof. - intros. intro. monadInv H. - unfold gen_bblocks in H0. - destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. - all: discriminate. -Qed. - -Lemma find_label_transl_false: - forall x f lbl bb ep x', - transl_block f bb ep = OK x -> - MB.is_label lbl bb = false -> - find_label lbl (x++x') = find_label lbl x'. -Proof. - intros until x'. intros TLB MBis; simpl; auto. - destruct x as [|x0 x1]; simpl; auto. - destruct x1 as [|x1 x2]; simpl; auto. - - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. - - destruct x2 as [|x2 x3]; simpl; auto. - + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. - erewrite transl_is_label_false2; eauto. - + apply transl_block_limit in TLB. destruct TLB. -Qed. - -Lemma transl_blocks_label: - forall lbl f c tc ep, - transl_blocks f c ep = OK tc -> - match MB.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. - destruct (MB.is_label lbl a) eqn:MBis. - - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } - simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. - rewrite ABis. - eexists. eexists. split; eauto. simpl transl_blocks. - assert (MB.header a <> nil). - { apply MB.is_label_correct_true in MBis. - destruct (MB.header a). contradiction. discriminate. } - destruct (MB.header a); try contradiction. - rewrite EQ. simpl. rewrite EQ1. simpl. auto. - - apply IHc in EQ1. destruct (MB.find_label lbl c). - + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. - erewrite find_label_transl_false; eauto. - + erewrite find_label_transl_false; eauto. -Qed. - -Lemma find_label_nil: - forall bb lbl c, - header bb = nil -> - find_label lbl (bb::c) = find_label lbl c. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. subst. - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { erewrite <- is_label_correct_false. simpl. auto. } - rewrite H. auto. -Qed. - -Lemma transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match MB.find_label lbl f.(MB.fn_code) with - | None => find_label lbl tf.(fn_blocks) = None - | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. - monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. - eapply transl_blocks_label; eauto. -Qed. - -End TRANSL_LABEL. - -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated Asm code. *) - -Lemma find_label_goto_label: - forall f tf lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - transf_function f = OK tf -> - rs PC = Vptr b ofs -> - MB.find_label lbl f.(MB.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros (tc & A & B). - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) - -(* NB: the hypothesis in comment on [b] is not needed in the proof ! -*) -Lemma return_address_exists: - forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. eapply Asmblockgenproof0.return_address_exists; eauto. - -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. -(* rewrite transl_code'_transl_code in EQ0. *) - exists x; exists true; split; auto. (* unfold fn_code. *) - repeat constructor. - - exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - -(** Semantic preservation is proved using simulation diagrams - of the following form. -<< - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' ->> - The invariant is the [match_states] predicate below, which includes: -- The Asm code pointed by the PC register is the translation of - the current Mach code sequence. -- Mach register values and Asm register values agree. -*) - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the Asm side. Actually, all Mach transitions - correspond to at least one Asm transition, except the - transition from [Machsem.Returnstate] to [Machsem.State]. - So, the following integer measure will suffice to rule out - the unwanted behaviour. *) - - -Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. -Proof. - intros. change (IR FP) with (preg_of MFP). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. - -Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), - match_states (Machblock.State s fb sp c ms m) - (Asmvliw.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Machblock.Callstate s fb ms m) - (Asmvliw.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Machblock.Returnstate s ms m) - (Asmvliw.State rs m'). - -Record codestate := - Codestate { pstate: state; - pheader: list label; - pbody1: list basic; - pbody2: list basic; - pctl: option control; - ep: bool; - rem: list AB.bblock; - cur: bblock }. - -(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) - -Inductive match_codestate fb: Machblock.state -> codestate -> Prop := - | match_codestate_intro: - forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m0) - (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) - (TIC: transl_instr_control f (MB.exit bb) = OK tbi) - (TBLS: transl_blocks f c false = OK tc) -(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) - (AG: agree ms sp rs0) - (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) - , - match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - {| pstate := (Asmvliw.State rs0 m0); - pheader := (MB.header bb); - pbody1 := tbc; - pbody2 := (extract_basic tbi); - pctl := extract_ctl tbi; - ep := ep; - rem := tc; - cur := tbb - |} -. - -Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := - | match_asmstate_some: - forall rs f tf tc m tbb ofs ep tbdy tex lhd - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (TRANSF: transf_function f = OK tf) - (PCeq: rs PC = Vptr fb ofs) - (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) -(* (HDROK: header tbb = lhd) *) - , - match_asmstate fb - {| pstate := (Asmvliw.State rs m); - pheader := lhd; - pbody1 := tbdy; - pbody2 := extract_basic tex; - pctl := extract_ctl tex; - ep := ep; - rem := tc; - cur := tbb |} - (Asmvliw.State rs m) -. - -Ltac exploreInst := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ |- context[if ?b then _ else _] ] => destruct b - | [ |- context[match ?m with | _ => _ end] ] => destruct m - | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - end. - -Lemma transl_blocks_nonil: - forall f bb c tc ep, - transl_blocks f (bb::c) ep = OK tc -> - exists tbb tc', tc = tbb :: tc'. -Proof. - intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. - destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - - destruct x1; simpl; eauto. -Qed. - -Lemma no_builtin_preserved: - forall f ex x2, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x2 -> - (exists i, extract_ctl x2 = Some (PCtlFlow i)) - \/ extract_ctl x2 = None. -Proof. - intros until x2. intros Hbuiltin TIC. - destruct ex. - - destruct c. - (* MBcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBtailcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBbuiltin *) - + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). - apply Hbuiltin. contradict H; auto. - (* MBgoto *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBcond *) - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. - * unfold transl_opt_compuimm. exploreInst; simpl; eauto. - * unfold transl_opt_compluimm. exploreInst; simpl; eauto. - * unfold transl_comp_float64. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. - * unfold transl_comp_float32. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. - (* MBjumptable *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBreturn *) - + simpl in TIC. monadInv TIC. simpl. eauto. - - monadInv TIC. simpl; auto. -Qed. - -Lemma transl_blocks_distrib: - forall c f bb tbb tc ep, - transl_blocks f (bb::c) ep = OK (tbb::tc) - -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) - -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) - /\ transl_blocks f c false = OK tc. -Proof. - intros until ep0. intros TLBS Hbuiltin. - destruct bb as [hd bdy ex]. - monadInv TLBS. monadInv EQ. - exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. - - destruct H as [i Hectl]. - unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. - simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite Hectl. auto. - - unfold gen_bblocks in H0. rewrite H in H0. - destruct x1 as [|bi x1]. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. -Qed. - -Lemma gen_bblocks_nobuiltin: - forall thd tbdy tex tbb, - (tbdy <> nil \/ extract_ctl tex <> None) -> - (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> - gen_bblocks thd tbdy tex = tbb :: nil -> - header tbb = thd - /\ body tbb = tbdy ++ extract_basic tex - /\ exit tbb = extract_ctl tex. -Proof. - intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl tex) eqn:ECTL. - - destruct c. - + destruct i; try (inv GENB; simpl; auto; fail). - assert False. eapply Hnobuiltin. eauto. destruct H. - + inv GENB. simpl. auto. - - inversion Hnonil. - + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. - + contradict H; simpl; auto. -Qed. - -Lemma transl_instr_basic_nonil: - forall k f bi ep x, - transl_instr_basic f bi ep k = OK x -> - x <> nil. -Proof. - intros until x. intros TIB. - destruct bi. - - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. - - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. - - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. - - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. - unfold transl_cond_op in EQ0. exploreInst; try discriminate. - unfold transl_cond_float64. exploreInst; try discriminate. - unfold transl_cond_notfloat64. exploreInst; try discriminate. - unfold transl_cond_float32. exploreInst; try discriminate. - unfold transl_cond_notfloat32. exploreInst; try discriminate. - - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. - - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. -Qed. - -Lemma transl_basic_code_nonil: - forall bdy f x ep, - bdy <> nil -> - transl_basic_code f bdy ep = OK x -> - x <> nil. -Proof. - induction bdy as [|bi bdy]. - intros. contradict H0; auto. - destruct bdy as [|bi2 bdy]. - - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. - - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. - monadInv TBC. - assert (x0 <> nil). - eapply IHbdy; eauto. subst bdy'. discriminate. - eapply transl_instr_basic_nonil; eauto. -Qed. - -Lemma transl_instr_control_nonil: - forall ex f x, - ex <> None -> - transl_instr_control f ex = OK x -> - extract_ctl x <> None. -Proof. - intros ex f x Hnonil TIC. - destruct ex as [ex|]. - - clear Hnonil. destruct ex. - all: try (simpl in TIC; exploreInst; discriminate). - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. - * unfold transl_opt_compuimm. exploreInst; try discriminate. - * unfold transl_opt_compluimm. exploreInst; try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. - - contradict Hnonil; auto. -Qed. - -Lemma transl_instr_control_nobuiltin: - forall f ex x, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x -> - (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). -Proof. - intros until x. intros Hnobuiltin TIC. intros until res. - unfold transl_instr_control in TIC. exploreInst. - all: try discriminate. - - assert False. eapply Hnobuiltin; eauto. destruct H. - - unfold transl_cbranch in TIC. exploreInst. - all: try discriminate. - * unfold transl_opt_compuimm. exploreInst. all: try discriminate. - * unfold transl_opt_compluimm. exploreInst. all: try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. -Qed. - -Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m, - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - (MB.body bb <> nil \/ MB.exit bb <> None) -> - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - match_states mbs abs -> - exists cs fb f tbb tc ep, - match_codestate fb mbs cs /\ match_asmstate fb cs abs - /\ Genv.find_funct_ptr ge fb = Some (Internal f) - /\ transl_blocks f (bb::c) ep = OK (tbb::tc) - /\ body tbb = pbody1 cs ++ pbody2 cs - /\ exit tbb = pctl cs - /\ cur cs = tbb /\ rem cs = tc - /\ pstate cs = abs. -Proof. - intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. - inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. - exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. - monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. - { inversion Hnotempty. - - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). - left. eapply transl_basic_code_nonil; eauto. - - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). - right. eapply transl_instr_control_nonil; eauto. } - eapply transl_instr_control_nobuiltin; eauto. - intros (Hth & Htbdy & Htexit). - exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; - pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. - repeat split. 1-2: econstructor; eauto. - { destruct (MB.header bb). eauto. discriminate. } eauto. - unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. - rewrite TLBS. simpl. rewrite H2. - all: simpl; auto. -Qed. - -Definition mb_remove_body (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. - -Lemma exec_straight_pnil: - forall c rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 -> - exec_straight tge c rs1 m1 nil rs2 m2. -Proof. - intros. eapply exec_straight_trans. eapply H. econstructor; eauto. -Qed. - -Lemma transl_block_nobuiltin: - forall f bb ep tbb, - (MB.body bb <> nil \/ MB.exit bb <> None) -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - transl_block f bb ep = OK (tbb :: nil) -> - exists c c', - transl_basic_code f (MB.body bb) ep = OK c - /\ transl_instr_control f (MB.exit bb) = OK c' - /\ body tbb = c ++ extract_basic c' - /\ exit tbb = extract_ctl c'. -Proof. - intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. -Qed. - -Lemma nextblock_preserves: - forall rs rs' bb r, - rs' = nextblock bb rs -> - data_preg r = true -> - rs r = rs' r. -Proof. - intros. destruct r; try discriminate. - subst. Simpl. -(* - subst. Simpl. *) -Qed. - -Lemma cons3_app {A: Type}: - forall a b c (l: list A), - a :: b :: c :: l = (a :: b :: c :: nil) ++ l. -Proof. - intros. simpl. auto. -Qed. - -Lemma exec_straight_opt_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight_opt tge c rs1 m1 c' rs2 m2 -> - exists body, - exec_body tge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. intros EXES. - inv EXES. - - exists nil. split; auto. - - eapply exec_straight_body2. auto. -Qed. - -Lemma extract_basics_to_code: - forall lb c, - extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -Lemma extract_ctl_basics_to_code: - forall lb c, - extract_ctl (basics_to_code lb ++ c) = extract_ctl c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -(* Lemma goto_label_inv: - forall fn tbb l rs m b ofs, - rs PC = Vptr b ofs -> - goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m. -Proof. - intros. - unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H. - exploreInst; auto. - unfold nextblock. rewrite Pregmap.gss. - -Qed. - - -Lemma exec_control_goto_label_inv: - exec_control tge fn (Some ctl) rs m = goto_label fn l rs m -> - exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m. -Proof. -Qed. *) - -Theorem step_simu_control: - forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2, - MB.body bb' = nil -> - (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> - Genv.find_funct_ptr tge fb = Some (Internal fn) -> - pstate cs2 = (Asmvliw.State rs2 m2) -> - pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> - cur cs2 = tbb -> - match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> - match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> - exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> - (exists rs3 m3 rs4 m4, - exec_body tge tbdy2 rs2 m2 = Next rs3 m3 - /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 - /\ match_states S'' (State rs4 m4)). -Proof. - intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. - inv ESTEP. - - inv MCS. inv MAS. simpl in *. - inv Hpstate. - destruct ctl. - + (* MBcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct s1 as [rf|fid]; simpl in H7. - * (* Indirect call *) - monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. - revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - { econstructor; eauto. } - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. - - * (* Direct call *) - monadInv H1. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - econstructor; eauto. - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. - Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. - + (* MBtailcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. - destruct s1 as [rf|fid]; simpl in H13. - * monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - - assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - { simpl. eauto. } - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). - { clear - EQ. destruct x; repeat split; try discriminate. - all: unfold ireg_of in EQ; destruct rf; try discriminate. } - Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. - * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } - + (* MBbuiltin (contradiction) *) - assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). - rewrite <- H in H1. contradict H1; auto. - + (* MBgoto *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. - remember (nextblock tbb rs2) as rs2'. - (* inv AT. monadInv H4. *) - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - exploit find_label_goto_label. - eauto. eauto. - instantiate (2 := rs2'). - { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } - eauto. - intros (tc' & rs' & GOTO & AT2 & INV). - - eexists. eexists. repeat eexists. repeat split. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. - econstructor; eauto. - rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. - eapply agree_exten; eauto with asmgen. - assert (forall r : preg, r <> PC -> rs' r = rs2 r). - { intros. destruct r. - - destruct g. all: rewrite INV; Simpl; auto. -(* - destruct g. all: rewrite INV; Simpl; auto. *) - - rewrite INV; Simpl; auto. - - contradiction. } - eauto with asmgen. - congruence. - + (* MBcond *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - * (* MBcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. - 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. - unfold Val.offset_ptr. rewrite PCeq. eauto. - intros (tc' & rs3 & GOTOL & TLPC & Hrs3). - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - - * (* MBcond false *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - - exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - + (* MBjumptable *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - monadInv H1. - generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. - - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. - - repeat eexists. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. - econstructor; eauto. - eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. - { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. - destruct (preg_eq r' GPR63). subst. contradiction. - destruct (preg_eq r' GPR62). subst. contradiction. - destruct r'; Simpl. } - discriminate. - + (* MBreturn *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - assert (f1 = f) by congruence. subst f1. - - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - - - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. -(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) - intros (TLB & TLBS). - *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. -(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *) - monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. - simpl. repeat eexists. - econstructor. 4: instantiate (3 := false). all:eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - assert (f = f0) by congruence. subst f0. econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - discriminate. -Qed. - -Definition mb_remove_first (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. - -Lemma exec_straight_body: - forall c c' lc rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 c' rs2 m2 -> - code_to_basics c = Some lc -> - exists l ll, - c = l ++ c' - /\ code_to_basics l = Some ll - /\ exec_body tge ll rs1 m1 = Next rs2 m2. -Proof. - induction c; try (intros; inv H; fail). - intros until m2. intros EXES CTB. inv EXES. - - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. - - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. - eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. - exists (i ::g l'),(i::ll). repeat (split; simpl; auto). - rewrite CTB. auto. - rewrite H1. auto. -Qed. - -Lemma basics_to_code_app: - forall c l x ll, - basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - c = ll ++ x. -Proof. - intros. apply (f_equal code_to_basics) in H. - erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. - rewrite code_to_basics_id in H. inv H. auto. -Qed. - -Lemma basics_to_code_app2: - forall i c l x ll, - (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - i :: c = ll ++ x. -Proof. - intros until ll. intros. - exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. - all: eauto. -Qed. - -Lemma step_simu_basic: - forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, - MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> - basic_step ge s fb sp ms m bi ms' m' -> - pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 l cs2 tbdy', - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} - /\ tbdy = l ++ tbdy' - /\ exec_body tge l rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). -Proof. - intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. - simpl in *. inv Hpstate. - rewrite Hbody in TBC. monadInv TBC. - inv BSTEP. - - (* MBgetstack *) - simpl in EQ0. - unfold Mach.load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - exploit loadind_correct; eauto with asmgen. - intros (rs2 & EXECS & Hrs'1 & Hrs'2). - eapply exec_straight_body in EXECS. - 2: eapply code_to_basics_id; eauto. - destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). - exists rs2, m1, Hlbi. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - rewrite <- Hheadereq. *) subst. - - eapply match_codestate_intro; eauto. simpl. simpl in EQ. (* { destruct (MB.header bb); auto. } *) - eapply agree_set_mreg; eauto with asmgen. - intro Hep. simpl in Hep. inv Hep. - - (* MBsetstack *) - simpl in EQ0. - unfold Mach.store_stack in H. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - exploit storeind_correct; eauto with asmgen. - rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs', m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - - eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. - - (* MBgetparam *) - simpl in EQ0. - - assert (f0 = f) by congruence; subst f0. - unfold Mach.load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. - - (* Opaque loadind. *) -(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) - monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. - destruct ep0 eqn:EPeq. - (* RTMP contains parent *) - + exploit loadind_correct. eexact EQ1. - instantiate (2 := rs1). rewrite DXP; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & BTC & CTB & EXECB). - exists rs2, m1, ll. eexists. - eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - { eapply basics_to_code_app; eauto. } - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - (* rewrite <- Hheadereq. *)subst. - eapply match_codestate_intro; eauto. - - eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. - simpl; intros. rewrite R; auto with asmgen. - apply preg_of_not_FP; auto. - - (* GPR11 does not contain parent *) - + rewrite chunk_of_Tptr in A. - exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. - exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. - intros [rs3 [S [T U]]]. - - exploit exec_straight_trans. - eapply P. - eapply S. - intros EXES. - - eapply exec_straight_body in EXES. - 2: simpl. 2: erewrite code_to_basics_id; eauto. - destruct EXES as (l & ll & BTC & CTB & EXECB). - exists rs3, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app2; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. - eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs2#FP <- (rs3#FP)). intros. - rewrite Pregmap.gso; auto with asmgen. - congruence. - intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. - simpl; intros. rewrite U; auto with asmgen. - apply preg_of_not_FP; auto. - - (* MBop *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_operation tge sp op (map ms args) m' = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. - eapply preg_vals; eauto. - 2: eexact H0. - all: eauto. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - apply agree_set_undef_mreg with rs1; auto. - apply Val.lessdef_trans with v'; auto. - simpl; intros. destruct (andb_prop _ _ H1); clear H1. - rewrite R; auto. apply preg_of_not_FP; auto. -Local Transparent destroyed_by_op. - destruct op; simpl; auto; congruence. - - (* MBload *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. - - - (* MBstore *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_undef_regs; eauto with asmgen. - simpl; congruence. -Qed. - -Lemma exec_body_trans: - forall l l' rs0 m0 rs1 m1 rs2 m2, - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_body tge l' rs1 m1 = Next rs2 m2 -> - exec_body tge (l++l') rs0 m0 = Next rs2 m2. -Proof. - induction l. - - simpl. congruence. - - intros until m2. intros EXEB1 EXEB2. - inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. - simpl. rewrite EBI. eapply IHl; eauto. -Qed. - -Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. - -Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. -Next Obligation. - destruct tbb. simpl. auto. -Qed. - -Inductive exec_header: codestate -> codestate -> Prop := - | exec_header_cons: forall cs1, - exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; - (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) - cur := cur cs1 |}. - -Lemma step_simu_header: - forall bb s fb sp c ms m rs1 m1 cs1, -(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *) - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists cs1', - exec_header cs1 cs1' - /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). -Proof. - intros until cs1. intros Hpstate MCS. - eexists. split; eauto. - econstructor; eauto. - inv MCS. simpl in *. inv Hpstate. - econstructor; eauto. -Qed. - -Lemma step_matchasm_header: - forall fb cs1 cs1' s1, - match_asmstate fb cs1 s1 -> - exec_header cs1 cs1' -> - match_asmstate fb cs1' s1. -Proof. - intros until s1. intros MAS EXH. - inv MAS. inv EXH. - simpl. econstructor; eauto. -Qed. - -Lemma step_simu_body: - forall bb s fb sp c ms m rs1 m1 ms' cs1 m', - MB.header bb = nil -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - body_step ge s fb sp (MB.body bb) ms m ms' m' -> - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 cs2 ep, - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} - /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). -Proof. - intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. - inv BSTEP. - exists rs1, m1, cs1, (ep cs1). - inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). - econstructor; eauto. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. - rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. - exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. - intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). - simpl in *. - exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. - intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). - exists rs3, m3, cs3, ep. - repeat (split; simpl; auto). subst. simpl in *. auto. - rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. -Qed. - -(* Lemma exec_body_straight: - forall l rs0 m0 rs1 m1, - l <> nil -> - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_straight tge l rs0 m0 nil rs1 m1. -Proof. - induction l as [|i1 l]. - intros. contradict H; auto. - destruct l as [|i2 l]. - - intros until m1. intros _ EXEB. simpl in EXEB. - destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - inv EXEB. econstructor; eauto. - - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl. - destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate. - econstructor; eauto. eapply IHl; eauto. discriminate. -Qed. *) - -Lemma exec_body_pc: - forall l rs1 m1 rs2 m2, - exec_body tge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma exec_body_control: - forall b rs1 m1 rs2 m2 rs3 m3 fn, - exec_body tge (body b) rs1 m1 = Next rs2 m2 -> - exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> - exec_bblock_rel tge fn b rs1 m1 rs3 m3. -Proof. - intros until fn. intros EXEB EXECTL. - econstructor; eauto. inv EXECTL. - unfold exec_bblock. rewrite EXEB. auto. -Qed. - -Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. - -Lemma mbsize_eqz: - forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. - remember (length _) as a. remember (length_opt _) as b. - assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. - inv H0. inv H1. destruct bdy; destruct ex; auto. - all: try discriminate. -Qed. - -Lemma mbsize_neqz: - forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. - destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). - contradict H. unfold mbsize. simpl. auto. -Qed. - -(* Alternative form of step_simulation_bblock, easier to prove *) -Lemma step_simulation_bblock': - forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, - bb' = mb_remove_header bb -> - body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> - bb'' = mb_remove_body bb' -> - (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. -Proof. - intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. - destruct (mbsize bb) eqn:SIZE. - - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). - destruct bb as [hd bdy ex]; simpl in *; subst. - inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. - monadInv H2. simpl in *. inv ESTEP. inv BSTEP. - eexists. split. eapply plus_one. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - assert (x = tf) by congruence. subst x. - eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. - unfold exec_bblock. simpl. eauto. - econstructor. eauto. eauto. eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - intros. discriminate. - - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } - intros Hnotempty. - - (* initial setting *) - exploit match_state_codestate. - 2: eapply Hnotempty. - all: eauto. - intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). - - (* step_simu_header part *) - assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } - destruct H as (rs1 & m1 & Hpstate2). subst. - assert (f = fb). { inv MCS. auto. } subst fb. - exploit step_simu_header. - 2: eapply MCS. - all: eauto. - intros (cs1' & EXEH & MCS2). - - (* step_simu_body part *) -(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. } - rewrite H in BSTEP. clear H. *) - assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } - exploit step_simu_body. - 3: eapply BSTEP. - 4: eapply MCS2. - all: eauto. rewrite Hpstate'. eauto. - intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). - - (* step_simu_control part *) - assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). - { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } - destruct H as (tf & FIND'). - assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). - { inv MAS. simpl in *. eauto. } - destruct H as (tex & Hpbody2 & Hpctl). - inv EXEH. simpl in *. - subst. exploit step_simu_control. - 9: eapply MCS'. all: simpl. - 10: eapply ESTEP. - all: simpl; eauto. - rewrite Hpbody2. rewrite Hpctl. - { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. - erewrite exec_body_pc; eauto. } - intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). - - (* bringing the pieces together *) - exploit exec_body_trans. - eapply EXEB. - eauto. - intros EXEB2. - exploit exec_body_control; eauto. - rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. - rewrite Hexit. rewrite Hpctl. eauto. - intros EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. eapply plus_one. rewrite Hpstate2. - assert (exists ofs, rs1 PC = Vptr f ofs). - { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } - destruct H0 as (ofs & Hrs1pc). - eapply exec_step_internal; eauto. - - (* proving the initial find_bblock *) - rewrite Hpstate2 in MAS. inv MAS. simpl in *. - assert (f1 = f0) by congruence. subst f0. - rewrite PCeq in Hrs1pc. inv Hrs1pc. - exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. - inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. - eapply find_bblock_tail; eauto. -Qed. - -Lemma step_simulation_bblock: - forall sf f sp bb ms m ms' m' S2 c, - body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. -Proof. - intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. - eapply step_simulation_bblock'; eauto. - all: destruct bb as [hd bdy ex]; simpl in *; eauto. - inv ESTEP. - - econstructor. inv H; try (econstructor; eauto; fail). - - econstructor. -Qed. - -Definition measure (s: MB.state) : nat := - match s with - | MB.State _ _ _ _ _ _ => 0%nat - | MB.Callstate _ _ _ _ => 0%nat - | MB.Returnstate _ _ _ => 1%nat - end. - -Definition split (c: MB.code) := - match c with - | nil => nil - | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} - :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c - end. - -Lemma cons_ok_eq3 {A: Type} : - forall (x:A) y z x' y' z', - x = x' -> y = y' -> z = z' -> - OK (x::y::z) = OK (x'::y'::z'). -Proof. - intros. subst. auto. -Qed. - -Lemma transl_blocks_split_builtin: - forall bb c ep f ef args res, - MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> - transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. -Proof. - intros until res. intros Hexit Hbody. simpl split. - unfold transl_blocks. fold transl_blocks. unfold transl_block. - simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. - remember (transl_blocks _ _ _) as tlbs. - destruct tbc; destruct tbi; destruct tlbs. - all: try simpl; auto. - - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. - unfold gen_bblocks. simpl. destruct l. - + exploit transl_basic_code_nonil; eauto. intro. destruct H. - + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. -Qed. - -Lemma transl_code_at_pc_split_builtin: - forall rs f f0 bb c ep tf tc ef args res, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> - transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. -Proof. - intros until res. intros Hbody Hexit AT. inv AT. - econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. -Qed. - -Theorem match_states_split_builtin: - forall sf f sp bb c rs m ef args res S1, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. -Proof. - intros until S1. intros Hbody Hexit MS. - inv MS. - econstructor; eauto. - eapply transl_code_at_pc_split_builtin; eauto. -Qed. - -Lemma step_simulation_builtin: - forall ef args res bb sf f sp c ms m t S2, - MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. -Proof. - intros until S2. intros Hbody Hexit ESTEP S1' MS. - inv MS. inv AT. monadInv H2. monadInv EQ. - rewrite Hbody in EQ0. monadInv EQ0. - rewrite Hexit in EQ. monadInv EQ. - rewrite Hexit in ESTEP. inv ESTEP. inv H4. - - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H1); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - econstructor; split. apply plus_one. - simpl in H3. - eapply exec_step_builtin. eauto. eauto. - eapply find_bblock_tail; eauto. - simpl. eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x0). - unfold nextblock, incrPC. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextblock. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. - apply Pregmap.gso; auto with asmgen. - congruence. -Qed. - -Lemma next_sep: - forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - congruence. -Qed. - -Theorem step_simulation: - forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros. - -- (* bblock *) - left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. - all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; - try (rewrite MBE; try discriminate); eauto). - + (* MBbuiltin *) - destruct (MB.body bb) eqn:MBB. - * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. - * eapply match_states_split_builtin in MS; eauto. - 2: rewrite MBB; discriminate. - simpl split in MS. - rewrite <- MBB in H. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. - assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } - rewrite H1 in H. subst. - exploit step_simulation_bblock. eapply H. - discriminate. - simpl. constructor. - eauto. - intros (S2' & PLUS1 & MS'). - rewrite MBE in MS'. - assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) - (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) - rs' m') t s'). - { inv H0. inv H3. econstructor. econstructor; eauto. } - exploit step_simulation_builtin. - 4: eapply MS'. - all: simpl; eauto. - intros (S3' & PLUS'' & MS''). - exists S3'. split; eauto. - eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. - + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. - -- (* internal function *) - inv MS. - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. - unfold Mach.store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - simpl chunk_of_type in F. - exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. - intros [m3' [P Q]]. - (* Execution of function prologue *) - monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) - set (tfbody := make_prologue f x0) in *. - set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. - set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). - exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. - intros (rs' & U' & V'). -(* exploit (exec_straight_through_singleinst); eauto. - intro W'. remember (nextblock _ rs') as rs''. *) - exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). - rewrite chunk_of_Tptr in P. - assert (rs' GPRA = rs0 RA). { apply V'. } - assert (rs' SP = rs2 SP). { apply V'; discriminate. } - rewrite H4. rewrite H3. - (* change (rs' GPRA) with (rs0 RA). *) - rewrite ATLR. - change (rs2 SP) with sp. eexact P. - intros (rs3 & U & V). -(* exploit (exec_straight_through_singleinst); eauto. - intro W. *) - assert (EXEC_PROLOGUE: exists rs3', - exec_straight_blocks tge tf - tf.(fn_blocks) rs0 m' - x0 rs3' m3' - /\ forall r, r <> PC -> rs3' r = rs3 r). - { eexists. split. - - change (fn_blocks tf) with tfbody; unfold tfbody. - econstructor; eauto. unfold exec_bblock. simpl exec_body. - rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. - Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. - rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. - simpl. apply next_sep; eauto. reflexivity. - - intros. destruct V' as (V'' & V'). destruct r. - + Simpl. - destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } - + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. - + contradiction. - } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). - exploit exec_straight_steps_2; eauto using functions_transl. - simpl fn_blocks. simpl fn_blocks in g. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3' m3'); split. - eapply exec_straight_steps_1; eauto. - simpl fn_blocks. simpl fn_blocks in g. omega. - constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_set_other; auto with asmgen. - apply agree_change_sp with (parent_sp s). - apply agree_undef_regs with rs0. auto. -Local Transparent destroyed_at_function_entry. - simpl; intros; Simpl. - unfold sp; congruence. - - intros. - assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. - assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - (* rewrite H8; auto. *) - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - intros. rewrite Heqrs3'. rewrite V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. discriminate. -- (* external function *) - inv MS. - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. - apply agree_set_pair; auto. - apply agree_undef_caller_save_regs; auto. - -- (* return *) - inv MS. - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. - -Lemma transf_initial_states: - forall st1, MB.initial_state prog st1 -> - exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Mach.Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. assumption. - compute in H1. inv H1. - generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. -Qed. - -Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := - Asmblockgenproof0.return_address_offset. - -Theorem transf_program_correct: - forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_star with (measure := measure). - - apply senv_preserved. - - eexact transf_initial_states. - - eexact transf_final_states. - - exact step_simulation. -Qed. - -End PRESERVATION. +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for RISC-V generation: main proof. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. +Require Import Axioms. + +Module MB := Machblock. +Module AB := Asmvliw. + +Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Machblock.program. +Variable tprog: Asmvliw.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +(** * Properties of control flow *) + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + +(** The following lemmas show that the translation from Mach to Asm + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ Asm instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- Asm instr seq tail + translation +>> + The proof demands many boring lemmas showing that Asm constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +Lemma gen_bblocks_label: + forall hd bdy ex tbb tc, + gen_bblocks hd bdy ex = tbb::tc -> + header tbb = hd. +Proof. + intros until tc. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma gen_bblocks_label2: + forall hd bdy ex tbb1 tbb2, + gen_bblocks hd bdy ex = tbb1::tbb2::nil -> + header tbb2 = nil. +Proof. + intros until tbb2. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma in_dec_transl: + forall lbl hd, + (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). +Proof. + intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. +Qed. + +Lemma transl_is_label: + forall lbl bb tbb f ep tc, + transl_block f bb ep = OK (tbb::tc) -> + is_label lbl tbb = MB.is_label lbl bb. +Proof. + intros until tc. intros TLB. + destruct tbb as [thd tbdy tex]; simpl in *. + monadInv TLB. + unfold is_label. simpl. + apply gen_bblocks_label in H0. simpl in H0. subst. + rewrite in_dec_transl. auto. +Qed. + +Lemma transl_is_label_false2: + forall lbl bb f ep tbb1 tbb2, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb2 = false. +Proof. + intros until tbb2. intros TLB. + destruct tbb2 as [thd tbdy tex]; simpl in *. + monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. + apply is_label_correct_false. simpl. auto. +Qed. + +Lemma transl_is_label2: + forall f bb ep tbb1 tbb2 lbl, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb1 = MB.is_label lbl bb + /\ is_label lbl tbb2 = false. +Proof. + intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. +Qed. + +Lemma transl_block_nonil: + forall f c ep tc, + transl_block f c ep = OK tc -> + tc <> nil. +Proof. + intros. monadInv H. unfold gen_bblocks. + destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. + all: discriminate. +Qed. + +Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, + ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). +Proof. + intros. intro. monadInv H. + unfold gen_bblocks in H0. + destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. + all: discriminate. +Qed. + +Lemma find_label_transl_false: + forall x f lbl bb ep x', + transl_block f bb ep = OK x -> + MB.is_label lbl bb = false -> + find_label lbl (x++x') = find_label lbl x'. +Proof. + intros until x'. intros TLB MBis; simpl; auto. + destruct x as [|x0 x1]; simpl; auto. + destruct x1 as [|x1 x2]; simpl; auto. + - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. + - destruct x2 as [|x2 x3]; simpl; auto. + + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. + erewrite transl_is_label_false2; eauto. + + apply transl_block_limit in TLB. destruct TLB. +Qed. + +Lemma transl_blocks_label: + forall lbl f c tc ep, + transl_blocks f c ep = OK tc -> + match MB.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. + destruct (MB.is_label lbl a) eqn:MBis. + - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } + simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. + rewrite ABis. + eexists. eexists. split; eauto. simpl transl_blocks. + assert (MB.header a <> nil). + { apply MB.is_label_correct_true in MBis. + destruct (MB.header a). contradiction. discriminate. } + destruct (MB.header a); try contradiction. + rewrite EQ. simpl. rewrite EQ1. simpl. auto. + - apply IHc in EQ1. destruct (MB.find_label lbl c). + + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. + erewrite find_label_transl_false; eauto. + + erewrite find_label_transl_false; eauto. +Qed. + +Lemma find_label_nil: + forall bb lbl c, + header bb = nil -> + find_label lbl (bb::c) = find_label lbl c. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. subst. + assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { erewrite <- is_label_correct_false. simpl. auto. } + rewrite H. auto. +Qed. + +Lemma transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match MB.find_label lbl f.(MB.fn_code) with + | None => find_label lbl tf.(fn_blocks) = None + | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + eapply transl_blocks_label; eauto. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Mach code translates to a valid ``go to'' + transition in the generated Asm code. *) + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + MB.find_label lbl f.(MB.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros (tc & A & B). + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +(* NB: the hypothesis in comment on [b] is not needed in the proof ! +*) +Lemma return_address_exists: + forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. + +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. +(* rewrite transl_code'_transl_code in EQ0. *) + exists x; exists true; split; auto. (* unfold fn_code. *) + repeat constructor. + - exact transf_function_no_overflow. +Qed. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using simulation diagrams + of the following form. +<< + st1 --------------- st2 + | | + t| *|t + | | + v v + st1'--------------- st2' +>> + The invariant is the [match_states] predicate below, which includes: +- The Asm code pointed by the PC register is the translation of + the current Mach code sequence. +- Mach register values and Asm register values agree. +*) + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the Asm side. Actually, all Mach transitions + correspond to at least one Asm transition, except the + transition from [Machsem.Returnstate] to [Machsem.State]. + So, the following integer measure will suffice to rule out + the unwanted behaviour. *) + + +Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of MFP). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_states (Machblock.State s fb sp c ms m) + (Asmvliw.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Machblock.Callstate s fb ms m) + (Asmvliw.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machblock.Returnstate s ms m) + (Asmvliw.State rs m'). + +Record codestate := + Codestate { pstate: state; + pheader: list label; + pbody1: list basic; + pbody2: list basic; + pctl: option control; + ep: bool; + rem: list AB.bblock; + cur: bblock }. + +(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) + +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m0) + (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) + (TIC: transl_instr_control f (MB.exit bb) = OK tbi) + (TBLS: transl_blocks f c false = OK tc) +(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) + (AG: agree ms sp rs0) + (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) + , + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + {| pstate := (Asmvliw.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc; + pbody2 := (extract_basic tbi); + pctl := extract_ctl tbi; + ep := ep; + rem := tc; + cur := tbb + |} +. + +Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := + | match_asmstate_some: + forall rs f tf tc m tbb ofs ep tbdy tex lhd + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (TRANSF: transf_function f = OK tf) + (PCeq: rs PC = Vptr fb ofs) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) +(* (HDROK: header tbb = lhd) *) + , + match_asmstate fb + {| pstate := (Asmvliw.State rs m); + pheader := lhd; + pbody1 := tbdy; + pbody2 := extract_basic tex; + pctl := extract_ctl tex; + ep := ep; + rem := tc; + cur := tbb |} + (Asmvliw.State rs m) +. + +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + +Lemma transl_blocks_nonil: + forall f bb c tc ep, + transl_blocks f (bb::c) ep = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. + intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. + - destruct x1; simpl; eauto. +Qed. + +Lemma no_builtin_preserved: + forall f ex x2, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x2 -> + (exists i, extract_ctl x2 = Some (PCtlFlow i)) + \/ extract_ctl x2 = None. +Proof. + intros until x2. intros Hbuiltin TIC. + destruct ex. + - destruct c. + (* MBcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBtailcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBbuiltin *) + + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). + apply Hbuiltin. contradict H; auto. + (* MBgoto *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBcond *) + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. + * unfold transl_opt_compuimm. exploreInst; simpl; eauto. + * unfold transl_opt_compluimm. exploreInst; simpl; eauto. + * unfold transl_comp_float64. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. + * unfold transl_comp_float32. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. + (* MBjumptable *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBreturn *) + + simpl in TIC. monadInv TIC. simpl. eauto. + - monadInv TIC. simpl; auto. +Qed. + +Lemma transl_blocks_distrib: + forall c f bb tbb tc ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. +Proof. + intros until ep0. intros TLBS Hbuiltin. + destruct bb as [hd bdy ex]. + monadInv TLBS. monadInv EQ. + exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. + - destruct H as [i Hectl]. + unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. + simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite Hectl. auto. + - unfold gen_bblocks in H0. rewrite H in H0. + destruct x1 as [|bi x1]. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. +Qed. + +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + (tbdy <> nil \/ extract_ctl tex <> None) -> + (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy ++ extract_basic tex + /\ exit tbb = extract_ctl tex. +Proof. + intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl tex) eqn:ECTL. + - destruct c. + + destruct i; try (inv GENB; simpl; auto; fail). + assert False. eapply Hnobuiltin. eauto. destruct H. + + inv GENB. simpl. auto. + - inversion Hnonil. + + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. + + contradict H; simpl; auto. +Qed. + +Lemma transl_instr_basic_nonil: + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> + x <> nil. +Proof. + intros until x. intros TIB. + destruct bi. + - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. + - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. + - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. + - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. + unfold transl_cond_op in EQ0. exploreInst; try discriminate. + unfold transl_cond_float64. exploreInst; try discriminate. + unfold transl_cond_notfloat64. exploreInst; try discriminate. + unfold transl_cond_float32. exploreInst; try discriminate. + unfold transl_cond_notfloat32. exploreInst; try discriminate. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x ep, + bdy <> nil -> + transl_basic_code f bdy ep = OK x -> + x <> nil. +Proof. + induction bdy as [|bi bdy]. + intros. contradict H0; auto. + destruct bdy as [|bi2 bdy]. + - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. + - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. + monadInv TBC. + assert (x0 <> nil). + eapply IHbdy; eauto. subst bdy'. discriminate. + eapply transl_instr_basic_nonil; eauto. +Qed. + +Lemma transl_instr_control_nonil: + forall ex f x, + ex <> None -> + transl_instr_control f ex = OK x -> + extract_ctl x <> None. +Proof. + intros ex f x Hnonil TIC. + destruct ex as [ex|]. + - clear Hnonil. destruct ex. + all: try (simpl in TIC; exploreInst; discriminate). + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. + * unfold transl_opt_compuimm. exploreInst; try discriminate. + * unfold transl_opt_compluimm. exploreInst; try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. + - contradict Hnonil; auto. +Qed. + +Lemma transl_instr_control_nobuiltin: + forall f ex x, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x -> + (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). +Proof. + intros until x. intros Hnobuiltin TIC. intros until res. + unfold transl_instr_control in TIC. exploreInst. + all: try discriminate. + - assert False. eapply Hnobuiltin; eauto. destruct H. + - unfold transl_cbranch in TIC. exploreInst. + all: try discriminate. + * unfold transl_opt_compuimm. exploreInst. all: try discriminate. + * unfold transl_opt_compluimm. exploreInst. all: try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. +Qed. + +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m, + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + (MB.body bb <> nil \/ MB.exit bb <> None) -> + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + match_states mbs abs -> + exists cs fb f tbb tc ep, + match_codestate fb mbs cs /\ match_asmstate fb cs abs + /\ Genv.find_funct_ptr ge fb = Some (Internal f) + /\ transl_blocks f (bb::c) ep = OK (tbb::tc) + /\ body tbb = pbody1 cs ++ pbody2 cs + /\ exit tbb = pctl cs + /\ cur cs = tbb /\ rem cs = tc + /\ pstate cs = abs. +Proof. + intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. + inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. + monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. + { inversion Hnotempty. + - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). + left. eapply transl_basic_code_nonil; eauto. + - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). + right. eapply transl_instr_control_nonil; eauto. } + eapply transl_instr_control_nobuiltin; eauto. + intros (Hth & Htbdy & Htexit). + exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. + repeat split. 1-2: econstructor; eauto. + { destruct (MB.header bb). eauto. discriminate. } eauto. + unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. + rewrite TLBS. simpl. rewrite H2. + all: simpl; auto. +Qed. + +Definition mb_remove_body (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma exec_straight_pnil: + forall c rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 -> + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb ep tbb, + (MB.body bb <> nil \/ MB.exit bb <> None) -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + transl_block f bb ep = OK (tbb :: nil) -> + exists c c', + transl_basic_code f (MB.body bb) ep = OK c + /\ transl_instr_control f (MB.exit bb) = OK c' + /\ body tbb = c ++ extract_basic c' + /\ exit tbb = extract_ctl c'. +Proof. + intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. +Qed. + +Lemma nextblock_preserves: + forall rs rs' bb r, + rs' = nextblock bb rs -> + data_preg r = true -> + rs r = rs' r. +Proof. + intros. destruct r; try discriminate. + subst. Simpl. +(* - subst. Simpl. *) +Qed. + +Lemma cons3_app {A: Type}: + forall a b c (l: list A), + a :: b :: c :: l = (a :: b :: c :: nil) ++ l. +Proof. + intros. simpl. auto. +Qed. + +Lemma exec_straight_opt_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight_opt tge c rs1 m1 c' rs2 m2 -> + exists body, + exec_body tge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. intros EXES. + inv EXES. + - exists nil. split; auto. + - eapply exec_straight_body2. auto. +Qed. + +Lemma extract_basics_to_code: + forall lb c, + extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +Lemma extract_ctl_basics_to_code: + forall lb c, + extract_ctl (basics_to_code lb ++ c) = extract_ctl c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +(* Lemma goto_label_inv: + forall fn tbb l rs m b ofs, + rs PC = Vptr b ofs -> + goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m. +Proof. + intros. + unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H. + exploreInst; auto. + unfold nextblock. rewrite Pregmap.gss. + +Qed. + + +Lemma exec_control_goto_label_inv: + exec_control tge fn (Some ctl) rs m = goto_label fn l rs m -> + exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m. +Proof. +Qed. *) + +Theorem step_simu_control: + forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2, + MB.body bb' = nil -> + (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + pstate cs2 = (Asmvliw.State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + cur cs2 = tbb -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> + exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> + (exists rs3 m3 rs4 m4, + exec_body tge tbdy2 rs2 m2 = Next rs3 m3 + /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. + inv ESTEP. + - inv MCS. inv MAS. simpl in *. + inv Hpstate. + destruct ctl. + + (* MBcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct s1 as [rf|fid]; simpl in H7. + * (* Indirect call *) + monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. + revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + { econstructor; eauto. } + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. + + * (* Direct call *) + monadInv H1. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. + destruct s1 as [rf|fid]; simpl in H13. + * monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + + assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + { simpl. eauto. } + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). + { clear - EQ. destruct x; repeat split; try discriminate. + all: unfold ireg_of in EQ; destruct rf; try discriminate. } + Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. + * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } + + (* MBbuiltin (contradiction) *) + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + + (* MBgoto *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. + remember (nextblock tbb rs2) as rs2'. + (* inv AT. monadInv H4. *) + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + exploit find_label_goto_label. + eauto. eauto. + instantiate (2 := rs2'). + { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } + eauto. + intros (tc' & rs' & GOTO & AT2 & INV). + + eexists. eexists. repeat eexists. repeat split. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. + econstructor; eauto. + rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. + eapply agree_exten; eauto with asmgen. + assert (forall r : preg, r <> PC -> rs' r = rs2 r). + { intros. destruct r. + - destruct g. all: rewrite INV; Simpl; auto. +(* - destruct g. all: rewrite INV; Simpl; auto. *) + - rewrite INV; Simpl; auto. + - contradiction. } + eauto with asmgen. + congruence. + + (* MBcond *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + * (* MBcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. + 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. + unfold Val.offset_ptr. rewrite PCeq. eauto. + intros (tc' & rs3 & GOTOL & TLPC & Hrs3). + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + * (* MBcond false *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + + exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + (* MBjumptable *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + monadInv H1. + generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. + + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. + + repeat eexists. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. + econstructor; eauto. + eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. + { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. + destruct (preg_eq r' GPR63). subst. contradiction. + destruct (preg_eq r' GPR62). subst. contradiction. + destruct r'; Simpl. } + discriminate. + + (* MBreturn *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + assert (f1 = f) by congruence. subst f1. + + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. + + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. +(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) + intros (TLB & TLBS). + *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. +(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *) + monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. + simpl. repeat eexists. + econstructor. 4: instantiate (3 := false). all:eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + assert (f = f0) by congruence. subst f0. econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + discriminate. +Qed. + +Definition mb_remove_first (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. + +Lemma exec_straight_body: + forall c c' lc rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 c' rs2 m2 -> + code_to_basics c = Some lc -> + exists l ll, + c = l ++ c' + /\ code_to_basics l = Some ll + /\ exec_body tge ll rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros until m2. intros EXES CTB. inv EXES. + - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. + - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. + eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. + exists (i ::g l'),(i::ll). repeat (split; simpl; auto). + rewrite CTB. auto. + rewrite H1. auto. +Qed. + +Lemma basics_to_code_app: + forall c l x ll, + basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + c = ll ++ x. +Proof. + intros. apply (f_equal code_to_basics) in H. + erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. + rewrite code_to_basics_id in H. inv H. auto. +Qed. + +Lemma basics_to_code_app2: + forall i c l x ll, + (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + i :: c = ll ++ x. +Proof. + intros until ll. intros. + exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. + all: eauto. +Qed. + +Lemma step_simu_basic: + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, + MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 l cs2 tbdy', + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} + /\ tbdy = l ++ tbdy' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). +Proof. + intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. + rewrite Hbody in TBC. monadInv TBC. + inv BSTEP. + + - (* MBgetstack *) + simpl in EQ0. + unfold Mach.load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + exploit loadind_correct; eauto with asmgen. + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. + 2: eapply code_to_basics_id; eauto. + destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). + exists rs2, m1, Hlbi. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } +(* rewrite <- Hheadereq. *) subst. simpl in Hheadereq. + + eapply match_codestate_intro; eauto. + { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity. + discriminate. apply preg_of_not_FP; assumption. reflexivity. + + - (* MBsetstack *) + simpl in EQ0. + unfold Mach.store_stack in H. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + exploit storeind_correct; eauto with asmgen. + rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs', m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. + - (* MBgetparam *) + simpl in EQ0. + + assert (f0 = f) by congruence; subst f0. + unfold Mach.load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. + + (* Opaque loadind. *) +(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + destruct ep0 eqn:EPeq. + (* RTMP contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & BTC & CTB & EXECB). + exists rs2, m1, ll. eexists. + eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + { eapply basics_to_code_app; eauto. } + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + (* rewrite <- Hheadereq. *)subst. + eapply match_codestate_intro; eauto. + + eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_FP; auto. + + (* GPR11 does not contain parent *) + + rewrite chunk_of_Tptr in A. + exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. + 2: simpl. 2: erewrite code_to_basics_id; eauto. + destruct EXES as (l & ll & BTC & CTB & EXECB). + exists rs3, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app2; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs2#FP <- (rs3#FP)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_FP; auto. + - (* MBop *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_operation tge sp op (map ms args) m' = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. + eapply preg_vals; eauto. + 2: eexact H0. + all: eauto. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + apply agree_set_undef_mreg with rs1; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_FP; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; congruence. + - (* MBload *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity. + apply preg_of_not_FP; assumption. reflexivity. + + - (* MBstore *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_undef_regs; eauto with asmgen. + intro Hep. simpl in Hep. + subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity. +Qed. + +Lemma exec_body_trans: + forall l l' rs0 m0 rs1 m1 rs2 m2, + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_body tge l' rs1 m1 = Next rs2 m2 -> + exec_body tge (l++l') rs0 m0 = Next rs2 m2. +Proof. + induction l. + - simpl. congruence. + - intros until m2. intros EXEB1 EXEB2. + inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. + simpl. rewrite EBI. eapply IHl; eauto. +Qed. + +Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. + +Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. +Next Obligation. + destruct tbb. simpl. auto. +Qed. + +Inductive exec_header: codestate -> codestate -> Prop := + | exec_header_cons: forall cs1, + exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; + (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) + cur := cur cs1 |}. + +Lemma step_simu_header: + forall bb s fb sp c ms m rs1 m1 cs1, +(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *) + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists cs1', + exec_header cs1 cs1' + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros until cs1. intros Hpstate MCS. + eexists. split; eauto. + econstructor; eauto. + inv MCS. simpl in *. inv Hpstate. + econstructor; eauto. +Qed. + +Lemma step_matchasm_header: + forall fb cs1 cs1' s1, + match_asmstate fb cs1 s1 -> + exec_header cs1 cs1' -> + match_asmstate fb cs1' s1. +Proof. + intros until s1. intros MAS EXH. + inv MAS. inv EXH. + simpl. econstructor; eauto. +Qed. + +Lemma step_simu_body: + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', + MB.header bb = nil -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 cs2 ep, + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} + /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. + inv BSTEP. + exists rs1, m1, cs1, (ep cs1). + inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). + econstructor; eauto. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. + rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). + simpl in *. + exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). + exists rs3, m3, cs3, ep. + repeat (split; simpl; auto). subst. simpl in *. auto. + rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. +Qed. + +(* Lemma exec_body_straight: + forall l rs0 m0 rs1 m1, + l <> nil -> + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_straight tge l rs0 m0 nil rs1 m1. +Proof. + induction l as [|i1 l]. + intros. contradict H; auto. + destruct l as [|i2 l]. + - intros until m1. intros _ EXEB. simpl in EXEB. + destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. + inv EXEB. econstructor; eauto. + - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl. + destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate. + econstructor; eauto. eapply IHl; eauto. discriminate. +Qed. *) + +Lemma exec_body_pc: + forall l rs1 m1 rs2 m2, + exec_body tge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma exec_body_control: + forall b rs1 m1 rs2 m2 rs3 m3 fn, + exec_body tge (body b) rs1 m1 = Next rs2 m2 -> + exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> + exec_bblock_rel tge fn b rs1 m1 rs3 m3. +Proof. + intros until fn. intros EXEB EXECTL. + econstructor; eauto. inv EXECTL. + unfold exec_bblock. rewrite EXEB. auto. +Qed. + +Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. + +Lemma mbsize_eqz: + forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. + remember (length _) as a. remember (length_opt _) as b. + assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. + inv H0. inv H1. destruct bdy; destruct ex; auto. + all: try discriminate. +Qed. + +Lemma mbsize_neqz: + forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. + destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). + contradict H. unfold mbsize. simpl. auto. +Qed. + +(* Alternative form of step_simulation_bblock, easier to prove *) +Lemma step_simulation_bblock': + forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, + bb' = mb_remove_header bb -> + body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> + bb'' = mb_remove_body bb' -> + (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. +Proof. + intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. + destruct (mbsize bb) eqn:SIZE. + - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. + inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + monadInv H2. simpl in *. inv ESTEP. inv BSTEP. + eexists. split. eapply plus_one. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + assert (x = tf) by congruence. subst x. + eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. + unfold exec_bblock. simpl. eauto. + econstructor. eauto. eauto. eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + intros. discriminate. + - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } + intros Hnotempty. + + (* initial setting *) + exploit match_state_codestate. + 2: eapply Hnotempty. + all: eauto. + intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). + + (* step_simu_header part *) + assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } + destruct H as (rs1 & m1 & Hpstate2). subst. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 2: eapply MCS. + all: eauto. + intros (cs1' & EXEH & MCS2). + + (* step_simu_body part *) +(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. } + rewrite H in BSTEP. clear H. *) + assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } + exploit step_simu_body. + 3: eapply BSTEP. + 4: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). + { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } + destruct H as (tf & FIND'). + assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). + { inv MAS. simpl in *. eauto. } + destruct H as (tex & Hpbody2 & Hpctl). + inv EXEH. simpl in *. + subst. exploit step_simu_control. + 9: eapply MCS'. all: simpl. + 10: eapply ESTEP. + all: simpl; eauto. + rewrite Hpbody2. rewrite Hpctl. + { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. + erewrite exec_body_pc; eauto. } + intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). + + (* bringing the pieces together *) + exploit exec_body_trans. + eapply EXEB. + eauto. + intros EXEB2. + exploit exec_body_control; eauto. + rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. + rewrite Hexit. rewrite Hpctl. eauto. + intros EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. eapply plus_one. rewrite Hpstate2. + assert (exists ofs, rs1 PC = Vptr f ofs). + { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } + destruct H0 as (ofs & Hrs1pc). + eapply exec_step_internal; eauto. + + (* proving the initial find_bblock *) + rewrite Hpstate2 in MAS. inv MAS. simpl in *. + assert (f1 = f0) by congruence. subst f0. + rewrite PCeq in Hrs1pc. inv Hrs1pc. + exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. + eapply find_bblock_tail; eauto. +Qed. + +Lemma step_simulation_bblock: + forall sf f sp bb ms m ms' m' S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. +Proof. + intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. + all: destruct bb as [hd bdy ex]; simpl in *; eauto. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. +Qed. + +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +Definition split (c: MB.code) := + match c with + | nil => nil + | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} + :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c + end. + +Lemma cons_ok_eq3 {A: Type} : + forall (x:A) y z x' y' z', + x = x' -> y = y' -> z = z' -> + OK (x::y::z) = OK (x'::y'::z'). +Proof. + intros. subst. auto. +Qed. + +Lemma transl_blocks_split_builtin: + forall bb c ep f ef args res, + MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> + transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. +Proof. + intros until res. intros Hexit Hbody. simpl split. + unfold transl_blocks. fold transl_blocks. unfold transl_block. + simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. + remember (transl_blocks _ _ _) as tlbs. + destruct tbc; destruct tbi; destruct tlbs. + all: try simpl; auto. + - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. + unfold gen_bblocks. simpl. destruct l. + + exploit transl_basic_code_nonil; eauto. intro. destruct H. + + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. +Qed. + +Lemma transl_code_at_pc_split_builtin: + forall rs f f0 bb c ep tf tc ef args res, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> + transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. +Proof. + intros until res. intros Hbody Hexit AT. inv AT. + econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. +Qed. + +Theorem match_states_split_builtin: + forall sf f sp bb c rs m ef args res S1, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. +Proof. + intros until S1. intros Hbody Hexit MS. + inv MS. + econstructor; eauto. + eapply transl_code_at_pc_split_builtin; eauto. +Qed. + +Lemma step_simulation_builtin: + forall ef args res bb sf f sp c ms m t S2, + MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. +Proof. + intros until S2. intros Hbody Hexit ESTEP S1' MS. + inv MS. inv AT. monadInv H2. monadInv EQ. + rewrite Hbody in EQ0. monadInv EQ0. + rewrite Hexit in EQ. monadInv EQ. + rewrite Hexit in ESTEP. inv ESTEP. inv H4. + + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H1); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + econstructor; split. apply plus_one. + simpl in H3. + eapply exec_step_builtin. eauto. eauto. + eapply find_bblock_tail; eauto. + simpl. eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x0). + unfold nextblock, incrPC. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextblock. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + apply Pregmap.gso; auto with asmgen. + congruence. +Qed. + +Lemma next_sep: + forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + congruence. +Qed. + +Theorem step_simulation: + forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros. + +- (* bblock *) + left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. + all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; + try (rewrite MBE; try discriminate); eauto). + + (* MBbuiltin *) + destruct (MB.body bb) eqn:MBB. + * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. + * eapply match_states_split_builtin in MS; eauto. + 2: rewrite MBB; discriminate. + simpl split in MS. + rewrite <- MBB in H. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. + assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } + rewrite H1 in H. subst. + exploit step_simulation_bblock. eapply H. + discriminate. + simpl. constructor. + eauto. + intros (S2' & PLUS1 & MS'). + rewrite MBE in MS'. + assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) + (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) + rs' m') t s'). + { inv H0. inv H3. econstructor. econstructor; eauto. } + exploit step_simulation_builtin. + 4: eapply MS'. + all: simpl; eauto. + intros (S3' & PLUS'' & MS''). + exists S3'. split; eauto. + eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. + +- (* internal function *) + inv MS. + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. + unfold Mach.store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + (* Execution of function prologue *) + monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) + set (tfbody := make_prologue f x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). + exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. + intros (rs' & U' & V'). +(* exploit (exec_straight_through_singleinst); eauto. + intro W'. remember (nextblock _ rs') as rs''. *) + exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). + rewrite chunk_of_Tptr in P. + assert (rs' GPRA = rs0 RA). { apply V'. } + assert (rs' SP = rs2 SP). { apply V'; discriminate. } + rewrite H4. rewrite H3. + (* change (rs' GPRA) with (rs0 RA). *) + rewrite ATLR. + change (rs2 SP) with sp. eexact P. + intros (rs3 & U & V). +(* exploit (exec_straight_through_singleinst); eauto. + intro W. *) + assert (EXEC_PROLOGUE: exists rs3', + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3' + /\ forall r, r <> PC -> rs3' r = rs3 r). + { eexists. split. + - change (fn_blocks tf) with tfbody; unfold tfbody. + econstructor; eauto. unfold exec_bblock. simpl exec_body. + rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. + Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. + rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. + simpl. apply next_sep; eauto. reflexivity. + - intros. destruct V' as (V'' & V'). destruct r. + + Simpl. + destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } + + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. + + contradiction. + } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. + simpl; intros; Simpl. + unfold sp; congruence. + + intros. + assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. + assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + (* rewrite H8; auto. *) + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + intros. rewrite Heqrs3'. rewrite V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. discriminate. +- (* external function *) + inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, MB.initial_state prog st1 -> + exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Mach.Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := + Asmblockgenproof0.return_address_offset. + +Theorem transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - exact step_simulation. +Qed. + +End PRESERVATION. -- cgit From 263a8d93cfabcec746c06d4abdcd06a0e8ec6d14 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Oct 2019 11:54:27 +0200 Subject: Converting mppa_k1c/*.v files to Unix format --- mppa_k1c/Asm.v | 1506 ++++++++++++++++++++++++++--------------------------- mppa_k1c/Asmaux.v | 2 +- 2 files changed, 754 insertions(+), 754 deletions(-) diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f09aa99c..e27ff40c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,753 +1,753 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) - -(** * Abstract syntax for K1c textual assembly language. - - Each emittable instruction is defined here. ';;' is also defined as an instruction. - The goal of this representation is to stay compatible with the rest of the generic backend of CompCert - We define [unfold : list bblock -> list instruction] - An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] - [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import ExtValues. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Import Asmvliw. -Require Import Linking. -Require Import Errors. - -(** Definitions for OCaml code *) -Definition label := positive. -Definition preg := preg. - -Inductive addressing : Type := - | AOff (ofs: offset) - | AReg (ro: ireg) - | ARegXS (ro: ireg) -. - -(** Syntax *) -Inductive instruction : Type := - (** pseudo instructions *) - | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) - | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Plabel (lbl: label) (**r define a code label *) - | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction (**r built-in function (pseudo) *) - | Psemi (**r semi colon separating bundles *) - | Pnop (**r instruction that does nothing *) - - (** Control flow instructions *) - | Pget (rd: ireg) (rs: preg) (**r get system register *) - | Pset (rd: preg) (rs: ireg) (**r set system register *) - | Pret (**r return *) - | Pcall (l: label) (**r function call *) - | Picall (rs: ireg) (**r function call on register *) - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pigoto (rs: ireg) (**r goto from register *) - | Pj_l (l: label) (**r jump to label *) - | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) - | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) - | Pjumptable (r: ireg) (labels: list label) - - (* For builtins *) - | Ploopdo (count: ireg) (loopend: label) - | Pgetn (n: int) (dst: ireg) - | Psetn (n: int) (src: ireg) - | Pwfxl (n: int) (src: ireg) - | Pwfxm (n: int) (src: ireg) - | Pldu (dst: ireg) (addr: ireg) - | Plbzu (dst: ireg) (addr: ireg) - | Plhzu (dst: ireg) (addr: ireg) - | Plwzu (dst: ireg) (addr: ireg) - | Pawait - | Psleep - | Pstop - | Pbarrier - | Pfence - | Pdinval - | Pdinvall (addr: ireg) - | Pdtouchl (addr: ireg) - | Piinval - | Piinvals (addr: ireg) - | Pitouchl (addr: ireg) - | Pdzerol (addr: ireg) -(*| Pafaddd (addr: ireg) (incr_res: ireg) - | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) - | Palclrd (dst: ireg) (addr: ireg) - | Palclrw (dst: ireg) (addr: ireg) - | Pclzll (rd rs: ireg) - | Pstsud (rd rs1 rs2: ireg) - - (** Loads **) - | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) - | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) - | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) - | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) - | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) - | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) - | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) - | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) - | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) - | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) - | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) - | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) - - (** Stores **) - | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) - | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) - | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) - | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) - | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) - | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) - - | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - - (** Arith RR *) - | Pmv (rd rs: ireg) (**r register move *) - | Pnegw (rd rs: ireg) (**r negate word *) - | Pnegl (rd rs: ireg) (**r negate long *) - | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) - | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) - | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) - - | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - - | Pfabsd (rd rs: ireg) (**r float absolute double *) - | Pfabsw (rd rs: ireg) (**r float absolute word *) - | Pfnegd (rd rs: ireg) (**r float negate double *) - | Pfnegw (rd rs: ireg) (**r float negate word *) - | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) - | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) - | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) - | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) - | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) - | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) - | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) - | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) - | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) - | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) - | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) - | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) - - (** Arith RI32 *) - | Pmake (rd: ireg) (imm: int) (**r load immediate *) - - (** Arith RI64 *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) - - (** Arith RF32 *) - | Pmakefs (rd: ireg) (imm: float32) - - (** Arith RF64 *) - | Pmakef (rd: ireg) (imm: float) - - (** Arith RRR *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) - | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) - | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) - | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) - - | Paddw (rd rs1 rs2: ireg) (**r add word *) - | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Psubw (rd rs1 rs2: ireg) (**r sub word *) - | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Pmulw (rd rs1 rs2: ireg) (**r mul word *) - | Pandw (rd rs1 rs2: ireg) (**r and word *) - | Pnandw (rd rs1 rs2: ireg) (**r nand word *) - | Porw (rd rs1 rs2: ireg) (**r or word *) - | Pnorw (rd rs1 rs2: ireg) (**r nor word *) - | Pxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pandnw (rd rs1 rs2: ireg) (**r andn word *) - | Pornw (rd rs1 rs2: ireg) (**r orn word *) - | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) - | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) - | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) - | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) - | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) - | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) - | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) - | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) - - | Paddl (rd rs1 rs2: ireg) (**r add long *) - | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) - | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) - | Pandl (rd rs1 rs2: ireg) (**r and long *) - | Pnandl (rd rs1 rs2: ireg) (**r nand long *) - | Porl (rd rs1 rs2: ireg) (**r or long *) - | Pnorl (rd rs1 rs2: ireg) (**r nor long *) - | Pxorl (rd rs1 rs2: ireg) (**r xor long *) - | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) - | Pandnl (rd rs1 rs2: ireg) (**r andn long *) - | Pornl (rd rs1 rs2: ireg) (**r orn long *) - | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) - | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) - | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) - | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) - | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) - | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) - | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) - - | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) - | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) - | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) - | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) - | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) - | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) - | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) - | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) - | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) - | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) - | Pfinvw (rd rs1: ireg) (**r Float invert word *) - - (** Arith RRI32 *) - | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) - - | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) - | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) - | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) - | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) - | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) - | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) - | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) - | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) - | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) - | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) - | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) - | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) - | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) - | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) - | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) - | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) - | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) - | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) - | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) - - (** Arith RRI64 *) - | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) - | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) - | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) - | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) - | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) - | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) - | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) - | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) - | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) - | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) - | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) -. - -(** Correspondance between Asmblock and Asm *) - -Definition control_to_instruction (c: control) := - match c with - | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res - | PCtlFlow Asmvliw.Pret => Pret - | PCtlFlow (Asmvliw.Pcall l) => Pcall l - | PCtlFlow (Asmvliw.Picall r) => Picall r - | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l - | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l - | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l - | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l - | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l - | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label - end. - -Definition basic_to_instruction (b: basic) := - match b with - (** Special basics *) - | Asmvliw.Pget rd rs => Pget rd rs - | Asmvliw.Pset rd rs => Pset rd rs - | Asmvliw.Pnop => Pnop - | Asmvliw.Pallocframe sz pos => Pallocframe sz pos - | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos - - (** PArith basics *) - (* R *) - | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs - - (* RR *) - | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs - | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs - | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs - | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs - | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs - | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs - | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start - | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start - | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start - | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start - | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs - | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs - | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs - | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs - | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs - | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs - | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs - | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs - | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs - | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs - | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs - | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs - | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs - | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs - | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs - - (* RI32 *) - | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm - - (* RI64 *) - | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm - - (* RF32 *) - | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm - - (* RF64 *) - | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm - - (* RRR *) - | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 - | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 - | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 - | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 - | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 - | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 - | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 - | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 - | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 - | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 - | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 - | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 - - | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 - | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 - | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 - | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 - | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 - | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 - | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 - | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 - | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 - | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 - | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 - - | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 - | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 - | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 - | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 - - (* RRI32 *) - | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm - | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm - | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm - | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm - | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm - | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm - | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm - | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm - | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm - | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm - | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm - | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm - | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm - | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm - | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm - | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm - | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm - | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm - | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm - | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm - | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm - | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm - | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm - - (* RRI64 *) - | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm - | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm - | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm - | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm - | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm - | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm - | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm - | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm - | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm - | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm - | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm - | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm - | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm - | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm - - (** ARRR *) - | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 - | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 - - (** ARR *) - | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start - | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start - - (** ARRI32 *) - | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm - - (** ARRI64 *) - | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm - (** Load *) - | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs) - - | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) - | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) - - | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro) - | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro) - | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro) - - | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro) - - (** Store *) - | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) - - | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) - | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) - - | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) - - | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) - | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) - end. - -Section RELSEM. - -Definition code := list instruction. - -Fixpoint unfold_label (ll: list label) := - match ll with - | nil => nil - | l :: ll => Plabel l :: unfold_label ll - end. - -Fixpoint unfold_body (lb: list basic) := - match lb with - | nil => nil - | b :: lb => basic_to_instruction b :: unfold_body lb - end. - -Definition unfold_exit (oc: option control) := - match oc with - | None => nil - | Some c => control_to_instruction c :: nil - end. - -Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ - (match (body b), (exit b) with - | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => - unfold_body bo - | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil - end). - -Fixpoint unfold (lb: bblocks) := - match lb with - | nil => nil - | b :: lb => (unfold_bblock b) ++ unfold lb - end. - -Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; - correct: unfold fn_blocks = fn_code }. - -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -Definition genv := Genv.t fundef unit. - -Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). - -Definition fundef_proj (fu: fundef) : Asmvliw.fundef := - match fu with - | Internal f => Internal (function_proj f) - | External ef => External ef - end. - -Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := - match gd with - | Gfun f => Gfun (fundef_proj f) - | Gvar gu => Gvar gu - end. - -Program Definition genv_trans (ge: genv) : Asmvliw.genv := - {| Genv.genv_public := Genv.genv_public ge; - Genv.genv_symb := Genv.genv_symb ge; - Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); - Genv.genv_next := Genv.genv_next ge |}. -Next Obligation. - destruct ge. simpl in *. eauto. -Qed. Next Obligation. - destruct ge; simpl in *. - rewrite PTree.gmap1 in H. - destruct (genv_defs ! b) eqn:GEN. - - eauto. - - discriminate. -Qed. Next Obligation. - destruct ge; simpl in *. - eauto. -Qed. - -Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) - : list (ident * globdef Asmvliw.fundef unit) := - match l with - | nil => nil - | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l - end. - -Definition program_proj (p: program) : Asmvliw.program := - {| prog_defs := prog_defs_proj (prog_defs p); - prog_public := prog_public p; - prog_main := prog_main p - |}. - -End RELSEM. - -Definition semantics (p: program) := Asmvliw.semantics (program_proj p). - -(** Determinacy of the [Asm] semantics. *) - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. - intros. apply semantics_determinate. -Qed. - -(** transf_program *) - -Program Definition transf_function (f: Asmvliw.function) : function := - {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; - fn_code := unfold (Asmvliw.fn_blocks f) |}. - -Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. -Proof. - intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. -Qed. - -Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. - -Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. -Proof. - intros f. destruct f as [f|e]; simpl; auto. - rewrite transf_function_proj. auto. -Qed. - -Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. - -Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), - prog_defs p1 = prog_defs p2 -> - prog_public p1 = prog_public p2 -> - prog_main p1 = prog_main p2 -> - p1 = p2. -Proof. - intros. destruct p1. destruct p2. simpl in *. subst. auto. -Qed. - -Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. -Proof. - intros p. destruct p as [defs pub main]. unfold program_proj. simpl. - apply program_equals; simpl; auto. - induction defs. - - simpl; auto. - - simpl. rewrite IHdefs. - destruct a as [id gd]; simpl. - destruct gd as [f|v]; simpl; auto. - rewrite transf_fundef_proj. auto. -Qed. - -Definition match_prog (p: Asmvliw.program) (tp: program) := - match_program (fun _ f tf => tf = transf_fundef f) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = tp -> match_prog p tp. -Proof. - intros. rewrite <- H. eapply match_transform_program; eauto. -Qed. - -Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. -Proof. - intros. congruence. -Qed. - -Lemma match_program_transf: - forall p tp, match_prog p tp -> transf_program p = tp. -Proof. - intros p tp H. inversion_clear H. inv H1. - destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. - subst. unfold transf_program. unfold transform_program. simpl. - apply program_equals; simpl; auto. - induction H0; simpl; auto. - rewrite IHlist_forall2. apply cons_extract. - destruct a1 as [ida gda]. destruct b1 as [idb gdb]. - simpl in *. - inv H. inv H2. - - simpl in *. subst. auto. - - simpl in *. subst. inv H. auto. -Qed. - -Section PRESERVATION. - -Variable prog: Asmvliw.program. -Variable tprog: program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Definition match_states (s1 s2: state) := s1 = s2. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - - -Theorem transf_program_correct: - forward_simulation (Asmvliw.semantics prog) (semantics tprog). -Proof. - pose proof (match_program_transf prog tprog TRANSF) as TR. - subst. unfold semantics. rewrite transf_program_proj. - - eapply forward_simulation_step with (match_states := match_states); simpl; auto. - - intros. exists s1. split; auto. congruence. - - intros. inv H. auto. - - intros. exists s1'. inv H0. split; auto. congruence. -Qed. - -End PRESERVATION. +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** * Abstract syntax for K1c textual assembly language. + + Each emittable instruction is defined here. ';;' is also defined as an instruction. + The goal of this representation is to stay compatible with the rest of the generic backend of CompCert + We define [unfold : list bblock -> list instruction] + An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] + [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Asmvliw. +Require Import Linking. +Require Import Errors. + +(** Definitions for OCaml code *) +Definition label := positive. +Definition preg := preg. + +Inductive addressing : Type := + | AOff (ofs: offset) + | AReg (ro: ireg) + | ARegXS (ro: ireg) +. + +(** Syntax *) +Inductive instruction : Type := + (** pseudo instructions *) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Plabel (lbl: label) (**r define a code label *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Psemi (**r semi colon separating bundles *) + | Pnop (**r instruction that does nothing *) + + (** Control flow instructions *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (rs: ireg) (**r function call on register *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (rs: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) + | Pjumptable (r: ireg) (labels: list label) + + (* For builtins *) + | Ploopdo (count: ireg) (loopend: label) + | Pgetn (n: int) (dst: ireg) + | Psetn (n: int) (src: ireg) + | Pwfxl (n: int) (src: ireg) + | Pwfxm (n: int) (src: ireg) + | Pldu (dst: ireg) (addr: ireg) + | Plbzu (dst: ireg) (addr: ireg) + | Plhzu (dst: ireg) (addr: ireg) + | Plwzu (dst: ireg) (addr: ireg) + | Pawait + | Psleep + | Pstop + | Pbarrier + | Pfence + | Pdinval + | Pdinvall (addr: ireg) + | Pdtouchl (addr: ireg) + | Piinval + | Piinvals (addr: ireg) + | Pitouchl (addr: ireg) + | Pdzerol (addr: ireg) +(*| Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) + | Palclrd (dst: ireg) (addr: ireg) + | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) + + (** Loads **) + | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) + | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) + + (** Stores **) + | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) + | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) + | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + + | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + + (** Arith RR *) + | Pmv (rd rs: ireg) (**r register move *) + | Pnegw (rd rs: ireg) (**r negate word *) + | Pnegl (rd rs: ireg) (**r negate long *) + | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) + | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) + | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) + + | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + + | Pfabsd (rd rs: ireg) (**r float absolute double *) + | Pfabsw (rd rs: ireg) (**r float absolute word *) + | Pfnegd (rd rs: ireg) (**r float negate double *) + | Pfnegw (rd rs: ireg) (**r float negate word *) + | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) + | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) + | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) + | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) + | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) + | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) + | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) + | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) + | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) + | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) + | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) + | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) + + (** Arith RI32 *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + + (** Arith RI64 *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + + (** Arith RF32 *) + | Pmakefs (rd: ireg) (imm: float32) + + (** Arith RF64 *) + | Pmakef (rd: ireg) (imm: float) + + (** Arith RRR *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) + | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) + + | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Pmulw (rd rs1 rs2: ireg) (**r mul word *) + | Pandw (rd rs1 rs2: ireg) (**r and word *) + | Pnandw (rd rs1 rs2: ireg) (**r nand word *) + | Porw (rd rs1 rs2: ireg) (**r or word *) + | Pnorw (rd rs1 rs2: ireg) (**r nor word *) + | Pxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pandnw (rd rs1 rs2: ireg) (**r andn word *) + | Pornw (rd rs1 rs2: ireg) (**r orn word *) + | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) + | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) + | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) + | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) + | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) + | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) + | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) + + | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) + | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | Pandl (rd rs1 rs2: ireg) (**r and long *) + | Pnandl (rd rs1 rs2: ireg) (**r nand long *) + | Porl (rd rs1 rs2: ireg) (**r or long *) + | Pnorl (rd rs1 rs2: ireg) (**r nor long *) + | Pxorl (rd rs1 rs2: ireg) (**r xor long *) + | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) + | Pandnl (rd rs1 rs2: ireg) (**r andn long *) + | Pornl (rd rs1 rs2: ireg) (**r orn long *) + | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) + | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) + | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) + | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) + | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) + | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) + | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) + + | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) + | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) + | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) + | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) + | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) + | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) + | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) + | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) + | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) + | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) + | Pfinvw (rd rs1: ireg) (**r Float invert word *) + + (** Arith RRI32 *) + | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) + + | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) + | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) + | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) + | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) + | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) + | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) + | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) + | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) + | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) + | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) + | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) + | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) + | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) + | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) + | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) + + (** Arith RRI64 *) + | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) + | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) + | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) + | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) + | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) + | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) + | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) + | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) + | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) + | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) + | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) +. + +(** Correspondance between Asmblock and Asm *) + +Definition control_to_instruction (c: control) := + match c with + | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res + | PCtlFlow Asmvliw.Pret => Pret + | PCtlFlow (Asmvliw.Pcall l) => Pcall l + | PCtlFlow (Asmvliw.Picall r) => Picall r + | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l + | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l + | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l + | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l + | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l + | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label + end. + +Definition basic_to_instruction (b: basic) := + match b with + (** Special basics *) + | Asmvliw.Pget rd rs => Pget rd rs + | Asmvliw.Pset rd rs => Pset rd rs + | Asmvliw.Pnop => Pnop + | Asmvliw.Pallocframe sz pos => Pallocframe sz pos + | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos + + (** PArith basics *) + (* R *) + | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + + (* RR *) + | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs + | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs + | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs + | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs + | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs + | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs + | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start + | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start + | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start + | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start + | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs + | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs + | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs + | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs + | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs + | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs + | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs + | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs + | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs + | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs + | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs + + (* RI32 *) + | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm + + (* RI64 *) + | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm + + (* RF32 *) + | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm + + (* RF64 *) + | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm + + (* RRR *) + | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 + | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 + | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 + | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 + | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 + | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 + | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 + | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 + | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 + | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 + + | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 + | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 + | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 + | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 + | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 + | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 + | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 + | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 + | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 + + | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 + | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 + | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 + | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 + + (* RRI32 *) + | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm + | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm + | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm + | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm + | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm + | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm + | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm + | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm + | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm + | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm + | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm + | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm + | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm + | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm + | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm + | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm + | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm + | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm + + (* RRI64 *) + | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm + | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm + | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm + | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm + | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm + | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm + | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm + | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm + | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm + | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm + | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm + + (** ARRR *) + | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 + + (** ARR *) + | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start + | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start + + (** ARRI32 *) + | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm + + (** ARRI64 *) + | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm + (** Load *) + | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs) + + | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) + | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) + + | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro) + | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro) + | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro) + | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro) + | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro) + | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro) + | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro) + | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro) + | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro) + | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro) + + | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro) + + (** Store *) + | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) + + | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) + | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) + + | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) + + | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) + | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) + end. + +Section RELSEM. + +Definition code := list instruction. + +Fixpoint unfold_label (ll: list label) := + match ll with + | nil => nil + | l :: ll => Plabel l :: unfold_label ll + end. + +Fixpoint unfold_body (lb: list basic) := + match lb with + | nil => nil + | b :: lb => basic_to_instruction b :: unfold_body lb + end. + +Definition unfold_exit (oc: option control) := + match oc with + | None => nil + | Some c => control_to_instruction c :: nil + end. + +Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ + (match (body b), (exit b) with + | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => + unfold_body bo + | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil + end). + +Fixpoint unfold (lb: bblocks) := + match lb with + | nil => nil + | b :: lb => (unfold_bblock b) ++ unfold lb + end. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; + correct: unfold fn_blocks = fn_code }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). + +Definition fundef_proj (fu: fundef) : Asmvliw.fundef := + match fu with + | Internal f => Internal (function_proj f) + | External ef => External ef + end. + +Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := + match gd with + | Gfun f => Gfun (fundef_proj f) + | Gvar gu => Gvar gu + end. + +Program Definition genv_trans (ge: genv) : Asmvliw.genv := + {| Genv.genv_public := Genv.genv_public ge; + Genv.genv_symb := Genv.genv_symb ge; + Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); + Genv.genv_next := Genv.genv_next ge |}. +Next Obligation. + destruct ge. simpl in *. eauto. +Qed. Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gmap1 in H. + destruct (genv_defs ! b) eqn:GEN. + - eauto. + - discriminate. +Qed. Next Obligation. + destruct ge; simpl in *. + eauto. +Qed. + +Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) + : list (ident * globdef Asmvliw.fundef unit) := + match l with + | nil => nil + | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l + end. + +Definition program_proj (p: program) : Asmvliw.program := + {| prog_defs := prog_defs_proj (prog_defs p); + prog_public := prog_public p; + prog_main := prog_main p + |}. + +End RELSEM. + +Definition semantics (p: program) := Asmvliw.semantics (program_proj p). + +(** Determinacy of the [Asm] semantics. *) + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. + intros. apply semantics_determinate. +Qed. + +(** transf_program *) + +Program Definition transf_function (f: Asmvliw.function) : function := + {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; + fn_code := unfold (Asmvliw.fn_blocks f) |}. + +Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. +Proof. + intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. +Qed. + +Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. + +Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. +Proof. + intros f. destruct f as [f|e]; simpl; auto. + rewrite transf_function_proj. auto. +Qed. + +Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. + +Definition match_prog (p: Asmvliw.program) (tp: program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + +Section PRESERVATION. + +Variable prog: Asmvliw.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Definition match_states (s1 s2: state) := s1 = s2. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Theorem transf_program_correct: + forward_simulation (Asmvliw.semantics prog) (semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. + subst. unfold semantics. rewrite transf_program_proj. + + eapply forward_simulation_step with (match_states := match_states); simpl; auto. + - intros. exists s1. split; auto. congruence. + - intros. inv H. auto. + - intros. exists s1'. inv H0. split; auto. congruence. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v index 94b39f4e..891d1068 100644 --- a/mppa_k1c/Asmaux.v +++ b/mppa_k1c/Asmaux.v @@ -2,4 +2,4 @@ Require Import Asm. Require Import AST. (** Constant only needed by Asmexpandaux.ml *) -Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. +Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. -- cgit From e3f2f81e6ad70c082dbf3dc5f938e8474c46657d Mon Sep 17 00:00:00 2001 From: Michael Schmidt Date: Sun, 13 Oct 2019 21:05:56 +0200 Subject: Fix configure for coq 8.10.0 --- configure | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure b/configure index dccf6d14..bf4172f9 100755 --- a/configure +++ b/configure @@ -530,14 +530,14 @@ 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.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10) + 8.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" 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.10, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" + echo "Error: CompCert requires one of the following Coq versions: 8.10.0, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" missingtools=true fi;; "") -- cgit From c59a26be1b4ae5c0ecf963d0ff2436dc73e72123 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 14 Oct 2019 10:50:34 +0200 Subject: Explicitly naming SP_split_args for easier grepping --- cparser/StructPassing.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cparser/StructPassing.ml b/cparser/StructPassing.ml index 5c6454f0..060a4848 100644 --- a/cparser/StructPassing.ml +++ b/cparser/StructPassing.ml @@ -68,7 +68,7 @@ let classify_param env ty = match !struct_passing_style with | SP_ref_callee -> Param_unchanged | SP_ref_caller -> Param_ref_caller - | _ -> + | SP_split_args -> match sizeof env ty, alignof env ty with | Some sz, Some al -> Param_flattened ((sz + 3) / 4, sz, al) -- cgit From 64a80f81297fb20c4f952d4b36cd0ae5d5da8f1e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 14 Oct 2019 11:17:45 +0200 Subject: Tackling struct passing by value for the future K1C ABI --- cparser/Machine.ml | 5 +++-- cparser/Machine.mli | 1 + cparser/StructPassing.ml | 8 ++++++++ 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/cparser/Machine.ml b/cparser/Machine.ml index ac34fa5f..4999f0ac 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -18,6 +18,7 @@ type struct_passing_style = | SP_ref_callee (* by reference, callee takes copy *) | SP_ref_caller (* by reference, caller takes copy *) + | SP_value32_ref_callee (* by value if <= 32 bits, by ref_callee otherwise *) | SP_split_args (* by value, as a sequence of ints *) type struct_return_style = @@ -268,8 +269,8 @@ let mppa_k1c = bigendian = false; bitfields_msb_first = false; (* TO CHECK *) supports_unaligned_accesses = true; - struct_passing_style = SP_split_args; - struct_return_style = SR_int1248 } + struct_passing_style = SP_value32_ref_callee; + struct_return_style = SR_int1to4 } (* Add GCC extensions re: sizeof and alignof *) diff --git a/cparser/Machine.mli b/cparser/Machine.mli index 56d8d0b9..24d36e6c 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -17,6 +17,7 @@ type struct_passing_style = | SP_ref_callee (* by reference, callee takes copy *) | SP_ref_caller (* by reference, caller takes copy *) + | SP_value32_ref_callee (* by value if <= 32 bits, by ref_callee otherwise *) | SP_split_args (* by value, as a sequence of ints *) type struct_return_style = diff --git a/cparser/StructPassing.ml b/cparser/StructPassing.ml index 060a4848..7bd72808 100644 --- a/cparser/StructPassing.ml +++ b/cparser/StructPassing.ml @@ -68,6 +68,14 @@ let classify_param env ty = match !struct_passing_style with | SP_ref_callee -> Param_unchanged | SP_ref_caller -> Param_ref_caller + | SP_value32_ref_callee -> + (match sizeof env ty, alignof env ty with + | Some sz, Some al -> + if (sz <= 4) then + Param_flattened ((sz+3)/4, sz, al) (* FIXME - why (sz+3)/4 ? *) + else + Param_unchanged + | _, _ -> failwith "StructPassing.classify_param SP_split_args32_ref_callee") | SP_split_args -> match sizeof env ty, alignof env ty with | Some sz, Some al -> -- cgit From ccfd145a139c2ac6af522b2c259cbfbf60573740 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 14 Oct 2019 15:49:35 +0200 Subject: Fix for test/regression/struct2.c --- cparser/StructPassing.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cparser/StructPassing.ml b/cparser/StructPassing.ml index 7bd72808..3aff090e 100644 --- a/cparser/StructPassing.ml +++ b/cparser/StructPassing.ml @@ -75,7 +75,8 @@ let classify_param env ty = Param_flattened ((sz+3)/4, sz, al) (* FIXME - why (sz+3)/4 ? *) else Param_unchanged - | _, _ -> failwith "StructPassing.classify_param SP_split_args32_ref_callee") + | _, _ -> Param_unchanged (* when parsing prototype with incomplete structure definition *) + ) | SP_split_args -> match sizeof env ty, alignof env ty with | Some sz, Some al -> -- cgit From 6d4ec0d398dcc9ec766c3f55ba4edbae63fb6a2f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Oct 2019 15:51:44 +0200 Subject: More elaborate comments + rewriting for easier to understand Asmblockgenproof.v --- mppa_k1c/Asmblockgenproof.v | 234 +++++++++++++++++--------------------------- 1 file changed, 89 insertions(+), 145 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ad4d2932..834e11e1 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -47,7 +47,6 @@ Lemma senv_preserved: Senv.equiv ge tge. Proof (Genv.senv_match TRANSF). - Lemma functions_translated: forall b f, Genv.find_funct_ptr ge b = Some f -> @@ -65,8 +64,6 @@ Proof. monadInv B. rewrite H0 in EQ; inv EQ; auto. Qed. -(** * Properties of control flow *) - Lemma transf_function_no_overflow: forall f tf, transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. @@ -75,23 +72,7 @@ Proof. omega. Qed. -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. +Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) Lemma gen_bblocks_label: forall hd bdy ex tbb tc, @@ -113,7 +94,7 @@ Proof. all: inv GENB; simpl; auto. Qed. -Lemma in_dec_transl: +Remark in_dec_transl: forall lbl hd, (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). Proof. @@ -226,7 +207,7 @@ Proof. rewrite H. auto. Qed. -Lemma transl_find_label: +Theorem transl_find_label: forall lbl f tf, transf_function f = OK tf -> match MB.find_label lbl f.(MB.fn_code) with @@ -241,8 +222,8 @@ Qed. End TRANSL_LABEL. -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated Asm code. *) +(** A valid branch in a piece of Machblock code translates to a valid ``go to'' + transition in the generated Asmblock code. *) Lemma find_label_goto_label: forall f tf lbl rs m c' b ofs, @@ -270,48 +251,47 @@ Qed. (** Existence of return addresses *) -(* NB: the hypothesis in comment on [b] is not needed in the proof ! -*) Lemma return_address_exists: - forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> exists ra, return_address_offset f c ra. Proof. intros. eapply Asmblockgenproof0.return_address_exists; eauto. - intros. monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. -(* rewrite transl_code'_transl_code in EQ0. *) - exists x; exists true; split; auto. (* unfold fn_code. *) + exists x; exists true; split; auto. repeat constructor. - - exact transf_function_no_overflow. +- exact transf_function_no_overflow. Qed. (** * Proof of semantic preservation *) -(** Semantic preservation is proved using simulation diagrams +(** Semantic preservation is proved using a complex simulation diagram of the following form. << - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' + MB.step + ----------------------------------------> + header body exit + st1 -----> st2 -----> st3 ------------------> st4 + | | | | + | (A) | (B) | (C) | + match_codestate | | | | + | header | body1 | body2 | match_states + cs1 -----> cs2 -----> cs3 ------> cs4 | + | / \ exit | + match_asmstate | --------------- --->--- | + | / match_asmstate \ | + st'1 ---------------------------------------> st'2 + AB.step * >> - The invariant is the [match_states] predicate below, which includes: -- The Asm code pointed by the PC register is the translation of - the current Mach code sequence. -- Mach register values and Asm register values agree. -*) - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the Asm side. Actually, all Mach transitions - correspond to at least one Asm transition, except the - transition from [Machsem.Returnstate] to [Machsem.State]. - So, the following integer measure will suffice to rule out - the unwanted behaviour. *) + The invariant between each MB.step/AB.step is the [match_states] predicate below. + However, we also need to introduce an intermediary state [Codestate] which allows + us to reason on a finer grain, executing header, body and exit separately. + This [Codestate] consists in a state like [Asmblock.State], except that the + code is directly stored in the state, much like [Machblock.State]. It also features + additional useful elements to keep track of while executing a bblock. +*) Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. Proof. @@ -349,17 +329,18 @@ Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := (Asmvliw.State rs m'). Record codestate := - Codestate { pstate: state; + Codestate { pstate: state; (**r projection to Asmblock.state *) pheader: list label; - pbody1: list basic; - pbody2: list basic; - pctl: option control; - ep: bool; - rem: list AB.bblock; - cur: bblock }. - -(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) - + pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) + pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) + pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) + ep: bool; (**r reflects the [ep] variable used in the translation *) + rem: list AB.bblock; (**r remaining bblocks to execute *) + cur: bblock (**r current bblock to execute - to keep track of its size when incrementing PC *) + }. + +(* The part that deals with Machblock <-> Codestate agreement + * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) Inductive match_codestate fb: Machblock.state -> codestate -> Prop := | match_codestate_intro: forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi @@ -369,7 +350,6 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) (TIC: transl_instr_control f (MB.exit bb) = OK tbi) (TBLS: transl_blocks f c false = OK tc) -(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) (AG: agree ms sp rs0) (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) , @@ -377,7 +357,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := {| pstate := (Asmvliw.State rs0 m0); pheader := (MB.header bb); pbody1 := tbc; - pbody2 := (extract_basic tbi); + pbody2 := extract_basic tbi; pctl := extract_ctl tbi; ep := ep; rem := tc; @@ -385,6 +365,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := |} . +(* The part ensuring that the code in Codestate actually resides at [rs PC] *) Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := | match_asmstate_some: forall rs f tf tc m tbb ofs ep tbdy tex lhd @@ -392,7 +373,6 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := (TRANSF: transf_function f = OK tf) (PCeq: rs PC = Vptr fb ofs) (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) -(* (HDROK: header tbb = lhd) *) , match_asmstate fb {| pstate := (Asmvliw.State rs m); @@ -406,6 +386,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := (Asmvliw.State rs m) . +(* Useful for dealing with the many cases in some proofs *) Ltac exploreInst := repeat match goal with | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var @@ -417,6 +398,8 @@ Ltac exploreInst := | [ H : Error _ = OK _ |- _ ] => inversion H end. +(** Some translation properties *) + Lemma transl_blocks_nonil: forall f bb c tc ep, transl_blocks f (bb::c) ep = OK tc -> @@ -584,6 +567,9 @@ Proof. * unfold transl_comp_notfloat32. exploreInst; try discriminate. Qed. +(* Proving that one can decompose a [match_state] relation into a [match_codestate] + and a [match_asmstate], along with some helpful properties tying both relations together *) + Theorem match_state_codestate: forall mbs abs s fb sp bb c ms m, (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -624,7 +610,7 @@ Definition mb_remove_body (bb: MB.bblock) := Lemma exec_straight_pnil: forall c rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 -> + exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 -> exec_straight tge c rs1 m1 nil rs2 m2. Proof. intros. eapply exec_straight_trans. eapply H. econstructor; eauto. @@ -656,10 +642,9 @@ Lemma nextblock_preserves: Proof. intros. destruct r; try discriminate. subst. Simpl. -(* - subst. Simpl. *) Qed. -Lemma cons3_app {A: Type}: +Remark cons3_app {A: Type}: forall a b c (l: list A), a :: b :: c :: l = (a :: b :: c :: nil) ++ l. Proof. @@ -693,27 +678,11 @@ Proof. induction lb; intros; simpl; congruence. Qed. -(* Lemma goto_label_inv: - forall fn tbb l rs m b ofs, - rs PC = Vptr b ofs -> - goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m. -Proof. - intros. - unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H. - exploreInst; auto. - unfold nextblock. rewrite Pregmap.gss. - -Qed. - - -Lemma exec_control_goto_label_inv: - exec_control tge fn (Some ctl) rs m = goto_label fn l rs m -> - exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m. -Proof. -Qed. *) - +(* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are + unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by + yourself the steps *) Theorem step_simu_control: - forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2, + forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, MB.body bb' = nil -> (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> Genv.find_funct_ptr tge fb = Some (Internal fn) -> @@ -722,7 +691,7 @@ Theorem step_simu_control: cur cs2 = tbb -> match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> - exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> + exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> (exists rs3 m3 rs4 m4, exec_body tge tbdy2 rs2 m2 = Next rs3 m3 /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 @@ -834,7 +803,6 @@ Proof. assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. remember (nextblock tbb rs2) as rs2'. - (* inv AT. monadInv H4. *) exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. assert (tf = fn) by congruence. subst tf. exploit find_label_goto_label. @@ -853,7 +821,6 @@ Proof. assert (forall r : preg, r <> PC -> rs' r = rs2 r). { intros. destruct r. - destruct g. all: rewrite INV; Simpl; auto. -(* - destruct g. all: rewrite INV; Simpl; auto. *) - rewrite INV; Simpl; auto. - contradiction. } eauto with asmgen. @@ -932,7 +899,7 @@ Proof. intros [tc' [rs' [A [B C]]]]. exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. - + repeat eexists. rewrite H6. simpl extract_basic. simpl. eauto. rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. @@ -955,7 +922,7 @@ Proof. simpl. eauto. intros EXEB. assert (f1 = f) by congruence. subst f1. - + repeat eexists. rewrite H6. simpl extract_basic. eauto. rewrite H7. simpl extract_ctl. simpl. reflexivity. @@ -963,10 +930,7 @@ Proof. unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. -(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) - intros (TLB & TLBS). - *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. -(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *) + destruct bb' as [hd' bdy' ex']; simpl in *. subst. monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. simpl. repeat eexists. econstructor. 4: instantiate (3 := false). all:eauto. @@ -1023,7 +987,8 @@ Proof. all: eauto. Qed. -Lemma step_simu_basic: +(* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) +Theorem step_simu_basic: forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> @@ -1058,7 +1023,7 @@ Proof. eapply basics_to_code_app; eauto. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } -(* rewrite <- Hheadereq. *) subst. simpl in Hheadereq. + subst. simpl in Hheadereq. eapply match_codestate_intro; eauto. { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } @@ -1084,8 +1049,7 @@ Proof. repeat (split; auto). eapply basics_to_code_app; eauto. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. + subst. eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. eapply agree_undef_regs; eauto with asmgen. @@ -1101,10 +1065,9 @@ Proof. exploit Mem.loadv_extends. eauto. eexact H1. auto. intros [v' [C D]]. - (* Opaque loadind. *) -(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. destruct ep0 eqn:EPeq. + (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. @@ -1119,14 +1082,14 @@ Proof. { eapply basics_to_code_app; eauto. } remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - (* rewrite <- Hheadereq. *)subst. + subst. eapply match_codestate_intro; eauto. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. simpl; intros. rewrite R; auto with asmgen. apply preg_of_not_FP; auto. - (* GPR11 does not contain parent *) + (* RTMP does not contain parent *) + rewrite chunk_of_Tptr in A. exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. @@ -1157,7 +1120,7 @@ Proof. apply preg_of_not_FP; auto. - (* MBop *) simpl in EQ0. rewrite Hheader in DXP. - + assert (eval_operation tge sp op (map ms args) m' = Some v). rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. exploit eval_operation_lessdef. @@ -1175,8 +1138,7 @@ Proof. repeat (split; auto). eapply basics_to_code_app; eauto. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. + subst. eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. apply agree_set_undef_mreg with rs1; auto. apply Val.lessdef_trans with v'; auto. @@ -1265,12 +1227,11 @@ Inductive exec_header: codestate -> codestate -> Prop := | exec_header_cons: forall cs1, exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; - (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) cur := cur cs1 |}. -Lemma step_simu_header: +(* Theorem (A) in the diagram, the easiest of all *) +Theorem step_simu_header: forall bb s fb sp c ms m rs1 m1 cs1, -(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *) pstate cs1 = (State rs1 m1) -> match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> (exists cs1', @@ -1295,7 +1256,8 @@ Proof. simpl. econstructor; eauto. Qed. -Lemma step_simu_body: +(* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) +Theorem step_simu_body: forall bb s fb sp c ms m rs1 m1 ms' cs1 m', MB.header bb = nil -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -1326,23 +1288,6 @@ Proof. rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. Qed. -(* Lemma exec_body_straight: - forall l rs0 m0 rs1 m1, - l <> nil -> - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_straight tge l rs0 m0 nil rs1 m1. -Proof. - induction l as [|i1 l]. - intros. contradict H; auto. - destruct l as [|i2 l]. - - intros until m1. intros _ EXEB. simpl in EXEB. - destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - inv EXEB. econstructor; eauto. - - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl. - destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate. - econstructor; eauto. eapply IHl; eauto. discriminate. -Qed. *) - Lemma exec_body_pc: forall l rs1 m1 rs2 m2, exec_body tge l rs1 m1 = Next rs2 m2 -> @@ -1387,7 +1332,8 @@ Proof. contradict H. unfold mbsize. simpl. auto. Qed. -(* Alternative form of step_simulation_bblock, easier to prove *) +(* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) +(* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) Lemma step_simulation_bblock': forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, bb' = mb_remove_header bb -> @@ -1436,8 +1382,6 @@ Proof. intros (cs1' & EXEH & MCS2). (* step_simu_body part *) -(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. } - rewrite H in BSTEP. clear H. *) assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } exploit step_simu_body. 3: eapply BSTEP. @@ -1487,7 +1431,7 @@ Proof. eapply find_bblock_tail; eauto. Qed. -Lemma step_simulation_bblock: +Theorem step_simulation_bblock: forall sf f sp bb ms m ms' m' S2 c, body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -1503,12 +1447,7 @@ Proof. - econstructor. Qed. -Definition measure (s: MB.state) : nat := - match s with - | MB.State _ _ _ _ _ _ => 0%nat - | MB.Callstate _ _ _ _ => 0%nat - | MB.Returnstate _ _ _ => 1%nat - end. +(** Dealing now with the builtin case *) Definition split (c: MB.code) := match c with @@ -1564,7 +1503,7 @@ Proof. eapply transl_code_at_pc_split_builtin; eauto. Qed. -Lemma step_simulation_builtin: +Theorem step_simulation_builtin: forall ef args res bb sf f sp c ms m t S2, MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> @@ -1611,6 +1550,16 @@ Proof. congruence. Qed. +(* Measure to prove finite stuttering, see the other backends *) +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +(* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs + for the internal and external function cases *) Theorem step_simulation: forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> forall S1' (MS: match_states S1 S1'), @@ -1665,25 +1614,20 @@ Proof. exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. intros [m3' [P Q]]. (* Execution of function prologue *) - monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) + monadInv EQ0. set (tfbody := make_prologue f x0) in *. set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. intros (rs' & U' & V'). -(* exploit (exec_straight_through_singleinst); eauto. - intro W'. remember (nextblock _ rs') as rs''. *) exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). rewrite chunk_of_Tptr in P. assert (rs' GPRA = rs0 RA). { apply V'. } assert (rs' SP = rs2 SP). { apply V'; discriminate. } rewrite H4. rewrite H3. - (* change (rs' GPRA) with (rs0 RA). *) rewrite ATLR. change (rs2 SP) with sp. eexact P. intros (rs3 & U & V). -(* exploit (exec_straight_through_singleinst); eauto. - intro W. *) assert (EXEC_PROLOGUE: exists rs3', exec_straight_blocks tge tf tf.(fn_blocks) rs0 m' @@ -1729,7 +1673,6 @@ Local Transparent destroyed_at_function_entry. rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - (* rewrite H8; auto. *) contradict H3; rewrite H3; unfold data_preg; auto. contradict H3; rewrite H3; unfold data_preg; auto. contradict H3; rewrite H3; unfold data_preg; auto. @@ -1737,6 +1680,7 @@ Local Transparent destroyed_at_function_entry. intros. rewrite Heqrs3'. rewrite V by auto with asmgen. assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } rewrite H4 by auto with asmgen. reflexivity. discriminate. + - (* external function *) inv MS. exploit functions_translated; eauto. -- cgit From 72378d9371bc5da342266bcf14231ab568e0f919 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Oct 2019 16:01:30 +0200 Subject: Few minor other changes in proof --- mppa_k1c/Asmblockgenproof.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 834e11e1..bd2dc985 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1621,12 +1621,12 @@ Proof. exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. intros (rs' & U' & V'). exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). - rewrite chunk_of_Tptr in P. + { rewrite chunk_of_Tptr in P. assert (rs' GPRA = rs0 RA). { apply V'. } assert (rs' SP = rs2 SP). { apply V'; discriminate. } rewrite H4. rewrite H3. rewrite ATLR. - change (rs2 SP) with sp. eexact P. + change (rs2 SP) with sp. eexact P. } intros (rs3 & U & V). assert (EXEC_PROLOGUE: exists rs3', exec_straight_blocks tge tf @@ -1652,7 +1652,7 @@ Proof. } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). exploit exec_straight_steps_2; eauto using functions_transl. simpl fn_blocks. simpl fn_blocks in g. omega. constructor. - intros (ofs' & X & Y). + intros (ofs' & X & Y). left; exists (State rs3' m3'); split. eapply exec_straight_steps_1; eauto. simpl fn_blocks. simpl fn_blocks in g. omega. -- cgit From d4e2f7b715b21efe0d693415ab63dad5a22afa92 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 16 Oct 2019 18:34:30 +0200 Subject: eq_condition already existed --- backend/Duplicate.v | 2 +- backend/Duplicateproof.v | 2 +- mppa_k1c/Op.v | 6 ------ 3 files changed, 2 insertions(+), 8 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index d1458bd4..68a7f413 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -157,7 +157,7 @@ Definition verify_match_inst revmap inst tinst := | Icond cond' lr' n1' n2' => do u1 <- verify_is_copy revmap n1 n1'; do u2 <- verify_is_copy revmap n2 n2'; - if (condition_eq cond cond') then + if (eq_condition cond cond') then if (list_eq_dec Pos.eq_dec lr lr') then OK tt else Error (msg "Different lr in Icond") else Error (msg "Different cond in Icond") diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 54dd6196..d16505dd 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -132,7 +132,7 @@ Proof. - destruct i'; try (inversion H; fail). monadInv H. destruct x. eapply verify_is_copy_correct in EQ. destruct x0. eapply verify_is_copy_correct in EQ1. - destruct (condition_eq _ _); try discriminate. + destruct (eq_condition _ _); try discriminate. destruct (list_eq_dec _ _ _); try discriminate. subst. constructor; assumption. (* Ijumptable *) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index ce9a5dcd..f9a774e8 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -51,12 +51,6 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) -Definition condition_eq: forall (x y: condition), {x = y} + {x <> y}. -Proof. - generalize comparison_eq int_eq int64_eq. - decide equality. -Defined. - Inductive condition0 : Type := | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) -- cgit From a7d7fff55965bae9abc341156719f8828597f7da Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 16 Oct 2019 18:37:06 +0200 Subject: fix compile for rv32 --- riscV/Asmgen.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index a704ed74..631693b9 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -25,6 +25,8 @@ Require Import Op Locations Mach Asm. Local Open Scope string_scope. Local Open Scope error_monad_scope. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. + (** 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 -- cgit From e1799093f9b9663f0d3c031357a8ce8b4a835c4d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 21 Oct 2019 11:57:28 +0200 Subject: Adding MPPA endianess in test/endian.h --- test/endian.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/endian.h b/test/endian.h index 8be2850c..d6e121f4 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(__riscv) || defined(__aarch64__) || defined(__K1C__) #undef ARCH_BIG_ENDIAN #else #error "unknown endianness" -- cgit From e247f20f8fb530bb225ac04f2e1589beaffcb257 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 21 Oct 2019 18:11:33 +0200 Subject: Un espace en trop --- mppa_k1c/Asmblockgen.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index bbe24fec..abb24327 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1185,7 +1185,7 @@ Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := match lmb with | nil => OK nil - | mb :: lmb => + | mb :: lmb => do lb <- transl_block f mb (if Machblock.header mb then ep else false); do lb' <- transl_blocks f lmb false; OK (lb @@ lb') -- cgit From 8bee1136d7d298e9f33ea91ee7a248909467dd13 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 22 Oct 2019 17:44:15 +0200 Subject: Scaling down forgotten tests -> test/c/ operational --- test/c/Results/mandelbrot-mppa_k1c | Bin 709 -> 409 bytes test/c/aes.c | 4 ++++ test/c/almabench.c | 7 ++++++- test/c/mandelbrot.c | 2 +- test/c/sha1.c | 4 ++++ test/c/sha3.c | 5 +++++ test/c/siphash24.c | 8 +++++++- 7 files changed, 27 insertions(+), 3 deletions(-) diff --git a/test/c/Results/mandelbrot-mppa_k1c b/test/c/Results/mandelbrot-mppa_k1c index 246f7ce1..f50961fe 100644 Binary files a/test/c/Results/mandelbrot-mppa_k1c and b/test/c/Results/mandelbrot-mppa_k1c differ diff --git a/test/c/aes.c b/test/c/aes.c index 16f02e47..0a64fe60 100644 --- a/test/c/aes.c +++ b/test/c/aes.c @@ -1441,6 +1441,10 @@ 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__ + do_bench(2000); +#else do_bench(1000000); +#endif return 0; } diff --git a/test/c/almabench.c b/test/c/almabench.c index 5487b062..4417200c 100644 --- a/test/c/almabench.c +++ b/test/c/almabench.c @@ -42,10 +42,15 @@ #define R2D (180.0 / PI) #define GAUSSK 0.01720209895 #define TEST_LOOPS 20 -#define TEST_LENGTH 36525 #define sineps 0.3977771559319137 #define coseps 0.9174820620691818 +#ifdef __K1C__ +#define TEST_LENGTH 12 +#else +#define TEST_LENGTH 36525 +#endif + const double amas [8] = { 6023600.0, 408523.5, 328900.5, 3098710.0, 1047.355, 3498.5, 22869.0, 19314.0 }; const double a [8][3] = diff --git a/test/c/mandelbrot.c b/test/c/mandelbrot.c index 133d55c5..fb8b929c 100644 --- a/test/c/mandelbrot.c +++ b/test/c/mandelbrot.c @@ -27,7 +27,7 @@ int main (int argc, char **argv) if (argc < 2) { #ifdef __K1C__ - w = h = 50; + w = h = 40; #else w = h = 1000; #endif diff --git a/test/c/sha1.c b/test/c/sha1.c index 0a6ac8fe..624030cc 100644 --- a/test/c/sha1.c +++ b/test/c/sha1.c @@ -231,6 +231,10 @@ int main(int argc, char ** argv) } do_test(test_input_1, test_output_1); do_test(test_input_2, test_output_2); +#ifdef __K1C__ + do_bench(500); +#else do_bench(200000); +#endif return 0; } diff --git a/test/c/sha3.c b/test/c/sha3.c index a0905817..164e3086 100644 --- a/test/c/sha3.c +++ b/test/c/sha3.c @@ -190,8 +190,13 @@ test_triplet_t testvec[4] = { } }; +#ifdef __K1C__ +#define DATALEN 1000 +#define NITER 7 +#else #define DATALEN 100000 #define NITER 25 +#endif int main() { diff --git a/test/c/siphash24.c b/test/c/siphash24.c index 4a42e013..ce0df78c 100644 --- a/test/c/siphash24.c +++ b/test/c/siphash24.c @@ -235,13 +235,19 @@ int test_vectors() u8 testdata[100] = { 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 12, 34, 56, 78, 90 }; +#ifdef __K1C__ +#define NITER 1000 +#else +#define NITER 1000000 +#endif + int speed_test(void) { u8 out[8], k[16]; int i; for(i = 0; i < 16; ++i ) k[i] = i; - for(i = 0; i < 1000000; i++) { + for(i = 0; i < NITER; i++) { testdata[99] = (u8) i; crypto_auth(out, testdata, 100, k); } -- cgit From 64e7c075685d3653d67de29f2c5bc6f2bb1c47ae Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 23 Oct 2019 15:41:43 +0200 Subject: An alternative proof where the match_state does not depend on the translation --- backend/Duplicate.v | 7 --- backend/Duplicateproof.v | 130 ++++++++++++++++++++++++++++------------------- 2 files changed, 77 insertions(+), 60 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index d1458bd4..a00ef71f 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -222,13 +222,6 @@ Proof. repeat (split; try reflexivity). Qed. -Remark transf_function_aux_fnsig: forall f xf, transf_function_aux f = OK xf -> fn_sig f = fn_sig (fn_RTL xf). - Proof. apply transf_function_aux_preserves. Qed. -Remark transf_function_aux_fnparams: forall f xf, transf_function_aux f = OK xf -> fn_params f = fn_params (fn_RTL xf). - Proof. apply transf_function_aux_preserves. Qed. -Remark transf_function_aux_fnstacksize: forall f xf, transf_function_aux f = OK xf -> fn_stacksize f = fn_stacksize (fn_RTL xf). - Proof. apply transf_function_aux_preserves. Qed. - Definition transf_function (f: function) : res function := do xf <- transf_function_aux f; OK (fn_RTL xf). diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 54dd6196..da6d24d0 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -5,14 +5,7 @@ Require Import Op RTL Duplicate. Local Open Scope positive_scope. -Definition match_prog (p tp: program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -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. +(** * Definition of [match_states] (independently of the translation) *) (* est-ce plus simple de prendre is_copy: node -> node, avec un noeud hors CFG à la place de None ? *) Inductive match_inst (is_copy: node -> option node): instruction -> instruction -> Prop := @@ -38,6 +31,46 @@ Inductive match_inst (is_copy: node -> option node): instruction -> instruction match_inst is_copy (Ijumptable r ln) (Ijumptable r ln') | match_inst_return: forall or, match_inst is_copy (Ireturn or) (Ireturn or). +Record match_function f xf: Prop := { + revmap_correct: forall n n', (fn_revmap xf)!n' = Some n -> + (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n' => (fn_revmap xf)!n') i i'); + revmap_entrypoint: (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f); + preserv_fnsig: fn_sig f = fn_sig (fn_RTL xf); + preserv_fnparams: fn_params f = fn_params (fn_RTL xf); + preserv_fnstacksize: fn_stacksize f = fn_stacksize (fn_RTL xf) +}. + +Inductive match_fundef: RTL.fundef -> RTL.fundef -> Prop := + | match_Internal f xf: match_function f xf -> match_fundef (Internal f) (Internal (fn_RTL xf)) + | match_External ef: match_fundef (External ef) (External ef). + + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + | match_stackframe_intro: + forall res f sp pc rs xf pc' + (TRANSF: match_function f xf) + (DUPLIC: (fn_revmap xf)!pc' = Some pc), + match_stackframes (Stackframe res f sp pc rs) (Stackframe res (fn_RTL xf) sp pc' rs). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall st f sp pc rs m st' xf pc' + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: match_function f xf) + (DUPLIC: (fn_revmap xf)!pc' = Some pc), + match_states (State st f sp pc rs m) (State st' (fn_RTL xf) sp pc' rs m) + | match_states_call: + forall st st' f f' args m + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: match_fundef f f'), + match_states (Callstate st f args m) (Callstate st' f' args m) + | match_states_return: + forall st st' v m + (STACKS: list_forall2 match_stackframes st st'), + match_states (Returnstate st v m) (Returnstate st' v m). + +(** * Auxiliary properties *) + Lemma verify_mapping_mn_rec_step: forall lb b f xf, In b lb -> @@ -181,28 +214,42 @@ Proof. eapply verify_mapping_mn_correct; eauto. Qed. - -Theorem revmap_correct: forall f xf n n', - transf_function_aux f = OK xf -> - (fn_revmap xf)!n' = Some n -> - (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n' => (fn_revmap xf)!n') i i'). +Theorem transf_function_correct f xf: + transf_function_aux f = OK xf -> match_function f xf. Proof. - intros until n'. intros TRANSF REVM i FNC. + intros TRANSF ; constructor 1; try (apply transf_function_aux_preserves; auto). + + (* correct *) + intros until n'. intros REVM i FNC. unfold transf_function_aux in TRANSF. destruct (duplicate_aux f) as (tcte & mp). destruct tcte as (tc & te). monadInv TRANSF. simpl in *. monadInv EQ. clear EQ0. unfold verify_mapping_match_nodes in EQ. simpl in EQ. destruct x1. eapply verify_mapping_mn_rec_correct. 5: eapply EQ. all: eauto. + + (* entrypoint *) + intros. unfold transf_function_aux in TRANSF. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). + monadInv TRANSF. simpl. monadInv EQ. unfold verify_mapping_entrypoint in EQ0. simpl in EQ0. + destruct (mp ! te) eqn:PT; try discriminate. + destruct (n ?= fn_entrypoint f) eqn:EQQ; try discriminate. inv EQ0. + apply Pos.compare_eq in EQQ. congruence. +Qed. + +Lemma transf_fundef_correct f f': + transf_fundef f = OK f' -> match_fundef f f'. +Proof. + intros TRANSF; destruct f; simpl; monadInv TRANSF. + + monadInv EQ. + eapply match_Internal; eapply transf_function_correct; eauto. + + eapply match_External. Qed. +(** * Preservation proof *) -Theorem revmap_entrypoint: - forall f xf, transf_function_aux f = OK xf -> (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f). +Definition match_prog (p tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. Proof. - intros. unfold transf_function_aux in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). - monadInv H. simpl. monadInv EQ. unfold verify_mapping_entrypoint in EQ0. simpl in EQ0. - destruct (mp ! te) eqn:PT; try discriminate. - destruct (n ?= fn_entrypoint f) eqn:EQQ; try discriminate. inv EQ0. - apply Pos.compare_eq in EQQ. congruence. + intros. eapply match_transform_partial_program_contextual; eauto. Qed. Section PRESERVATION. @@ -288,30 +335,6 @@ Proof. intros (pc'1 & LNZ & REV). exists pc'1. split; auto. congruence. Qed. -Inductive match_stackframes: stackframe -> stackframe -> Prop := - | match_stackframe_intro: - forall res f sp pc rs xf pc' - (TRANSF: transf_function_aux f = OK xf) - (DUPLIC: (fn_revmap xf)!pc' = Some pc), - match_stackframes (Stackframe res f sp pc rs) (Stackframe res (fn_RTL xf) sp pc' rs). - -Inductive match_states: state -> state -> Prop := - | match_states_intro: - forall st f sp pc rs m st' xf pc' - (STACKS: list_forall2 match_stackframes st st') - (TRANSF: transf_function_aux f = OK xf) - (DUPLIC: (fn_revmap xf)!pc' = Some pc), - match_states (State st f sp pc rs m) (State st' (fn_RTL xf) sp pc' rs m) - | match_states_call: - forall st st' f f' args m - (STACKS: list_forall2 match_stackframes st st') - (TRANSF: transf_fundef f = OK f'), - match_states (Callstate st f args m) (Callstate st' f' args m) - | match_states_return: - forall st st' v m - (STACKS: list_forall2 match_stackframes st st'), - match_states (Returnstate st v m) (Returnstate st' v m). - Theorem transf_initial_states: forall s1, initial_state prog s1 -> exists s2, initial_state tprog s2 /\ match_states s1 s2. @@ -327,7 +350,7 @@ Proof. + destruct f. * monadInv TRANSF. monadInv EQ. rewrite <- H3. symmetry; eapply transf_function_aux_preserves. assumption. * monadInv TRANSF. (* monadInv EQ. *) assumption. - - constructor; eauto. constructor. + - constructor; eauto. constructor. apply transf_fundef_correct; auto. Qed. Theorem transf_final_states: @@ -344,6 +367,7 @@ Theorem step_simulation: step tge s2 t s2' /\ match_states s1' s2'. Proof. + Local Hint Resolve transf_fundef_correct. induction 1; intros; inv MS. (* Inop *) - eapply revmap_correct in DUPLIC; eauto. @@ -400,14 +424,14 @@ Proof. eexists. split. + eapply exec_Itailcall. eassumption. simpl. eassumption. apply function_sig_translated. assumption. - erewrite <- transf_function_aux_fnstacksize; eauto. + erewrite <- preserv_fnstacksize; eauto. + repeat (constructor; auto). * simpl in H0. destruct (Genv.find_symbol _ _) eqn:GFS; try discriminate. apply function_ptr_translated in H0. destruct H0 as (tf & GFF & TF). eexists. split. + eapply exec_Itailcall. eassumption. simpl. rewrite symbols_preserved. rewrite GFS. eassumption. apply function_sig_translated. assumption. - erewrite <- transf_function_aux_fnstacksize; eauto. + erewrite <- preserv_fnstacksize; eauto. + repeat (constructor; auto). (* Ibuiltin *) - eapply revmap_correct in DUPLIC; eauto. @@ -437,15 +461,15 @@ Proof. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. - + eapply exec_Ireturn; eauto. erewrite <- transf_function_aux_fnstacksize; eauto. + + eapply exec_Ireturn; eauto. erewrite <- preserv_fnstacksize; eauto. + constructor; auto. (* exec_function_internal *) - - monadInv TRANSF. monadInv EQ. eexists. split. - + eapply exec_function_internal. erewrite <- transf_function_aux_fnstacksize; eauto. - + erewrite transf_function_aux_fnparams; eauto. + - inversion TRANSF as [f0 xf MATCHF|]; subst. eexists. split. + + eapply exec_function_internal. erewrite <- preserv_fnstacksize; eauto. + + erewrite preserv_fnparams; eauto. econstructor; eauto. apply revmap_entrypoint. assumption. (* exec_function_external *) - - monadInv TRANSF. (* monadInv EQ. *) eexists. split. + - inversion TRANSF as [|]; subst. eexists. split. + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + constructor. assumption. (* exec_return *) -- cgit From 8fbe9863a920f6351a13c5a7f0028b8640b9319d Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 28 Oct 2019 11:20:28 +0100 Subject: clightgen: sanitize names of functions and global variables A "dollar" sign in a function name or a global variable name was producing incorrect Coq identifiers. (Issue #319.) --- exportclight/ExportClight.ml | 8 ++++---- test/clightgen/issue319.c | 12 ++++++++++++ 2 files changed, 16 insertions(+), 4 deletions(-) create mode 100644 test/clightgen/issue319.c diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml index b124586a..d86e137a 100644 --- a/exportclight/ExportClight.ml +++ b/exportclight/ExportClight.ml @@ -381,7 +381,7 @@ and lblstmts p = function (print_option coqZ) lbl stmt s lblstmts ls let print_function p (id, f) = - fprintf p "Definition f_%s := {|@ " (extern_atom id); + fprintf p "Definition f_%s := {|@ " (sanitize (extern_atom id)); fprintf p " fn_return := %a;@ " typ f.fn_return; fprintf p " fn_callconv := %a;@ " callconv f.fn_callconv; fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params; @@ -402,7 +402,7 @@ let init_data p = function | Init_addrof(id,ofs) -> fprintf p "Init_addrof %a %a" ident id coqptrofs ofs let print_variable p (id, v) = - fprintf p "Definition v_%s := {|@ " (extern_atom id); + fprintf p "Definition v_%s := {|@ " (sanitize (extern_atom id)); fprintf p " gvar_info := %a;@ " typ v.gvar_info; fprintf p " gvar_init := %a;@ " (print_list init_data) v.gvar_init; fprintf p " gvar_readonly := %B;@ " v.gvar_readonly; @@ -417,12 +417,12 @@ let print_globdef p (id, gd) = let print_ident_globdef p = function | (id, Gfun(Ctypes.Internal f)) -> - fprintf p "(%a, Gfun(Internal f_%s))" ident id (extern_atom id) + fprintf p "(%a, Gfun(Internal f_%s))" ident id (sanitize (extern_atom id)) | (id, Gfun(Ctypes.External(ef, targs, tres, cc))) -> fprintf p "@[(%a,@ @[Gfun(External %a@ %a@ %a@ %a))@]@]" ident id external_function ef typlist targs typ tres callconv cc | (id, Gvar v) -> - fprintf p "(%a, Gvar v_%s)" ident id (extern_atom id) + fprintf p "(%a, Gvar v_%s)" ident id (sanitize (extern_atom id)) (* Composite definitions *) diff --git a/test/clightgen/issue319.c b/test/clightgen/issue319.c new file mode 100644 index 00000000..be9f3f7e --- /dev/null +++ b/test/clightgen/issue319.c @@ -0,0 +1,12 @@ +/* Dollar signs in identifiers */ + +int c$d = 42; + +int a$b(int x$$) { + return c$d + x$$; +} + +int main(int argc, const char *argv[]) +{ + return a$b(6); +} -- cgit From 1c1a4d86a22dd04fc92e61d4bd5c35e047c8b772 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 28 Oct 2019 16:22:53 +0100 Subject: Add support for Coq 8.10.1 --- configure | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure b/configure index bf4172f9..cb2747be 100755 --- a/configure +++ b/configure @@ -530,14 +530,14 @@ 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.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0) + 8.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" 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.10.0, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" + echo "Error: CompCert requires one of the following Coq versions: 8.10.1, 8.10.0, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" missingtools=true fi;; "") -- cgit From a0844a9b6eb88f9e75f7305e8d1505cf502fb81a Mon Sep 17 00:00:00 2001 From: Frédéric Besson Date: Wed, 30 Oct 2019 09:38:01 +0100 Subject: More robust proof of `size_and` (#320) The proposed proof only uses `zify` for closing the goal. This is needed for Coq PR #10982 which changes the inner working of `zify`. --- lib/Integers.v | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/Integers.v b/lib/Integers.v index 3b6c35eb..8990c78d 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -3322,10 +3322,11 @@ Proof. assert (0 <= Z.min (size a) (size b)). generalize (size_range a) (size_range b). zify; omega. apply bits_size_3. auto. intros. - rewrite bits_and. zify. subst z z0. destruct H1. - rewrite (bits_size_2 a). auto. omega. - rewrite (bits_size_2 b). apply andb_false_r. omega. - omega. + rewrite bits_and by omega. + rewrite andb_false_iff. + generalize (bits_size_2 a i). + generalize (bits_size_2 b i). + zify; intuition. Qed. Corollary and_interval: -- cgit From 029329c8adc955d9ebe9030074cce0df9dcfa5f7 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 31 Oct 2019 11:49:42 +0100 Subject: Raise minimal required versions for OCaml and Coq (#203) At least OCaml 4.05 is now required as well as Coq 8.8. --- configure | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/configure b/configure index cb2747be..8604a1d9 100755 --- a/configure +++ b/configure @@ -530,14 +530,14 @@ 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.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1) + 8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" 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.10.1, 8.10.0, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" + echo "Error: CompCert requires one of the following Coq versions: 8.10.1, 8.10.0, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0" missingtools=true fi;; "") @@ -549,15 +549,10 @@ esac echo "Testing OCaml... " | tr -d '\n' ocaml_ver=`ocamlopt -version 2>/dev/null` case "$ocaml_ver" in - 4.00.*|4.01.*) + 4.00.*|4.01.*| 4.02.*|4.03.*|4.04.*) echo "version $ocaml_ver -- UNSUPPORTED" - echo "Error: CompCert requires OCaml version 4.02 or later." + echo "Error: CompCert requires OCaml version 4.05 or later." missingtools=true;; - 4.02.*|4.03.*|4.04.*) - echo "version $ocaml_ver -- good!" - echo "WARNING: some Intel processors of the Skylake and Kaby Lake generations" - echo "have a hardware bug that can be triggered by this version of OCaml." - echo "To avoid this risk, it is recommended to use OCaml 4.05 or later.";; 4.0*) echo "version $ocaml_ver -- good!";; ?.*) -- cgit From 5b23665719a332db987f8f8b7c0e64667d0d521e Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 12 Nov 2019 14:56:04 +0000 Subject: Use `intuition idtac` instead of `intuition` (#321) A stronger `intuition` in the near future would break this use of `intuition`. --- lib/IntvSets.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/IntvSets.v b/lib/IntvSets.v index 78c20cc5..b97d9882 100644 --- a/lib/IntvSets.v +++ b/lib/IntvSets.v @@ -102,7 +102,7 @@ Proof. simpl. rewrite IHok. tauto. destruct (zlt h0 l). simpl. tauto. - rewrite IHok. intuition. + rewrite IHok. intuition idtac. assert (l0 <= x < h0 \/ l <= x < h) by xomega. tauto. left; xomega. left; xomega. -- cgit From 40360396c621603af3ea6fb9a2fc89fa7945c79a Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 12 Nov 2019 18:17:07 +0100 Subject: Remove no longer needed file PrintLTLin --- backend/PrintLTLin.ml | 115 -------------------------------------------------- 1 file changed, 115 deletions(-) delete mode 100644 backend/PrintLTLin.ml diff --git a/backend/PrintLTLin.ml b/backend/PrintLTLin.ml deleted file mode 100644 index 4e8efd16..00000000 --- a/backend/PrintLTLin.ml +++ /dev/null @@ -1,115 +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. *) -(* *) -(* *********************************************************************) - -(** Pretty-printer for LTLin code *) - -open Format -open Camlcoq -open Datatypes -open Maps -open AST -open Integers -open Locations -open Machregsaux -open LTLin -open PrintAST -open PrintOp - -let reg pp loc = - match loc with - | R r -> - begin match name_of_register r with - | Some s -> fprintf pp "%s" s - | None -> fprintf pp "" - end - | S (Local(ofs, ty)) -> - fprintf pp "local(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs) - | S (Incoming(ofs, ty)) -> - fprintf pp "incoming(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs) - | S (Outgoing(ofs, ty)) -> - fprintf pp "outgoing(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs) - -let rec regs pp = function - | [] -> () - | [r] -> reg pp r - | r1::rl -> fprintf pp "%a, %a" reg r1 regs rl - -let ros pp = function - | Coq_inl r -> reg pp r - | Coq_inr s -> fprintf pp "\"%s\"" (extern_atom s) - -let print_instruction pp i = - match i with - | Lop(op, args, res) -> - fprintf pp "%a = %a@ " - reg res (PrintOp.print_operation reg) (op, args) - | Lload(chunk, addr, args, dst) -> - fprintf pp "%a = %s[%a]@ " - reg dst (name_of_chunk chunk) - (PrintOp.print_addressing reg) (addr, args) - | Lstore(chunk, addr, args, src) -> - fprintf pp "%s[%a] = %a@ " - (name_of_chunk chunk) - (PrintOp.print_addressing reg) (addr, args) - reg src - | Lcall(sg, fn, args, res) -> - fprintf pp "%a = %a(%a)@ " - reg res ros fn regs args - | Ltailcall(sg, fn, args) -> - fprintf pp "tailcall %a(%a)@ " - ros fn regs args - | Lbuiltin(ef, args, res) -> - fprintf pp "%a = builtin %s(%a)@ " - reg res (name_of_external ef) regs args - | Llabel lbl -> - fprintf pp "%ld:@ " (P.to_int32 lbl) - | Lgoto lbl -> - fprintf pp "goto %ld@ " (P.to_int32 lbl) - | Lcond(cond, args, lbl) -> - fprintf pp "if (%a) goto %ld@ " - (PrintOp.print_condition reg) (cond, args) - (P.to_int32 lbl) - | Ljumptable(arg, tbl) -> - let tbl = Array.of_list tbl in - fprintf pp "@[jumptable (%a)" reg arg; - for i = 0 to Array.length tbl - 1 do - fprintf pp "@ case %d: goto %ld" i (P.to_int32 tbl.(i)) - done; - fprintf pp "@]@ " - | Lreturn None -> - fprintf pp "return@ " - | Lreturn (Some arg) -> - fprintf pp "return %a@ " reg arg - -let print_function pp id f = - fprintf pp "@[%s(%a) {@ " (extern_atom id) regs f.fn_params; - List.iter (print_instruction pp) f.fn_code; - fprintf pp "@;<0 -2>}@]@." - -let print_globdef pp (id, gd) = - match gd with - | Gfun(Internal f) -> print_function pp id f - | _ -> () - -let print_program pp prog = - List.iter (print_globdef pp) prog.prog_defs - -let destination : string option ref = ref None - -let print_if prog = - match !destination with - | None -> () - | Some f -> - let oc = open_out f in - let pp = formatter_of_out_channel oc in - print_program pp prog; - close_out oc -- cgit From 962c8f9935b257c1df6bddfc88ec41d4822f65c3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 13 Nov 2019 11:55:18 +0100 Subject: Removing clutter from building + running benches --- test/monniaux/Makefile | 10 +++++++--- test/monniaux/build_benches.sh | 7 ++++++- test/monniaux/clean_benches.sh | 6 +++++- test/monniaux/run_benches.sh | 5 +++-- 4 files changed, 21 insertions(+), 7 deletions(-) diff --git a/test/monniaux/Makefile b/test/monniaux/Makefile index a6b19891..d7437eea 100644 --- a/test/monniaux/Makefile +++ b/test/monniaux/Makefile @@ -20,9 +20,12 @@ oracle_times.txt: PostpassSchedulingOracle.patch bash build_benches.sh $@ measures.csv: - (cd ../../ && make -j20 && make install) - bash build_benches.sh - bash run_benches.sh $@ + @echo "Building compcert.." + @(cd ../../ && make -s -j20 && make -s install) + @echo "Building benches..." + @bash build_benches.sh + @echo "Benches built. Running benches..." + @bash run_benches.sh $@ #compile_times.pdf: gencompile.py verifier_times.txt oracle_times.txt # python3.5 $^ $@ @@ -32,4 +35,5 @@ measures.csv: .PHONY: clean: + @bash clean_benches.sh rm -f verifier_times.txt oracle_times.txt compile_times.pdf measure_times.k1c.pdf measures.csv diff --git a/test/monniaux/build_benches.sh b/test/monniaux/build_benches.sh index 931cebac..a749779d 100755 --- a/test/monniaux/build_benches.sh +++ b/test/monniaux/build_benches.sh @@ -4,11 +4,16 @@ TMPFILE=/tmp/1513times.txt source benches.sh +default="\e[39m" +magenta="\e[35m" +red="\e[31m" + rm -f commands.txt rm -f $TMPFILE for bench in $benches; do + echo -e "${magenta}Building $bench..${default}" if [ "$1" == "" ]; then - (cd $bench && make -j20) + (cd $bench && make -s -j20 > /dev/null &> /dev/null) || { echo -e "${red}Build failed" && break; } else (cd $bench && make -j20) | grep -P "\d+: \d+\.\d+" >> $TMPFILE fi diff --git a/test/monniaux/clean_benches.sh b/test/monniaux/clean_benches.sh index c0a87ff9..dff15fd4 100755 --- a/test/monniaux/clean_benches.sh +++ b/test/monniaux/clean_benches.sh @@ -1,8 +1,12 @@ source benches.sh +blue="\e[34m" +default="\e[39m" + rm -f commands.txt for bench in $benches; do - (cd $bench && make clean) + echo -e "${blue}Cleaning $bench..${default}" + (cd $bench && make -s clean) done rm -f *.o diff --git a/test/monniaux/run_benches.sh b/test/monniaux/run_benches.sh index 5f9f22cb..60eec865 100755 --- a/test/monniaux/run_benches.sh +++ b/test/monniaux/run_benches.sh @@ -3,10 +3,11 @@ source benches.sh rm -f commands.txt for bench in $benches; do - echo "(cd $bench && make -j5 run)" >> commands.txt + echo "(cd $bench && echo \"Running $bench..\" &&\ + make -j4 run > /dev/null && echo \"$bench DONE\")" >> commands.txt done -cat commands.txt | xargs -n1 -I{} -P4 bash -c '{}' +cat commands.txt | xargs -n1 -I{} -P6 bash -c '{}' ## # Gather all the CSV files -- cgit From 847554275608bafcbfad635684e588501e00ac31 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 13 Nov 2019 11:55:57 +0100 Subject: Putting back the building rules for the paper (rules.mk) --- test/monniaux/rules.mk | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index 079606e6..9d4f5278 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -31,27 +31,27 @@ K1C_CCOMP?=ccomp EXECUTE_CYCLES?=k1-cluster --syscall=libstd_scalls.so --cycle-based -- # You can define up to GCC4FLAGS and CCOMP4FLAGS -GCC0FLAGS?= -GCC1FLAGS?=$(ALL_GCCFLAGS) -O1 -g +GCC0FLAGS?=$(ALL_GCCFLAGS) -O0 +GCC1FLAGS?=$(ALL_GCCFLAGS) -O1 GCC2FLAGS?=$(ALL_GCCFLAGS) -O2 GCC3FLAGS?=$(ALL_GCCFLAGS) -O3 GCC4FLAGS?= -CCOMP0FLAGS?= -CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -O1 -g -CCOMP2FLAGS?=$(ALL_CCOMPFLAGS) -CCOMP3FLAGS?= +CCOMP0FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fno-postpass +CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fpostpass= greedy +CCOMP2FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fno-if-conversion +CCOMP3FLAGS?=$(ALL_CCOMPFLAGS) -O2 CCOMP4FLAGS?= # Prefix names -GCC0PREFIX?= +GCC0PREFIX?=.gcc.o0 GCC1PREFIX?=.gcc.o1 GCC2PREFIX?=.gcc.o2 GCC3PREFIX?=.gcc.o3 GCC4PREFIX?= -CCOMP0PREFIX?= -CCOMP1PREFIX?=.ccomp.o1 -CCOMP2PREFIX?=.ccomp.o2 -CCOMP3PREFIX?= +CCOMP0PREFIX?=.ccomp.nobundle +CCOMP1PREFIX?=.ccomp.greedy +CCOMP2PREFIX?=.ccomp.noif +CCOMP3PREFIX?=.ccomp CCOMP4PREFIX?= # List of outfiles, updated by gen_rules -- cgit From 0bfebb652a4e4cb1348e7d6c8f100254ed035c76 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 13 Nov 2019 15:28:58 +0100 Subject: Correcting typo in rules.mk --- test/monniaux/rules.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index 9d4f5278..c91e9d1f 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -135,7 +135,7 @@ endif measures.csv: $(OUTFILES) @echo $(FIRSTLINE) > $@ - @for i in $(MEASURES); do\ + @for i in "$(MEASURES)"; do\ first=$$(grep "$$i cycles" $(firstword $(OUTFILES)));\ if test ! -z "$$first"; then\ if [ "$$i" != "time" ]; then\ -- cgit From 8d1b23070baa3c2db69a066dfc097e08bb811eb3 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Nov 2019 15:35:47 +0100 Subject: removing Focus (deprecated) --- mppa_k1c/lib/Machblockgenproof.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index ab7fff74..8da610ad 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -719,13 +719,13 @@ Proof. exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - Focus 10. exists (add_to_new_bblock (MB_basic bi)::nil). exists b. + 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. rewrite Heqti. eapply Tr_end_block; eauto. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. + simpl in H5; congruence. } all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From 4c471a5a7852d02c368101205b34418c0f754b91 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Nov 2019 16:04:03 +0100 Subject: fixing a potential inconsistency from unsafe_coerce Now, unsafe_coerce axioms are clearly consistent (for any interpretation of may-return monads). But, the extraction is still unsafe... --- mppa_k1c/Asmblockdeps.v | 10 ++++++++-- mppa_k1c/abstractbb/Impure/ImpConfig.v | 10 +++++----- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c4c1bbf1..8bc1112f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1636,11 +1636,17 @@ Hint Resolve bblock_simu_test_correct: wlp. Import UnsafeImpure. -Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2). +Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := + match unsafe_coerce (bblock_simu_test verb p1 p2) with + | Some b => b + | None => false + end. Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. - intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto. + unfold pure_bblock_simu_test. + destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. + intros; subst. eapply bblock_simu_test_correct; eauto. apply unsafe_coerce_not_really_correct; eauto. Qed. diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v index 1bd93d4c..e49a4611 100644 --- a/mppa_k1c/abstractbb/Impure/ImpConfig.v +++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v @@ -22,9 +22,9 @@ Module Type ImpureView. (* START COMMENT *) Module UnsafeImpure. - Parameter unsafe_coerce: forall {A}, t A -> A. + Parameter unsafe_coerce: forall {A}, t A -> option A. - Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=x -> mayRet k x. + Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=Some x -> mayRet k x. Extraction Inline unsafe_coerce. @@ -41,11 +41,11 @@ Module Impure: ImpureView. Module UnsafeImpure. - Definition unsafe_coerce {A} (x:t A) := x. + Definition unsafe_coerce {A} (x:t A) := Some x. - Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=x -> mayRet k x. + Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=Some x -> mayRet k x. Proof. - unfold unsafe_coerce, mayRet; auto. + unfold unsafe_coerce, mayRet; congruence. Qed. End UnsafeImpure. -- cgit From 58502dffb43171ef2e37f8e256481de8d1071ede Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Nov 2019 17:10:07 +0100 Subject: simplification of Duplicate: remove xfunction --- backend/Duplicate.v | 105 +++++++-------------- backend/Duplicateproof.v | 236 ++++++++++++++++++++++++----------------------- 2 files changed, 154 insertions(+), 187 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index a591d6e5..3ad37c83 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -13,49 +13,28 @@ Axiom duplicate_aux: function -> code * node * (PTree.t node). Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux". -Record xfunction : Type := - { fn_RTL: function; - fn_revmap: PTree.t node; - }. - -Definition xfundef := AST.fundef xfunction. -Definition xprogram := AST.program xfundef unit. -Definition xgenv := Genv.t xfundef unit. - -Definition fundef_RTL (fu: xfundef) : fundef := - match fu with - | Internal f => Internal (fn_RTL f) - | External ef => External ef - end. - (** * Verification of node duplications *) -Definition verify_mapping_entrypoint (f: function) (xf: xfunction) : res unit := - match ((fn_revmap xf)!(fn_entrypoint (fn_RTL xf))) with - | None => Error (msg "verify_mapping: No node in xf revmap for entrypoint") - | Some n => match (Pos.compare n (fn_entrypoint f)) with - | Eq => OK tt - | _ => Error (msg "verify_mapping_entrypoint: xf revmap for entrypoint does not correspond to the entrypoint of f") - end - end. - -Definition verify_is_copy revmap n n' := - match revmap!n' with +Definition verify_is_copy dupmap n n' := + match dupmap!n' with | None => Error(msg "verify_is_copy None") | Some revn => match (Pos.compare n revn) with Eq => OK tt | _ => Error(msg "verify_is_copy invalid map") end end. -Fixpoint verify_is_copy_list revmap ln ln' := +Fixpoint verify_is_copy_list dupmap ln ln' := match ln with | n::ln => match ln' with - | n'::ln' => do u <- verify_is_copy revmap n n'; - verify_is_copy_list revmap ln ln' + | n'::ln' => do u <- verify_is_copy dupmap n n'; + verify_is_copy_list dupmap ln ln' | nil => Error (msg "verify_is_copy_list: ln' bigger than ln") end | nil => match ln' with | n :: ln' => Error (msg "verify_is_copy_list: ln bigger than ln'") | nil => OK tt end end. +Definition verify_mapping_entrypoint dupmap (f f': function): res unit := + verify_is_copy dupmap (fn_entrypoint f) (fn_entrypoint f'). + Lemma product_eq {A B: Type} : (forall (a b: A), {a=b} + {a<>b}) -> (forall (c d: B), {c=d} + {c<>d}) -> @@ -77,13 +56,13 @@ Remark builtin_res_eq_pos: forall (a b: builtin_res positive), {a=b} + {a<>b}. Proof. intros. apply (builtin_res_eq Pos.eq_dec). Qed. Global Opaque builtin_res_eq_pos. -Definition verify_match_inst revmap inst tinst := +Definition verify_match_inst dupmap inst tinst := match inst with - | Inop n => match tinst with Inop n' => do u <- verify_is_copy revmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end + | Inop n => match tinst with Inop n' => do u <- verify_is_copy dupmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end | Iop op lr r n => match tinst with Iop op' lr' r' n' => - do u <- verify_is_copy revmap n n'; + do u <- verify_is_copy dupmap n n'; if (eq_operation op op') then if (list_eq_dec Pos.eq_dec lr lr') then if (Pos.eq_dec r r') then @@ -95,7 +74,7 @@ Definition verify_match_inst revmap inst tinst := | Iload m a lr r n => match tinst with | Iload m' a' lr' r' n' => - do u <- verify_is_copy revmap n n'; + do u <- verify_is_copy dupmap n n'; if (chunk_eq m m') then if (eq_addressing a a') then if (list_eq_dec Pos.eq_dec lr lr') then @@ -108,7 +87,7 @@ Definition verify_match_inst revmap inst tinst := | Istore m a lr r n => match tinst with | Istore m' a' lr' r' n' => - do u <- verify_is_copy revmap n n'; + do u <- verify_is_copy dupmap n n'; if (chunk_eq m m') then if (eq_addressing a a') then if (list_eq_dec Pos.eq_dec lr lr') then @@ -121,7 +100,7 @@ Definition verify_match_inst revmap inst tinst := | Icall s ri lr r n => match tinst with | Icall s' ri' lr' r' n' => - do u <- verify_is_copy revmap n n'; + do u <- verify_is_copy dupmap n n'; if (signature_eq s s') then if (product_eq Pos.eq_dec ident_eq ri ri') then if (list_eq_dec Pos.eq_dec lr lr') then @@ -144,7 +123,7 @@ Definition verify_match_inst revmap inst tinst := | Ibuiltin ef lbar brr n => match tinst with | Ibuiltin ef' lbar' brr' n' => - do u <- verify_is_copy revmap n n'; + do u <- verify_is_copy dupmap n n'; if (external_function_eq ef ef') then if (list_eq_dec builtin_arg_eq_pos lbar lbar') then if (builtin_res_eq_pos brr brr') then OK tt @@ -155,8 +134,8 @@ Definition verify_match_inst revmap inst tinst := | Icond cond lr n1 n2 => match tinst with | Icond cond' lr' n1' n2' => - do u1 <- verify_is_copy revmap n1 n1'; - do u2 <- verify_is_copy revmap n2 n2'; + do u1 <- verify_is_copy dupmap n1 n1'; + do u2 <- verify_is_copy dupmap n2 n2'; if (eq_condition cond cond') then if (list_eq_dec Pos.eq_dec lr lr') then OK tt else Error (msg "Different lr in Icond") @@ -165,7 +144,7 @@ Definition verify_match_inst revmap inst tinst := | Ijumptable r ln => match tinst with | Ijumptable r' ln' => - do u <- verify_is_copy_list revmap ln ln'; + do u <- verify_is_copy_list dupmap ln ln'; if (Pos.eq_dec r r') then OK tt else Error (msg "Different r in Ijumptable") | _ => Error (msg "verify_match_inst Ijumptable") end @@ -177,54 +156,40 @@ Definition verify_match_inst revmap inst tinst := | _ => Error (msg "verify_match_inst Ireturn") end end. -Definition verify_mapping_mn f xf (m: positive*positive) := +Definition verify_mapping_mn dupmap f f' (m: positive*positive) := let (tn, n) := m in match (fn_code f)!n with | None => Error (msg "verify_mapping_mn: Could not get an instruction at (fn_code f)!n") - | Some inst => match (fn_code (fn_RTL xf))!tn with + | Some inst => match (fn_code f')!tn with | None => Error (msg "verify_mapping_mn: Could not get an instruction at (fn_code xf)!tn") - | Some tinst => verify_match_inst (fn_revmap xf) inst tinst + | Some tinst => verify_match_inst dupmap inst tinst end end. -Fixpoint verify_mapping_mn_rec f xf lm := +Fixpoint verify_mapping_mn_rec dupmap f f' lm := match lm with | nil => OK tt - | m :: lm => do u <- verify_mapping_mn f xf m; - do u2 <- verify_mapping_mn_rec f xf lm; + | m :: lm => do u <- verify_mapping_mn dupmap f f' m; + do u2 <- verify_mapping_mn_rec dupmap f f' lm; OK tt end. -Definition verify_mapping_match_nodes (f: function) (xf: xfunction) : res unit := - verify_mapping_mn_rec f xf (PTree.elements (fn_revmap xf)). +Definition verify_mapping_match_nodes dupmap (f f': function): res unit := + verify_mapping_mn_rec dupmap f f' (PTree.elements dupmap). -(** Verifies that the [fn_revmap] of the translated function [xf] is giving correct information in regards to [f] *) -Definition verify_mapping (f: function) (xf: xfunction) : res unit := - do u <- verify_mapping_entrypoint f xf; - do v <- verify_mapping_match_nodes f xf; OK tt. -(* TODO - verify the other axiom *) +(** Verifies that the [dupmap] of the translated function [f'] is giving correct information in regards to [f] *) +Definition verify_mapping dupmap (f f': function) : res unit := + do u <- verify_mapping_entrypoint dupmap f f'; + do v <- verify_mapping_match_nodes dupmap f f'; OK tt. (** * Entry points *) -Definition transf_function_aux (f: function) : res xfunction := - let (tcte, mp) := duplicate_aux f in - let (tc, te) := tcte in - let xf := {| fn_RTL := (mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te); fn_revmap := mp |} in - do u <- verify_mapping f xf; - OK xf. - -Theorem transf_function_aux_preserves: - forall f xf, - transf_function_aux f = OK xf -> - fn_sig f = fn_sig (fn_RTL xf) /\ fn_params f = fn_params (fn_RTL xf) /\ fn_stacksize f = fn_stacksize (fn_RTL xf). -Proof. - intros. unfold transf_function_aux in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. - repeat (split; try reflexivity). -Qed. - Definition transf_function (f: function) : res function := - do xf <- transf_function_aux f; - OK (fn_RTL xf). + let (tcte, dupmap) := duplicate_aux f in + let (tc, te) := tcte in + let f' := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in + do u <- verify_mapping dupmap f f'; + OK f'. Definition transf_fundef (f: fundef) : res fundef := transf_partial_fundef transf_function f. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 04936eeb..9d56e86f 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -7,58 +7,57 @@ Local Open Scope positive_scope. (** * Definition of [match_states] (independently of the translation) *) -(* est-ce plus simple de prendre is_copy: node -> node, avec un noeud hors CFG à la place de None ? *) -Inductive match_inst (is_copy: node -> option node): instruction -> instruction -> Prop := +(* est-ce plus simple de prendre dupmap: node -> node, avec un noeud hors CFG à la place de None ? *) +Inductive match_inst (dupmap: PTree.t node): instruction -> instruction -> Prop := | match_inst_nop: forall n n', - is_copy n' = (Some n) -> match_inst is_copy (Inop n) (Inop n') + dupmap!n' = (Some n) -> match_inst dupmap (Inop n) (Inop n') | match_inst_op: forall n n' op lr r, - is_copy n' = (Some n) -> match_inst is_copy (Iop op lr r n) (Iop op lr r n') + dupmap!n' = (Some n) -> match_inst dupmap (Iop op lr r n) (Iop op lr r n') | match_inst_load: forall n n' m a lr r, - is_copy n' = (Some n) -> match_inst is_copy (Iload m a lr r n) (Iload m a lr r n') + dupmap!n' = (Some n) -> match_inst dupmap (Iload m a lr r n) (Iload m a lr r n') | match_inst_store: forall n n' m a lr r, - is_copy n' = (Some n) -> match_inst is_copy (Istore m a lr r n) (Istore m a lr r n') + dupmap!n' = (Some n) -> match_inst dupmap (Istore m a lr r n) (Istore m a lr r n') | match_inst_call: forall n n' s ri lr r, - is_copy n' = (Some n) -> match_inst is_copy (Icall s ri lr r n) (Icall s ri lr r n') + dupmap!n' = (Some n) -> match_inst dupmap (Icall s ri lr r n) (Icall s ri lr r n') | match_inst_tailcall: forall s ri lr, - match_inst is_copy (Itailcall s ri lr) (Itailcall s ri lr) + match_inst dupmap (Itailcall s ri lr) (Itailcall s ri lr) | match_inst_builtin: forall n n' ef la br, - is_copy n' = (Some n) -> match_inst is_copy (Ibuiltin ef la br n) (Ibuiltin ef la br n') + dupmap!n' = (Some n) -> match_inst dupmap (Ibuiltin ef la br n) (Ibuiltin ef la br n') | match_inst_cond: forall ifso ifso' ifnot ifnot' c lr, - is_copy ifso' = (Some ifso) -> is_copy ifnot' = (Some ifnot) -> - match_inst is_copy (Icond c lr ifso ifnot) (Icond c lr ifso' ifnot') + dupmap!ifso' = (Some ifso) -> dupmap!ifnot' = (Some ifnot) -> + match_inst dupmap (Icond c lr ifso ifnot) (Icond c lr ifso' ifnot') | match_inst_jumptable: forall ln ln' r, - list_forall2 (fun n n' => (is_copy n' = (Some n))) ln ln' -> - match_inst is_copy (Ijumptable r ln) (Ijumptable r ln') - | match_inst_return: forall or, match_inst is_copy (Ireturn or) (Ireturn or). - -Record match_function f xf: Prop := { - revmap_correct: forall n n', (fn_revmap xf)!n' = Some n -> - (forall i, (fn_code f)!n = Some i -> exists i', (fn_code (fn_RTL xf))!n' = Some i' /\ match_inst (fun n' => (fn_revmap xf)!n') i i'); - revmap_entrypoint: (fn_revmap xf)!(fn_entrypoint (fn_RTL xf)) = Some (fn_entrypoint f); - preserv_fnsig: fn_sig f = fn_sig (fn_RTL xf); - preserv_fnparams: fn_params f = fn_params (fn_RTL xf); - preserv_fnstacksize: fn_stacksize f = fn_stacksize (fn_RTL xf) + list_forall2 (fun n n' => (dupmap!n' = (Some n))) ln ln' -> + match_inst dupmap (Ijumptable r ln) (Ijumptable r ln') + | match_inst_return: forall or, match_inst dupmap (Ireturn or) (Ireturn or). + +Record match_function dupmap f f': Prop := { + dupmap_correct: forall n n', dupmap!n' = Some n -> + (forall i, (fn_code f)!n = Some i -> exists i', (fn_code f')!n' = Some i' /\ match_inst dupmap i i'); + dupmap_entrypoint: dupmap!(fn_entrypoint f') = Some (fn_entrypoint f); + preserv_fnsig: fn_sig f = fn_sig f'; + preserv_fnparams: fn_params f = fn_params f'; + preserv_fnstacksize: fn_stacksize f = fn_stacksize f' }. Inductive match_fundef: RTL.fundef -> RTL.fundef -> Prop := - | match_Internal f xf: match_function f xf -> match_fundef (Internal f) (Internal (fn_RTL xf)) + | match_Internal dupmap f f': match_function dupmap f f' -> match_fundef (Internal f) (Internal f') | match_External ef: match_fundef (External ef) (External ef). - Inductive match_stackframes: stackframe -> stackframe -> Prop := - | match_stackframe_intro: - forall res f sp pc rs xf pc' - (TRANSF: match_function f xf) - (DUPLIC: (fn_revmap xf)!pc' = Some pc), - match_stackframes (Stackframe res f sp pc rs) (Stackframe res (fn_RTL xf) sp pc' rs). + | match_stackframe_intro + dupmap res f sp pc rs f' pc' + (TRANSF: match_function dupmap f f') + (DUPLIC: dupmap!pc' = Some pc): + match_stackframes (Stackframe res f sp pc rs) (Stackframe res f' sp pc' rs). Inductive match_states: state -> state -> Prop := - | match_states_intro: - forall st f sp pc rs m st' xf pc' + | match_states_intro + dupmap st f sp pc rs m st' f' pc' (STACKS: list_forall2 match_stackframes st st') - (TRANSF: match_function f xf) - (DUPLIC: (fn_revmap xf)!pc' = Some pc), - match_states (State st f sp pc rs m) (State st' (fn_RTL xf) sp pc' rs m) + (TRANSF: match_function dupmap f f') + (DUPLIC: dupmap!pc' = Some pc): + match_states (State st f sp pc rs m) (State st' f' sp pc' rs m) | match_states_call: forall st st' f f' args m (STACKS: list_forall2 match_stackframes st st') @@ -71,11 +70,22 @@ Inductive match_states: state -> state -> Prop := (** * Auxiliary properties *) + +Theorem transf_function_preserves: + forall f f', + transf_function f = OK f' -> + fn_sig f = fn_sig f' /\ fn_params f = fn_params f' /\ fn_stacksize f = fn_stacksize f'. +Proof. + intros. unfold transf_function in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. + repeat (split; try reflexivity). +Qed. + + Lemma verify_mapping_mn_rec_step: - forall lb b f xf, + forall dupmap lb b f f', In b lb -> - verify_mapping_mn_rec f xf lb = OK tt -> - verify_mapping_mn f xf b = OK tt. + verify_mapping_mn_rec dupmap f f' lb = OK tt -> + verify_mapping_mn dupmap f f' b = OK tt. Proof. induction lb; intros. - monadInv H0. inversion H. @@ -85,20 +95,20 @@ Proof. Qed. Lemma verify_is_copy_correct: - forall xf n n', - verify_is_copy (fn_revmap xf) n n' = OK tt -> - (fn_revmap xf) ! n' = Some n. + forall dupmap n n', + verify_is_copy dupmap n n' = OK tt -> + dupmap ! n' = Some n. Proof. intros. unfold verify_is_copy in H. destruct (_ ! n') eqn:REVM; [|inversion H]. - destruct (n ?= n0) eqn:NP; try (inversion H; fail). + destruct (n ?= p) eqn:NP; try (inversion H; fail). eapply Pos.compare_eq in NP. subst. reflexivity. Qed. Lemma verify_is_copy_list_correct: - forall xf ln ln', - verify_is_copy_list (fn_revmap xf) ln ln' = OK tt -> - list_forall2 (fun n n' => (fn_revmap xf) ! n' = Some n) ln ln'. + forall dupmap ln ln', + verify_is_copy_list dupmap ln ln' = OK tt -> + list_forall2 (fun n n' => dupmap ! n' = Some n) ln ln'. Proof. induction ln. - intros. destruct ln'; monadInv H. constructor. @@ -107,9 +117,9 @@ Proof. Qed. Lemma verify_match_inst_correct: - forall xf i i', - verify_match_inst (fn_revmap xf) i i' = OK tt -> - match_inst (fun nn => (fn_revmap xf) ! nn) i i'. + forall dupmap i i', + verify_match_inst dupmap i i' = OK tt -> + match_inst dupmap i i'. Proof. intros. unfold verify_match_inst in H. destruct i; try (inversion H; fail). @@ -180,64 +190,64 @@ Proof. Qed. -Lemma verify_mapping_mn_correct: - forall mp n n' i f xf tc, +Lemma verify_mapping_mn_correct mp n n' i f f' tc: mp ! n' = Some n -> (fn_code f) ! n = Some i -> - (fn_code (fn_RTL xf)) = tc -> - fn_revmap xf = mp -> - verify_mapping_mn f xf (n', n) = OK tt -> + (fn_code f') = tc -> + verify_mapping_mn mp f f' (n', n) = OK tt -> exists i', tc ! n' = Some i' - /\ match_inst (fun nn => mp ! nn) i i'. + /\ match_inst mp i i'. Proof. - intros. unfold verify_mapping_mn in H3. rewrite H0 in H3. clear H0. rewrite H1 in H3. clear H1. - destruct (tc ! n') eqn:TCN; [| inversion H3]. - exists i0. split; auto. rewrite <- H2. + unfold verify_mapping_mn; intros H H0 H1 H2. rewrite H0 in H2. clear H0. rewrite H1 in H2. clear H1. + destruct (tc ! n') eqn:TCN; [| inversion H2]. + exists i0. split; auto. eapply verify_match_inst_correct. assumption. Qed. Lemma verify_mapping_mn_rec_correct: - forall mp n n' i f xf tc, + forall mp n n' i f f' tc, mp ! n' = Some n -> (fn_code f) ! n = Some i -> - (fn_code (fn_RTL xf)) = tc -> - fn_revmap xf = mp -> - verify_mapping_mn_rec f xf (PTree.elements mp) = OK tt -> + (fn_code f') = tc -> + verify_mapping_mn_rec mp f f' (PTree.elements mp) = OK tt -> exists i', tc ! n' = Some i' - /\ match_inst (fun nn => mp ! nn) i i'. + /\ match_inst mp i i'. Proof. intros. exploit PTree.elements_correct. eapply H. intros IN. - eapply verify_mapping_mn_rec_step in H3; eauto. + eapply verify_mapping_mn_rec_step in H2; eauto. eapply verify_mapping_mn_correct; eauto. Qed. -Theorem transf_function_correct f xf: - transf_function_aux f = OK xf -> match_function f xf. +Theorem transf_function_correct f f': + transf_function f = OK f' -> exists dupmap, match_function dupmap f f'. Proof. - intros TRANSF ; constructor 1; try (apply transf_function_aux_preserves; auto). + unfold transf_function. + intros TRANSF. + destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). + monadInv TRANSF. + unfold verify_mapping in EQ. monadInv EQ. + exists mp; constructor 1; simpl; auto. + (* correct *) intros until n'. intros REVM i FNC. - unfold transf_function_aux in TRANSF. destruct (duplicate_aux f) as (tcte & mp). destruct tcte as (tc & te). monadInv TRANSF. - simpl in *. monadInv EQ. clear EQ0. unfold verify_mapping_match_nodes in EQ. simpl in EQ. destruct x1. - eapply verify_mapping_mn_rec_correct. 5: eapply EQ. all: eauto. + eapply verify_mapping_mn_rec_correct; eauto. + simpl; eauto. + (* entrypoint *) - intros. unfold transf_function_aux in TRANSF. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). - monadInv TRANSF. simpl. monadInv EQ. unfold verify_mapping_entrypoint in EQ0. simpl in EQ0. - destruct (mp ! te) eqn:PT; try discriminate. - destruct (n ?= fn_entrypoint f) eqn:EQQ; try discriminate. inv EQ0. - apply Pos.compare_eq in EQQ. congruence. + intros. unfold verify_mapping_entrypoint in EQ0. simpl in EQ0. + eapply verify_is_copy_correct; eauto. + destruct x0; auto. Qed. Lemma transf_fundef_correct f f': transf_fundef f = OK f' -> match_fundef f f'. Proof. intros TRANSF; destruct f; simpl; monadInv TRANSF. - + monadInv EQ. - eapply match_Internal; eapply transf_function_correct; eauto. + + exploit transf_function_correct; eauto. + intros (dupmap & MATCH_F). + eapply match_Internal; eauto. + eapply match_External. Qed. @@ -267,10 +277,12 @@ Proof. rewrite <- (Genv.find_symbol_match TRANSL). reflexivity. Qed. +(* UNUSED LEMMA ? Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. Proof. unfold Senv.equiv. intuition congruence. Qed. +*) Lemma senv_preserved: Senv.equiv ge tge. @@ -304,27 +316,17 @@ Lemma function_sig_translated: forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f. Proof. intros. destruct f. - - simpl in H. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_aux_preserves. assumption. - - simpl in H. monadInv H. (* monadInv EQ. *) reflexivity. + - simpl in H. monadInv H. simpl. symmetry. apply transf_function_preserves. assumption. + - simpl in H. monadInv H. reflexivity. Qed. -Lemma sig_preserved: - forall f tf, - transf_fundef f = OK tf -> - funsig tf = funsig f. -Proof. - unfold transf_fundef, transf_partial_fundef; intros. - destruct f. monadInv H. simpl. symmetry. monadInv EQ. apply transf_function_aux_preserves. assumption. - inv H. reflexivity. -Qed. - -Lemma list_nth_z_revmap: - forall ln f ln' (pc pc': node) val, +Lemma list_nth_z_dupmap: + forall dupmap ln ln' (pc pc': node) val, list_nth_z ln val = Some pc -> - list_forall2 (fun n n' => (fn_revmap f)!n' = Some n) ln ln' -> + list_forall2 (fun n n' => dupmap!n' = Some n) ln ln' -> exists pc', list_nth_z ln' val = Some pc' - /\ (fn_revmap f)!pc' = Some pc. + /\ dupmap!pc' = Some pc. Proof. induction ln; intros until val; intros LNZ LFA. - inv LNZ. @@ -348,8 +350,8 @@ Proof. symmetry. eapply match_program_main. eauto. + exploit function_ptr_translated; eauto. + destruct f. - * monadInv TRANSF. monadInv EQ. rewrite <- H3. symmetry; eapply transf_function_aux_preserves. assumption. - * monadInv TRANSF. (* monadInv EQ. *) assumption. + * monadInv TRANSF. rewrite <- H3. symmetry; eapply transf_function_preserves. assumption. + * monadInv TRANSF. assumption. - constructor; eauto. constructor. apply transf_fundef_correct; auto. Qed. @@ -370,35 +372,35 @@ Proof. Local Hint Resolve transf_fundef_correct. induction 1; intros; inv MS. (* Inop *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. eexists. split. + eapply exec_Inop; eauto. - + constructor; eauto. + + econstructor; eauto. (* Iop *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. + eapply exec_Iop; eauto. erewrite eval_operation_preserved; eauto. - + constructor; eauto. + + econstructor; eauto. (* Iload *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. + eapply exec_Iload; eauto. erewrite eval_addressing_preserved; eauto. - + constructor; auto. + + econstructor; eauto. (* Istore *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. + eapply exec_Istore; eauto. erewrite eval_addressing_preserved; eauto. - + constructor; auto. + + econstructor; eauto. (* Icall *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. destruct ros. @@ -407,15 +409,15 @@ Proof. eexists. split. + eapply exec_Icall. eassumption. simpl. eassumption. apply function_sig_translated. assumption. - + repeat (constructor; auto). + + repeat (econstructor; eauto). * simpl in H0. destruct (Genv.find_symbol _ _) eqn:GFS; try discriminate. apply function_ptr_translated in H0. destruct H0 as (tf & GFF & TF). eexists. split. + eapply exec_Icall. eassumption. simpl. rewrite symbols_preserved. rewrite GFS. eassumption. apply function_sig_translated. assumption. - + repeat (constructor; auto). + + repeat (econstructor; eauto). (* Itailcall *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H10 & H11). inv H11. pose symbols_preserved as SYMPRES. destruct ros. @@ -434,40 +436,40 @@ Proof. erewrite <- preserv_fnstacksize; eauto. + repeat (constructor; auto). (* Ibuiltin *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. + eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved; eauto. eapply external_call_symbols_preserved; eauto. eapply senv_preserved. - + constructor; auto. + + econstructor; eauto. (* Icond *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. + eapply exec_Icond; eauto. - + constructor; auto. destruct b; auto. + + econstructor; eauto. destruct b; auto. (* Ijumptable *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. - exploit list_nth_z_revmap; eauto. intros (pc'1 & LNZ & REVM). + exploit list_nth_z_dupmap; eauto. intros (pc'1 & LNZ & REVM). eexists. split. + eapply exec_Ijumptable; eauto. - + constructor; auto. + + econstructor; eauto. (* Ireturn *) - - eapply revmap_correct in DUPLIC; eauto. + - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. + eapply exec_Ireturn; eauto. erewrite <- preserv_fnstacksize; eauto. - + constructor; auto. + + econstructor; eauto. (* exec_function_internal *) - - inversion TRANSF as [f0 xf MATCHF|]; subst. eexists. split. + - inversion TRANSF as [dupmap f0 f0' MATCHF|]; subst. eexists. split. + eapply exec_function_internal. erewrite <- preserv_fnstacksize; eauto. + erewrite preserv_fnparams; eauto. - econstructor; eauto. apply revmap_entrypoint. assumption. + econstructor; eauto. apply dupmap_entrypoint. assumption. (* exec_function_external *) - inversion TRANSF as [|]; subst. eexists. split. + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. @@ -475,7 +477,7 @@ Proof. (* exec_return *) - inv STACKS. destruct b1 as [res' f' sp' pc' rs']. eexists. split. + constructor. - + inv H1. constructor; assumption. + + inv H1. econstructor; eauto. Qed. Theorem transf_program_correct: -- cgit From 009d577cc3f590d525146a1afb87aa8e6d6a4b59 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 14 Nov 2019 23:03:30 +0100 Subject: merge merge merge --- backend/Lineartyping.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index d0971dbd..0e3b7c8e 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -325,7 +325,7 @@ Local Opaque mreg_type. change ty_res with (snd (ty_args, ty_res)). rewrite <- TYOP. eapply type_of_operation_sound; eauto. red; intros; subst op. simpl in ISMOVE. destruct args; try discriminate. destruct args; discriminate. - (* apply wt_undef_regs; auto. *) + apply wt_undef_regs; auto. - (* load *) simpl in *; InvBooleans. econstructor; eauto. -- cgit From 6250c0b916987bd48ed4d80be45083235665caca Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 15 Nov 2019 13:59:22 +0100 Subject: Adding jpeg-6b benchmark --- test/monniaux/jpeg-6b/Makefile | 79 +++++++++++++++++++++++++----------------- test/monniaux/rules.mk | 3 +- 2 files changed, 50 insertions(+), 32 deletions(-) diff --git a/test/monniaux/jpeg-6b/Makefile b/test/monniaux/jpeg-6b/Makefile index 5a45b729..2bec9bb7 100644 --- a/test/monniaux/jpeg-6b/Makefile +++ b/test/monniaux/jpeg-6b/Makefile @@ -1,6 +1,6 @@ -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 +TARGET=jpeg-6b -LIBSOURCES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \ +ALL_CFILES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \ jcinit.c jcmainct.c jcmarker.c jcmaster.c jcomapi.c jcparam.c \ jcphuff.c jcprepct.c jcsample.c jctrans.c jdapimin.c jdapistd.c \ jdatadst.c jdatasrc.c jdcoefct.c jdcolor.c jddctmgr.c jdhuff.c \ @@ -8,36 +8,53 @@ LIBSOURCES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \ jdpostct.c jdsample.c jdtrans.c jerror.c jfdctflt.c jfdctfst.c \ jfdctint.c jidctflt.c jidctfst.c jidctint.c jidctred.c jquant1.c \ 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 +ALL_CFILES+=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 +ALL_CFILES+=cjpeg.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) +EXECUTE_ARGS=-dct int -outfile __BASE__.jpg testimg.ppm 2> __BASE__.out 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.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.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 - - -djpeg.%.out: djpeg.% - $(EXECUTE_CYCLES) $< -dct int -ppm -outfile $@.ppm testorig.jpg 2> $@ - cmp $@.ppm testimg.ppm 2>> $@ - -cjpeg.%.out: cjpeg.% - $(EXECUTE_CYCLES) $< -dct int -outfile $@.jpg testimg.ppm 2> $@ - cmp $@.jpg testimg.jpg 2>> $@ - -.SECONDARY: +#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 +# +#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 \ +# jcphuff.c jcprepct.c jcsample.c jctrans.c jdapimin.c jdapistd.c \ +# jdatadst.c jdatasrc.c jdcoefct.c jdcolor.c jddctmgr.c jdhuff.c \ +# jdinput.c jdmainct.c jdmarker.c jdmaster.c jdmerge.c jdphuff.c \ +# jdpostct.c jdsample.c jdtrans.c jerror.c jfdctflt.c jfdctfst.c \ +# jfdctint.c jidctflt.c jidctfst.c jidctint.c jidctred.c jquant1.c \ +# 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) +# +#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.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.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 +# +# +#djpeg.%.out: djpeg.% +# $(EXECUTE_CYCLES) $< -dct int -ppm -outfile $@.ppm testorig.jpg 2> $@ +# cmp $@.ppm testimg.ppm 2>> $@ +# +#cjpeg.%.out: cjpeg.% +# $(EXECUTE_CYCLES) $< -dct int -outfile $@.jpg testimg.ppm 2> $@ +# cmp $@.jpg testimg.jpg 2>> $@ +# +#.SECONDARY: diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index c91e9d1f..6cb63235 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -95,7 +95,8 @@ obj/%.o: asm/%.s out/%.out: bin/%.bin @mkdir -p $(@D) - $(EXECUTE_CYCLES) $< $(EXECUTE_ARGS) | tee $@ + @rm -f $@ + $(EXECUTE_CYCLES) $< $(subst __BASE__,$(patsubst %.out,%,$@),$(EXECUTE_ARGS)) | tee -a $@ ## # Generating the rules for all the compiler/flags.. -- cgit From e47bea1b9f99f78f92079a91aa23b2b01a8f23e9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 15 Nov 2019 17:07:46 +0100 Subject: Adding zlib --- test/monniaux/zlib-1.2.11/Makefile | 106 ++++++++++++++++++++----------------- 1 file changed, 57 insertions(+), 49 deletions(-) diff --git a/test/monniaux/zlib-1.2.11/Makefile b/test/monniaux/zlib-1.2.11/Makefile index 202f2ea4..64fa89d2 100644 --- a/test/monniaux/zlib-1.2.11/Makefile +++ b/test/monniaux/zlib-1.2.11/Makefile @@ -1,53 +1,61 @@ -ALL_CCOMPFLAGS = -faddx -ALL_CFLAGS = -D_POSIX_C_SOURCE=2 -D_LARGEFILE64_SOURCE=1 -U__STRICT_ANSI__ +TARGET=zlib -include ../rules.mk - -src=$(wildcard *.c) - -PRODUCTS?=minigzip.gcc.host minigzip.ccomp.host minigzip.gcc.k1c minigzip.gcc.o1.k1c minigzip.ccomp.k1c -PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS)) - -all: $(PRODUCTS) - -.PHONY: -run: measures.csv - - -minigzip.gcc.host: $(src:.c=.gcc.host.o) ../clock.gcc.host.o - $(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 $@ -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)>> $@ +ALL_CCOMPFLAGS=-faddx +ALL_CFLAGS= -D_POSIX_C_SOURCE=2 -D_LARGEFILE64_SOURCE=1 -U__STRICT_ANSI__ -SAMPLE_FILE=zlib.h - -minigzip.gcc.host.out minigzip.gcc.host.output: minigzip.gcc.host - ./$< < $(SAMPLE_FILE) > $<.output 2> $@ - -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 - $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ - -minigzip.gcc.o1.k1c.out minigzip.gcc.o1.k1c.output: minigzip.gcc.o1.k1c - $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ - -minigzip.ccomp.k1c.out minigzip.ccomp.k1c.output: minigzip.ccomp.k1c - $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ - -.SECONDARY: +include ../rules.mk -.PHONY: -clean: - rm -f *.o *.s *.k1c *.csv +#ALL_CCOMPFLAGS = -faddx +#ALL_CFLAGS = -D_POSIX_C_SOURCE=2 -D_LARGEFILE64_SOURCE=1 -U__STRICT_ANSI__ +# +#include ../rules.mk +# +#src=$(wildcard *.c) +# +#PRODUCTS?=minigzip.gcc.host minigzip.ccomp.host minigzip.gcc.k1c minigzip.gcc.o1.k1c minigzip.ccomp.k1c +#PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS)) +# +#all: $(PRODUCTS) +# +#.PHONY: +#run: measures.csv +# +# +#minigzip.gcc.host: $(src:.c=.gcc.host.o) ../clock.gcc.host.o +# $(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 $@ +#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)>> $@ +# +#SAMPLE_FILE=zlib.h +# +#minigzip.gcc.host.out minigzip.gcc.host.output: minigzip.gcc.host +# ./$< < $(SAMPLE_FILE) > $<.output 2> $@ +# +#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 +# $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ +# +#minigzip.gcc.o1.k1c.out minigzip.gcc.o1.k1c.output: minigzip.gcc.o1.k1c +# $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ +# +#minigzip.ccomp.k1c.out minigzip.ccomp.k1c.output: minigzip.ccomp.k1c +# $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ +# +#.SECONDARY: +# +#.PHONY: +#clean: +# rm -f *.o *.s *.k1c *.csv +# -- cgit From c3223c26f4d0b9deb3c099d87b7812413cf279e4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 19 Nov 2019 16:57:36 +0100 Subject: Fixing zlib --- test/monniaux/rules.mk | 1 + test/monniaux/zlib-1.2.11/Makefile | 1 + test/monniaux/zlib-1.2.11/zlib_small.txt | 539 +++++++++++++++++++++++++++++++ 3 files changed, 541 insertions(+) create mode 100644 test/monniaux/zlib-1.2.11/zlib_small.txt diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index 6cb63235..7546f517 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -28,6 +28,7 @@ K1C_CC?=k1-cos-gcc K1C_CCOMP?=ccomp # Command to execute +#EXECUTE_CYCLES?=timeout --signal=SIGTERM 3m k1-cluster --syscall=libstd_scalls.so --cycle-based -- EXECUTE_CYCLES?=k1-cluster --syscall=libstd_scalls.so --cycle-based -- # You can define up to GCC4FLAGS and CCOMP4FLAGS diff --git a/test/monniaux/zlib-1.2.11/Makefile b/test/monniaux/zlib-1.2.11/Makefile index 64fa89d2..9e6920f5 100644 --- a/test/monniaux/zlib-1.2.11/Makefile +++ b/test/monniaux/zlib-1.2.11/Makefile @@ -2,6 +2,7 @@ TARGET=zlib ALL_CCOMPFLAGS=-faddx ALL_CFLAGS= -D_POSIX_C_SOURCE=2 -D_LARGEFILE64_SOURCE=1 -U__STRICT_ANSI__ +EXECUTE_ARGS=< zlib_small.txt > /dev/null 2> __BASE__.out include ../rules.mk diff --git a/test/monniaux/zlib-1.2.11/zlib_small.txt b/test/monniaux/zlib-1.2.11/zlib_small.txt new file mode 100644 index 00000000..2c494200 --- /dev/null +++ b/test/monniaux/zlib-1.2.11/zlib_small.txt @@ -0,0 +1,539 @@ + + + +#ifndef ZLIB_H +#define ZLIB_H + +#include "zconf.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#define ZLIB_VERSION "1.2.11" +#define ZLIB_VERNUM 0x12b0 +#define ZLIB_VER_MAJOR 1 +#define ZLIB_VER_MINOR 2 +#define ZLIB_VER_REVISION 11 +#define ZLIB_VER_SUBREVISION 0 + + + + +typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size)); +typedef void (*free_func) OF((voidpf opaque, voidpf address)); + +struct internal_state; + +typedef struct z_stream_s { + z_const Bytef *next_in; + + uLong total_in; + + uInt avail_out; + + + z_const char *msg; + + + alloc_func zalloc; + + voidpf opaque; + + uLong adler; + +} z_stream; + +typedef z_stream FAR *z_streamp; + + + +typedef struct gz_header_s { + int text; + + int xflags; + + Bytef *extra; + + uInt extra_max; + + uInt name_max; + + uInt comm_max; + + int done; + +} gz_header; + +typedef gz_header FAR *gz_headerp; + + + + + + + +#define Z_OK 0 +#define Z_STREAM_END 1 +#define Z_NEED_DICT 2 +#define Z_ERRNO (-1) +#define Z_STREAM_ERROR (-2) +#define Z_DATA_ERROR (-3) +#define Z_MEM_ERROR (-4) +#define Z_BUF_ERROR (-5) +#define Z_VERSION_ERROR (-6) + + + +#define Z_NO_COMPRESSION 0 +#define Z_BEST_SPEED 1 +#define Z_BEST_COMPRESSION 9 +#define Z_DEFAULT_COMPRESSION (-1) + + + +#define Z_BINARY 0 +#define Z_TEXT 1 +#define Z_ASCII Z_TEXT + + +#define Z_DEFLATED 8 + + + +#define zlib_version zlibVersion() + + + +ZEXTERN const char * ZEXPORT zlibVersion OF((void)); + + + + + + + +ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush)); + + + + +ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm)); + + + + + + + + +ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush)); + + + + +ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm)); + + + + + + + + + + +ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm, + const Bytef *dictionary, + uInt dictLength)); + + + +ZEXTERN int ZEXPORT deflateGetDictionary OF((z_streamp strm, + Bytef *dictionary, + uInt *dictLength)); + + + +ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest, + z_streamp source)); + + + +ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm)); + + + +ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm, + int level, + int strategy)); + + + +ZEXTERN int ZEXPORT deflateTune OF((z_streamp strm, + int good_length, + int max_lazy, + int nice_length, + int max_chain)); + + + +ZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm, + uLong sourceLen)); + + + +ZEXTERN int ZEXPORT deflatePending OF((z_streamp strm, + unsigned *pending, + int *bits)); + + + +ZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm, + int bits, + int value)); + + + +ZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm, + gz_headerp head)); + + + + + + +ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm, + const Bytef *dictionary, + uInt dictLength)); + + + +ZEXTERN int ZEXPORT inflateGetDictionary OF((z_streamp strm, + Bytef *dictionary, + uInt *dictLength)); + + + +ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm)); + + + +ZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest, + z_streamp source)); + + + +ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm)); + + + +ZEXTERN int ZEXPORT inflateReset2 OF((z_streamp strm, + int windowBits)); + + + +ZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm, + int bits, + int value)); + + + +ZEXTERN long ZEXPORT inflateMark OF((z_streamp strm)); + + + +ZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm, + gz_headerp head)); + + + + + + +typedef unsigned (*in_func) OF((void FAR *, + z_const unsigned char FAR * FAR *)); +typedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned)); + +ZEXTERN int ZEXPORT inflateBack OF((z_streamp strm, + in_func in, void FAR *in_desc, + out_func out, void FAR *out_desc)); + + + +ZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm)); + + + +ZEXTERN uLong ZEXPORT zlibCompileFlags OF((void)); + + + +#ifndef Z_SOLO + + + + +ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen, + const Bytef *source, uLong sourceLen)); + + + +ZEXTERN int ZEXPORT compress2 OF((Bytef *dest, uLongf *destLen, + const Bytef *source, uLong sourceLen, + int level)); + + + +ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen)); + + + +ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen, + const Bytef *source, uLong sourceLen)); + + + +ZEXTERN int ZEXPORT uncompress2 OF((Bytef *dest, uLongf *destLen, + const Bytef *source, uLong *sourceLen)); + + + + + + +typedef struct gzFile_s *gzFile; + + +ZEXTERN gzFile ZEXPORT gzdopen OF((int fd, const char *mode)); + + + +ZEXTERN int ZEXPORT gzbuffer OF((gzFile file, unsigned size)); + + + +ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy)); + + + +ZEXTERN int ZEXPORT gzread OF((gzFile file, voidp buf, unsigned len)); + + + +ZEXTERN z_size_t ZEXPORT gzfread OF((voidp buf, z_size_t size, z_size_t nitems, + gzFile file)); + + + +ZEXTERN int ZEXPORT gzwrite OF((gzFile file, + voidpc buf, unsigned len)); + + + +ZEXTERN z_size_t ZEXPORT gzfwrite OF((voidpc buf, z_size_t size, + z_size_t nitems, gzFile file)); + + + +ZEXTERN int ZEXPORTVA gzprintf Z_ARG((gzFile file, const char *format, ...)); + + + +ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s)); + + + +ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len)); + + + +ZEXTERN int ZEXPORT gzputc OF((gzFile file, int c)); + + + +ZEXTERN int ZEXPORT gzgetc OF((gzFile file)); + + + +ZEXTERN int ZEXPORT gzungetc OF((int c, gzFile file)); + + + +ZEXTERN int ZEXPORT gzflush OF((gzFile file, int flush)); + + + + + + +ZEXTERN int ZEXPORT gzrewind OF((gzFile file)); + + + + + + + + + +ZEXTERN int ZEXPORT gzeof OF((gzFile file)); + + + +ZEXTERN int ZEXPORT gzdirect OF((gzFile file)); + + + +ZEXTERN int ZEXPORT gzclose OF((gzFile file)); + + + +ZEXTERN int ZEXPORT gzclose_r OF((gzFile file)); +ZEXTERN int ZEXPORT gzclose_w OF((gzFile file)); + + + +ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum)); + + + +ZEXTERN void ZEXPORT gzclearerr OF((gzFile file)); + + + +#endif + + + + + +ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len)); + + + +ZEXTERN uLong ZEXPORT adler32_z OF((uLong adler, const Bytef *buf, + z_size_t len)); + + + + + + +ZEXTERN uLong ZEXPORT crc32 OF((uLong crc, const Bytef *buf, uInt len)); + + + +ZEXTERN uLong ZEXPORT crc32_z OF((uLong adler, const Bytef *buf, + z_size_t len)); + + + + + + + + + +ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level, + const char *version, int stream_size)); +ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm, + const char *version, int stream_size)); +ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int level, int method, + int windowBits, int memLevel, + int strategy, const char *version, + int stream_size)); +ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int windowBits, + const char *version, int stream_size)); +ZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits, + unsigned char FAR *window, + const char *version, + int stream_size)); +#ifdef Z_PREFIX_SET +# define z_deflateInit(strm, level) \ + deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream)) +# define z_inflateInit(strm) \ + inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream)) +# define z_deflateInit2(strm, level, method, windowBits, memLevel, strategy) \ + deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\ + (strategy), ZLIB_VERSION, (int)sizeof(z_stream)) +# define z_inflateInit2(strm, windowBits) \ + inflateInit2_((strm), (windowBits), ZLIB_VERSION, \ + (int)sizeof(z_stream)) +# define z_inflateBackInit(strm, windowBits, window) \ + inflateBackInit_((strm), (windowBits), (window), \ + ZLIB_VERSION, (int)sizeof(z_stream)) +#else +# define deflateInit(strm, level) \ + deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream)) +# define inflateInit(strm) \ + inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream)) +# define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \ + deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\ + (strategy), ZLIB_VERSION, (int)sizeof(z_stream)) +# define inflateInit2(strm, windowBits) \ + inflateInit2_((strm), (windowBits), ZLIB_VERSION, \ + (int)sizeof(z_stream)) +# define inflateBackInit(strm, windowBits, window) \ + inflateBackInit_((strm), (windowBits), (window), \ + ZLIB_VERSION, (int)sizeof(z_stream)) +#endif + +#ifndef Z_SOLO + + + +struct gzFile_s { + unsigned have; + unsigned char *next; + z_off64_t pos; +}; +ZEXTERN int ZEXPORT gzgetc_ OF((gzFile file)); + +#ifdef Z_LARGE64 + ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *)); + ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int)); + ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile)); + ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile)); + ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off64_t)); + ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off64_t)); +#endif + +#if !defined(ZLIB_INTERNAL) && defined(Z_WANT64) +# ifdef Z_PREFIX_SET +# define z_gzopen z_gzopen64 +# define z_gzseek z_gzseek64 +# define z_gztell z_gztell64 +# define z_gzoffset z_gzoffset64 +# define z_adler32_combine z_adler32_combine64 +# define z_crc32_combine z_crc32_combine64 +# else +# define gzopen gzopen64 +# define gzseek gzseek64 +# define gztell gztell64 +# define gzoffset gzoffset64 +# define adler32_combine adler32_combine64 +# define crc32_combine crc32_combine64 +# endif +# ifndef Z_LARGE64 + ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *)); + ZEXTERN z_off_t ZEXPORT gzseek64 OF((gzFile, z_off_t, int)); + ZEXTERN z_off_t ZEXPORT gztell64 OF((gzFile)); + ZEXTERN z_off_t ZEXPORT gzoffset64 OF((gzFile)); + ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t)); + ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t)); +# endif +#else + ZEXTERN gzFile ZEXPORT gzopen OF((const char *, const char *)); + ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile, z_off_t, int)); + ZEXTERN z_off_t ZEXPORT gztell OF((gzFile)); + ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile)); + ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t)); + ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t)); +#endif + +#else + + + + -- cgit From 649bd315c541fcc076cdb05ee0c41be8c890bd88 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Nov 2019 11:34:10 +0100 Subject: benchmarks += ocaml --- test/monniaux/ocaml/Makefile | 33 +++------------------------------ 1 file changed, 3 insertions(+), 30 deletions(-) diff --git a/test/monniaux/ocaml/Makefile b/test/monniaux/ocaml/Makefile index b63c8864..20f32b65 100644 --- a/test/monniaux/ocaml/Makefile +++ b/test/monniaux/ocaml/Makefile @@ -1,33 +1,6 @@ -ALL_CFLAGS=-Ibyterun +TARGET=ocaml +ALL_CFLAGS=-Ibyterun -lm +ALL_CFILES=$(wildcard byterun/*.c) EXECUTE_ARGS=examples/quicksort include ../rules.mk - -ALL_CCOMPFLAGS= -LDLIBS=-lm - -CFILES=$(wildcard byterun/*.c) - -CCOMP_K1C_S=$(patsubst %.c,%.ccomp.k1c.s,$(CFILES)) -CCOMP_HOST_S=$(patsubst %.c,%.ccomp.host.s,$(CFILES)) - -GCC_K1C_S=$(patsubst %.c,%.gcc.k1c.s,$(CFILES)) -GCC_O1_K1C_S=$(patsubst %.c,%.gcc.o1.k1c.s,$(CFILES)) -GCC_HOST_S=$(patsubst %.c,%.gcc.host.s,$(CFILES)) - -all: $(CCOMP_K1C_S) $(GCC_K1C_S) ocamlrun.ccomp.k1c.out ocamlrun.gcc.k1c.out ocamlrun.gcc.o1.k1c.out - -ocamlrun.ccomp.k1c : $(CCOMP_K1C_S) ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ $(LDLIBS) - -ocamlrun.ccomp.host : $(CCOMP_HOST_S) ../clock.gcc.host.o - $(CCOMP) $(CCOMPFLAGS) $+ -o $@ $(LDLIBS) - -ocamlrun.gcc.k1c : $(GCC_K1C_S) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ $(LDLIBS) - -ocamlrun.gcc.o1.k1c : $(GCC_O1_K1C_S) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS_O1) $+ -o $@ $(LDLIBS) - -ocamlrun.gcc.host : $(GCC_HOST_S) ../clock.gcc.host.o - $(CC) $(CFLAGS) $+ -o $@ $(LDLIBS) -- cgit From c1ec610b440f1fd02ae8d3127a45edf66bc07a62 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Nov 2019 11:36:58 +0100 Subject: Adding the new benches to benches.sh --- test/monniaux/benches.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/benches.sh b/test/monniaux/benches.sh index 6014f628..0ba1dc51 100644 --- a/test/monniaux/benches.sh +++ b/test/monniaux/benches.sh @@ -1,3 +1,3 @@ -benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann" +benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann jpeg-6b zlib-1.2.11 ocaml" # Removed for now : ternary -- cgit From c087bf2556a280b3dbd4ba0c1cbda493d18d4290 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Nov 2019 11:57:13 +0100 Subject: benches += tiff --- test/monniaux/benches.sh | 2 +- test/monniaux/tiff-4.0.10/Makefile | 51 ++----------------------------- test/monniaux/tiff-4.0.10/example_bw.pbm | Bin 0 -> 18262 bytes 3 files changed, 4 insertions(+), 49 deletions(-) create mode 100644 test/monniaux/tiff-4.0.10/example_bw.pbm diff --git a/test/monniaux/benches.sh b/test/monniaux/benches.sh index 0ba1dc51..85d1f16d 100644 --- a/test/monniaux/benches.sh +++ b/test/monniaux/benches.sh @@ -1,3 +1,3 @@ -benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann jpeg-6b zlib-1.2.11 ocaml" +benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann jpeg-6b zlib-1.2.11 ocaml tiff-4.0.10" # Removed for now : ternary diff --git a/test/monniaux/tiff-4.0.10/Makefile b/test/monniaux/tiff-4.0.10/Makefile index db3428fa..ac1aa276 100644 --- a/test/monniaux/tiff-4.0.10/Makefile +++ b/test/monniaux/tiff-4.0.10/Makefile @@ -1,52 +1,7 @@ +TARGET=ppm2tiff +ALL_CFLAGS=-lm ALL_CCOMPFLAGS = -flongdouble +EXECUTE_ARGS= -c g3 __BASE__.g3.tif < example_bw.pbm include ../rules.mk -LIBS=-lm - -src=$(wildcard *.c) - -PRODUCTS?=ppm2tiff.gcc.host ppm2tiff.ccomp.host ppm2tiff.gcc.k1c ppm2tiff.gcc.o1.k1c ppm2tiff.ccomp.k1c -PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS)) - -all: $(PRODUCTS) - -.PHONY: -run: measures.csv - -ppm2tiff.gcc.host: $(src:.c=.gcc.host.o) ../clock.gcc.host.o - $(CC) $(CFLAGS) $+ $(LIBS) -o $@ -ppm2tiff.ccomp.host: $(src:.c=.ccomp.host.o) ../clock.gcc.host.o - $(CCOMP) $(CCOMPFLAGS) $+ $(LIBS) -o $@ -ppm2tiff.gcc.k1c: $(src:.c=.gcc.k1c.o) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ $(LIBS) -o $@ -ppm2tiff.gcc.o1.k1c: $(src:.c=.gcc.o1.k1c.o) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS_O1) $+ $(LIBS) -o $@ -ppm2tiff.ccomp.k1c: $(src:.c=.ccomp.k1c.o) ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ $(LIBS) -o $@ - -ppm2tiff.gcc.host.out: ppm2tiff.gcc.host - bunzip2 < example_bw.pbm.bz2 | ./$< -c g3 $<.g3.tif | tee $@ - -ppm2tiff.ccomp.host.out: ppm2tiff.ccomp.host - bunzip2 < example_bw.pbm.bz2 | ./$< -c g3 $<.g3.tif | tee $@ - -ppm2tiff.gcc.k1c.out: ppm2tiff.gcc.k1c - bunzip2 < example_bw.pbm.bz2 | $(EXECUTE_CYCLES) ./$< -c g3 $<.g3.tif | tee $@ - -ppm2tiff.gcc.o1.k1c.out: ppm2tiff.gcc.o1.k1c - bunzip2 < example_bw.pbm.bz2 | $(EXECUTE_CYCLES) ./$< -c g3 $<.g3.tif | tee $@ - -ppm2tiff.ccomp.k1c.out: ppm2tiff.ccomp.k1c - bunzip2 < example_bw.pbm.bz2 | $(EXECUTE_CYCLES) ./$< -c g3 $<.g3.tif | tee $@ - -measures.csv: $(PRODUCTS_OUT) - echo "benches, gcc host,ccomp host,gcc k1c,gcc o1 k1c,ccomp k1c" > $@ - echo "ppm2tiff ", $$(grep 'cycles' ppm2tiff.gcc.host.out | cut -d':' -f2), $$(grep 'cycles' ppm2tiff.ccomp.host.out | cut -d':' -f2), $$(grep 'cycles' ppm2tiff.gcc.k1c.out | cut -d':' -f2), $$(grep 'cycles' ppm2tiff.gcc.o1.k1c.out | cut -d':' -f2), $$(grep 'cycles' ppm2tiff.ccomp.k1c.out | cut -d':' -f2)>> $@ - -.SECONDARY: - -.PHONY: -clean: - rm -f *.o *.s *.k1c *.csv - diff --git a/test/monniaux/tiff-4.0.10/example_bw.pbm b/test/monniaux/tiff-4.0.10/example_bw.pbm new file mode 100644 index 00000000..971a82bb Binary files /dev/null and b/test/monniaux/tiff-4.0.10/example_bw.pbm differ -- cgit From 3b4184195e0fed3ff4e1590f401cbc0330910859 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Nov 2019 14:38:27 +0100 Subject: Real clean --- test/monniaux/rules.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index 7546f517..2de2c466 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -158,5 +158,5 @@ run: measures.csv clean: rm -f *.o *.s *.bin *.out - rm -f asm/*.s bin/*.bin obj/*.o out/*.out + rm -rf asm/ bin/ obj/ out/ -- cgit From 2d9ef79ffd1903a444bb33dfdd91bf4d2542c12e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Nov 2019 16:36:29 +0100 Subject: benches += ncompress --- test/monniaux/benches.sh | 2 +- test/monniaux/ncompress/Makefile | 54 +++------------------------------------- 2 files changed, 4 insertions(+), 52 deletions(-) diff --git a/test/monniaux/benches.sh b/test/monniaux/benches.sh index 85d1f16d..434e1b15 100644 --- a/test/monniaux/benches.sh +++ b/test/monniaux/benches.sh @@ -1,3 +1,3 @@ -benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann jpeg-6b zlib-1.2.11 ocaml tiff-4.0.10" +benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann jpeg-6b zlib-1.2.11 ocaml tiff-4.0.10 ncompress" # Removed for now : ternary diff --git a/test/monniaux/ncompress/Makefile b/test/monniaux/ncompress/Makefile index cf543976..14a99d0b 100644 --- a/test/monniaux/ncompress/Makefile +++ b/test/monniaux/ncompress/Makefile @@ -1,52 +1,4 @@ -include ../rules.mk - -all: check - - -all: compress.gcc.host compress.ccomp.host compress.gcc.k1c compress.ccomp.k1c - -compress.gcc.host : compress42.c ../clock.gcc.host.o - $(CC) $(CFLAGS) $+ -o $@ - -compress.ccomp.host : compress42.c ../clock.gcc.host.o - $(CCOMP) $(CCOMPFLAGS) $+ -o $@ - -compress.gcc.k1c : compress42.gcc.k1c.o ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ - -compress.ccomp.k1c : compress42.ccomp.k1c.o ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ - -INFILE=Makefile -COMPRESSED=foo.gcc.host.Z - -foo.gcc.host.Z: compress.gcc.host $(INFILE) - ./compress.gcc.host <$(INFILE) >foo.gcc.host.Z 2> foo.gcc.host.Z.out +TARGET=compress +EXECUTE_ARGS= < Makefile > __BASE__.Z 2> __BASE__.out -foo.ccomp.k1c.Z: compress.ccomp.k1c $(INFILE) - $(EXECUTE) ./compress.ccomp.k1c <$(INFILE) >foo.ccomp.k1c.Z 2> foo.ccomp.k1c.Z.out - -foo.gcc.k1c.Z: compress.gcc.k1c $(INFILE) - $(EXECUTE) ./compress.gcc.k1c <$(INFILE) >foo.gcc.k1c.Z 2> foo.gcc.k1c.Z.out - -foo.gcc.host.txt: compress.gcc.host $(COMPRESSED) - ./compress.gcc.host -d <$(COMPRESSED) >foo.gcc.host.txt 2> foo.gcc.host.txt.out - -foo.ccomp.k1c.txt: compress.gcc.host $(COMPRESSED) - $(EXECUTE) ./compress.ccomp.k1c -d <$(COMPRESSED) >foo.ccomp.k1c.txt 2> foo.ccomp.k1c.txt.out - -foo.gcc.k1c.txt: compress.gcc.host $(COMPRESSED) - $(EXECUTE) ./compress.gcc.k1c -d <$(COMPRESSED) >foo.gcc.k1c.txt 2> foo.gcc.k1c.txt.out - -check: foo.gcc.host.Z foo.gcc.host.txt foo.ccomp.k1c.Z foo.ccomp.k1c.txt foo.gcc.k1c.Z foo.gcc.k1c.txt - cmp foo.gcc.host.Z foo.ccomp.k1c.Z - cmp foo.gcc.host.Z foo.gcc.k1c.Z - cmp foo.gcc.host.txt foo.ccomp.k1c.txt - cmp foo.gcc.host.txt foo.gcc.k1c.txt - -clean: - rm -f *.Z *.txt *.out *.o *.s *.host *.k1c - -.PHONY: clean - -.SECONDARY: %.s +include ../rules.mk -- cgit From afcda39ab5d9aaf9dcce0d7ea9fc50acc9d318ed Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Nov 2019 17:19:18 +0100 Subject: Fixing pcre2 (but it is bugged in GCC?) --- test/monniaux/pcre2-10.32/Makefile | 39 ++++------------------------------- test/monniaux/pcre2-10.32/pcre2test.c | 2 +- 2 files changed, 5 insertions(+), 36 deletions(-) diff --git a/test/monniaux/pcre2-10.32/Makefile b/test/monniaux/pcre2-10.32/Makefile index 98c2c8c2..b6b66c37 100644 --- a/test/monniaux/pcre2-10.32/Makefile +++ b/test/monniaux/pcre2-10.32/Makefile @@ -1,4 +1,7 @@ -CFILES = \ +TARGET=pcre2 +ALL_CFLAGS = -DHAVE_CONFIG_H -DPCRE2_CODE_UNIT_WIDTH=8 +EXECUTE_ARGS=testdata/testinput6 > /dev/null 2> __BASE__.out +ALL_CFILES = \ pcre2_auto_possess.c \ pcre2_chartables.c \ pcre2_compile.c \ @@ -28,39 +31,5 @@ CFILES = \ pcre2posix.c \ pcre2test.c -HFILES = config.h pcre2_internal.h pcre2posix.h \ -pcre2.h pcre2_intmodedep.h pcre2_ucp.h - -K1C_GCC_OFILES=$(CFILES:.c=.gcc.k1c.o) -K1C_GCC_OFILES_O1=$(CFILES:.c=.gcc.o1.k1c.o) -K1C_CCOMP_OFILES=$(CFILES:.c=.ccomp.k1c.o) -K1C_GCC_SFILES=$(CFILES:.c=.gcc.k1c.s) -K1C_CCOMP_SFILES=$(CFILES:.c=.ccomp.k1c.s) -HOST_GCC_OFILES=$(CFILES:.c=.gcc.host.o) - -all: pcre2test.gcc.o1.k1c.out pcre2test.gcc.k1c.out pcre2test.ccomp.k1c.out $(K1C_GCC_SFILES) $(K1C_CCOMP_SFILES) - -ALL_CFLAGS = -DHAVE_CONFIG_H -DPCRE2_CODE_UNIT_WIDTH=8 -EXECUTE_ARGS = testdata/testinput6 - include ../rules.mk - -$(K1C_GCC_SFILES) $(K1C_GCC_OFILES_O1) $(K1C_CCOMP_SFILES) $(HOST_GCC_OFILES): $(HFILES) - -pcre2test.gcc.host: $(HOST_GCC_OFILES) - $(CC) $(CFLAGS) -o $@ $+ ../clock.gcc.host.o - -pcre2test.gcc.k1c: $(K1C_GCC_OFILES) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) -o $@ $+ - -pcre2test.gcc.o1.k1c: $(K1C_GCC_OFILES_O1) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS_O1) -o $@ $+ - -pcre2test.ccomp.k1c: $(K1C_CCOMP_OFILES) ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -o $@ $+ - -.PHONY: clean - -clean: - rm -f *.s *.o *.k1c diff --git a/test/monniaux/pcre2-10.32/pcre2test.c b/test/monniaux/pcre2-10.32/pcre2test.c index 25a7c4a1..a1fb64cb 100644 --- a/test/monniaux/pcre2-10.32/pcre2test.c +++ b/test/monniaux/pcre2-10.32/pcre2test.c @@ -8792,7 +8792,7 @@ FREECONTEXTS; #endif clock_stop(); - print_total_clock(); + printerr_total_clock(); return yield; } -- cgit From 30959c8e41625ad158f71f55529ff1123ee23b9b Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 25 Nov 2019 15:58:30 +0100 Subject: Simplified diagnostics module. Instead of constructing four different lists for maintaining the state of the warnings only one list is now used. This list contains the name of the warning and a boolean indicating whether this option should be active by default. The rest is computed from this list. --- cparser/Diagnostics.ml | 159 +++++++++++++------------------------------------ 1 file changed, 41 insertions(+), 118 deletions(-) diff --git a/cparser/Diagnostics.ml b/cparser/Diagnostics.ml index 012e4b66..e24b8e68 100644 --- a/cparser/Diagnostics.ml +++ b/cparser/Diagnostics.ml @@ -104,30 +104,45 @@ type warning_type = | Reduced_alignment | Non_linear_cond_expr +(* List of all warnings with default status. + "true" means the warning is active by default. + "false" means the warning is off by default. *) +let all_warnings = + [ (Unnamed, true); + (Unknown_attribute, true); + (Zero_length_array, false); + (Celeven_extension, false); + (Gnu_empty_struct, true); + (Missing_declarations, true); + (Constant_conversion, true); + (Int_conversion, true); + (Varargs, true); + (Implicit_function_declaration, true); + (Pointer_type_mismatch, true); + (Compare_distinct_pointer_types, true); + (Implicit_int, true); + (Main_return_type, true); + (Invalid_noreturn, true); + (Return_type, true); + (Literal_range, true); + (Unknown_pragmas, false); + (CompCert_conformance, false); + (Inline_asm_sdump, true); + (Unused_variable, false); + (Unused_parameter, false); + (Wrong_ais_parameter, true); + (Ignored_attributes, true); + (Extern_after_definition, true); + (Static_in_inline, true); + (Flexible_array_extensions, false); + (Tentative_incomplete_static, false); + (Reduced_alignment, false); + (Non_linear_cond_expr, false); + ] + (* List of active warnings *) -let active_warnings: warning_type list ref = ref [ - Unnamed; - Unknown_attribute; - Gnu_empty_struct; - Missing_declarations; - Constant_conversion; - Int_conversion; - Varargs; - Implicit_function_declaration; - Pointer_type_mismatch; - Compare_distinct_pointer_types; - Implicit_int; - Main_return_type; - Invalid_noreturn; - Return_type; - Literal_range; - Inline_asm_sdump; - Wrong_ais_parameter; - Unused_ais_parameter; - Ignored_attributes; - Extern_after_definition; - Static_in_inline; -] +let active_warnings: warning_type list ref = + ref (List.map fst (List.filter snd all_warnings)) (* List of errors treated as warning *) let error_warnings: warning_type list ref = ref [] @@ -188,76 +203,14 @@ let warning_not_as_error w () = (* Activate all warnings *) let wall () = - active_warnings:=[ - Unnamed; - Unknown_attribute; - Zero_length_array; - Celeven_extension; - Gnu_empty_struct; - Missing_declarations; - Constant_conversion; - Int_conversion; - Varargs; - Implicit_function_declaration; - Pointer_type_mismatch; - Compare_distinct_pointer_types; - Implicit_int; - Main_return_type; - Invalid_noreturn; - Return_type; - Literal_range; - Unknown_pragmas; - CompCert_conformance; - Inline_asm_sdump; - Unused_variable; - Unused_parameter; - Wrong_ais_parameter; - Ignored_attributes; - Extern_after_definition; - Static_in_inline; - Flexible_array_extensions; - Tentative_incomplete_static; - Reduced_alignment; - Non_linear_cond_expr; - ] + active_warnings:= List.map fst all_warnings let wnothing () = active_warnings :=[] (* Make all warnings an error *) let werror () = - error_warnings:=[ - Unnamed; - Unknown_attribute; - Zero_length_array; - Celeven_extension; - Gnu_empty_struct; - Missing_declarations; - Constant_conversion; - Int_conversion; - Varargs; - Implicit_function_declaration; - Pointer_type_mismatch; - Compare_distinct_pointer_types; - Implicit_int; - Main_return_type; - Invalid_noreturn; - Return_type; - Literal_range; - Unknown_pragmas; - CompCert_conformance; - Inline_asm_sdump; - Unused_variable; - Wrong_ais_parameter; - Unused_ais_parameter; - Ignored_attributes; - Extern_after_definition; - Static_in_inline; - Flexible_array_extensions; - Tentative_incomplete_static; - Reduced_alignment; - Non_linear_cond_expr; - ] + error_warnings:= List.map fst all_warnings (* Generate the warning key for the message *) let key_of_warning w = @@ -411,37 +364,7 @@ let error_option w = Exact ("-Wno-error="^key), Unit ( warning_not_as_error w)] let warning_options = - error_option Unnamed @ - error_option Unknown_attribute @ - error_option Zero_length_array @ - error_option Celeven_extension @ - error_option Gnu_empty_struct @ - error_option Missing_declarations @ - error_option Constant_conversion @ - error_option Int_conversion @ - error_option Varargs @ - error_option Implicit_function_declaration @ - error_option Pointer_type_mismatch @ - error_option Compare_distinct_pointer_types @ - error_option Implicit_int @ - error_option Main_return_type @ - error_option Invalid_noreturn @ - error_option Return_type @ - error_option Literal_range @ - error_option Unknown_pragmas @ - error_option CompCert_conformance @ - error_option Inline_asm_sdump @ - error_option Unused_variable @ - error_option Unused_parameter @ - error_option Wrong_ais_parameter @ - error_option Unused_ais_parameter @ - error_option Ignored_attributes @ - error_option Extern_after_definition @ - error_option Static_in_inline @ - error_option Flexible_array_extensions @ - error_option Tentative_incomplete_static @ - error_option Reduced_alignment @ - error_option Non_linear_cond_expr @ + List.concat (List.map (fun (w, active) -> error_option w) all_warnings) @ [Exact ("-Wfatal-errors"), Set error_fatal; Exact ("-fdiagnostics-color"), Ignore; (* Either output supports it or no color *) Exact ("-fno-diagnostics-color"), Unset color_diagnostics; -- cgit From e2341e779ca6bf734b9ed103156949db588fbbdc Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 26 Nov 2019 07:38:20 +0100 Subject: Duplicateproof: minor edit --- backend/Duplicateproof.v | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 9d56e86f..39b7a353 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -344,15 +344,16 @@ Proof. intros. inv H. exploit function_ptr_translated; eauto. intros (tf & FIND & TRANSF). eexists. split. - - econstructor. + - econstructor; eauto. + eapply (Genv.init_mem_transf_partial TRANSL); eauto. + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. symmetry. eapply match_program_main. eauto. - + exploit function_ptr_translated; eauto. + destruct f. * monadInv TRANSF. rewrite <- H3. symmetry; eapply transf_function_preserves. assumption. * monadInv TRANSF. assumption. - - constructor; eauto. constructor. apply transf_fundef_correct; auto. + - constructor; eauto. + + constructor. + + apply transf_fundef_correct; auto. Qed. Theorem transf_final_states: -- cgit From 50b6f685259f0326ea0c44cdd3503739455d5993 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 26 Nov 2019 09:15:26 +0100 Subject: Added back unused_ais_parameter warning. --- cparser/Diagnostics.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/cparser/Diagnostics.ml b/cparser/Diagnostics.ml index e24b8e68..7957375c 100644 --- a/cparser/Diagnostics.ml +++ b/cparser/Diagnostics.ml @@ -131,6 +131,7 @@ let all_warnings = (Unused_variable, false); (Unused_parameter, false); (Wrong_ais_parameter, true); + (Unused_ais_parameter, true); (Ignored_attributes, true); (Extern_after_definition, true); (Static_in_inline, true); -- cgit From def114623f2d03ea7838900b531f7b3beec5a7a0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 26 Nov 2019 17:07:59 +0100 Subject: run-benches.sh adapting to number of CPU cores --- test/monniaux/run_benches.sh | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/monniaux/run_benches.sh b/test/monniaux/run_benches.sh index 60eec865..2b2e28d6 100755 --- a/test/monniaux/run_benches.sh +++ b/test/monniaux/run_benches.sh @@ -1,13 +1,16 @@ source benches.sh +cores=$(grep -c ^processor /proc/cpuinfo) +processes=$((cores/4)) + rm -f commands.txt for bench in $benches; do echo "(cd $bench && echo \"Running $bench..\" &&\ make -j4 run > /dev/null && echo \"$bench DONE\")" >> commands.txt done -cat commands.txt | xargs -n1 -I{} -P6 bash -c '{}' +cat commands.txt | xargs -n1 -I{} -P$processes bash -c '{}' ## # Gather all the CSV files -- cgit From 6a3a2c90c52c60f2f9cc64dddb7b953a6b804f76 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 26 Nov 2019 17:11:17 +0100 Subject: build_benches.sh adapting to number of cores --- test/monniaux/build_benches.sh | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/monniaux/build_benches.sh b/test/monniaux/build_benches.sh index a749779d..01abf55d 100755 --- a/test/monniaux/build_benches.sh +++ b/test/monniaux/build_benches.sh @@ -2,6 +2,7 @@ TMPFILE=/tmp/1513times.txt +cores=$(grep -c ^processor /proc/cpuinfo) source benches.sh default="\e[39m" @@ -13,9 +14,9 @@ rm -f $TMPFILE for bench in $benches; do echo -e "${magenta}Building $bench..${default}" if [ "$1" == "" ]; then - (cd $bench && make -s -j20 > /dev/null &> /dev/null) || { echo -e "${red}Build failed" && break; } + (cd $bench && make -s -j$cores > /dev/null &> /dev/null) || { echo -e "${red}Build failed" && break; } else - (cd $bench && make -j20) | grep -P "\d+: \d+\.\d+" >> $TMPFILE + (cd $bench && make -j$cores) | grep -P "\d+: \d+\.\d+" >> $TMPFILE fi done -- cgit From b298bc4f694a71237d34881d0269721c3e0dcd02 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 26 Nov 2019 17:26:40 +0100 Subject: Updating test/monniaux/README.md --- test/monniaux/README.md | 67 ++++++++++++++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 28 deletions(-) diff --git a/test/monniaux/README.md b/test/monniaux/README.md index f2af67fb..67062e24 100644 --- a/test/monniaux/README.md +++ b/test/monniaux/README.md @@ -1,13 +1,18 @@ -# Benchmarking CompCert and GCC +# Benchmarking `CompCert` and GCC -rules.mk contains generic rules to compile with gcc and ccomp, with different -optimizations, and producing different binaries. It also produces a -measures.csv file containing the different timings given by the bench. +## Compiling `CompCert` -Up to 5 different optimizations can be used. +The first step to benchmark `CompCert` is to compile it - the `INSTALL.md` instructions of the project root folder should guide you on installing it. -To use this rule.mk, create a folder, put inside all the .c/.h source files, -and write a Makefile ressembling: +For the benchmarks to work, the compiler `ccomp` should be on your `$PATH`, with the runtime libraries installed correctly (with a successful `make install` on the project root directory). + +## Using the harness + +`rules.mk` contains generic rules to compile with `gcc` and `ccomp`, with different optimizations, and producing different binaries. It also produces a `measures.csv` file containing the different timings given by the bench. + +Up to 5 different sets of optimizations per compiler can be used. + +To use this `rules.mk`, create a folder, put inside all the .c/.h source files, and write a Makefile resembling: ```make TARGET=float_mat MEASURES="c1 c2 c3 c4 c5 c6 c7 c8" @@ -15,30 +20,24 @@ MEASURES="c1 c2 c3 c4 c5 c6 c7 c8" include ../rules.mk ``` -This is all that is required to write, the rules.mk handles everything. +This is all that is required to write, the `rules.mk` handles everything. -There is the possibility to define some variables to finetune what you want. -For instance, `ALL_CFILES` describes the .c source files whose objects are -to be linked. +There is the possibility to define some variables to fine tune what you want. For instance, `ALL_CFILES` describes the .c source files whose objects are to be linked. Here is an exhaustive list of the variables: - `TARGET`: name of the binary to produce - `MEASURES`: list of the different timings. This supposes that the program -prints something of the form "c3 cycles: 44131" for instance. In the above -example, the Makefile would generate such a line: -``` -float_mat c3, 1504675, 751514, 553235, 1929369, 1372441 -``` +prints something of the form `c3 cycles: 44131`. - `ALL_CFILES`: list of .c files to compile. By default, `$(wildcard *.c)` -- `CLOCK`: basename of the clock file to compile. Default `../clock` -- `ALL_CFLAGS`: cflags that are to be included for all compilers +- `CLOCK`: `basename` of the clock file to compile. Default `../clock` +- `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) -- `EXECUTE_CYCLES`: running command (default `k1-cluster` with some options) -- `EXECUTE_ARGS`: execution arguments -- `GCCiFLAGS` with i from 0 to 4: the wanted optimizations. If one of these flags is empty, nothing is done. Same for `CCOMPiFLAGS`. For now, the default values: +- `ALL_CCOMPFLAGS`: same, but `ccomp` specific +- `K1C_CC`: GCC compiler (default `k1-cos-gcc`) +- `K1C_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: ``` # You can define up to GCC4FLAGS and CCOMP4FLAGS GCC0FLAGS?= @@ -65,14 +64,26 @@ CCOMP3PREFIX?= CCOMP4PREFIX?= ``` -The `PREFIX` are the prefixes to add to the .s, .o, etc.. You should be careful that if a FLAGS is set, then the according PREFIX should be set as well. +The `PREFIX` are the prefixes to add to the secondary produced files (assembly, object, executable, ..). You should be careful that if a `FLAGS` is set, then the according `PREFIX` should be set as well. -Assembly files will be generated in `asm/`, objects in `obj/`, binaries in `bin/` and outputs in `out/`. +Assembly files are generated in `asm/`, objects in `obj/`, binaries in `bin/` and outputs in `out/`. -To compile and execute all the benches : `make` while in the `monniaux` directory (without any `-j` flag). +To compile and execute all the benches : `make` while in the `monniaux` directory (without any `-j` flag). Doing so will compile CompCert, install it, and then proceed to execute each bench. To compile and/or execute a single bench, `cd` to the bench directory, then: - `make` for compiling the bench - `make run` for running it -You can use `-j` flag when in a single bench directory +You can use `-j` flag when in a single bench directory. + +## Individual scripts + +If you want to run the building and running scripts individually without having to use the `Makefile` from `test/monniaux`, you can run the `build_benches.sh` script which builds each bench using all the available cores on your machine. + +Once the benches are built, you can then run `run_benches.sh file.csv` where `file.csv` is where you want to store the timings of the benchmarks. `run_benches.sh` also uses all the available cores of your machine. + +## Adding timings to a benchmark + +If you just add a benchmark without any timing function, the resulting `measures.csv` file will be empty for lack of timing output. + +TODO - how to add timings -- cgit From 5dcd78a4382992e92955ec0614fc2f5c4f80c429 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 26 Nov 2019 17:15:44 +0100 Subject: Added dwarf register numbers for aarch64 --- aarch64/Asmexpand.ml | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index ab155e9c..55922e9e 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -408,13 +408,28 @@ let expand_instruction instr = | _ -> emit instr -let int_reg_to_dwarf r = 0 (* TODO *) - -let float_reg_to_dwarf r = 0 (* TODO *) +let int_reg_to_dwarf = function + | X0 -> 0 | X1 -> 1 | X2 -> 2 | X3 -> 3 | X4 -> 4 + | X5 -> 5 | X6 -> 6 | X7 -> 7 | X8 -> 8 | X9 -> 9 + | X10 -> 10 | X11 -> 11 | X12 -> 12 | X13 -> 13 | X14 -> 14 + | X15 -> 15 | X16 -> 16 | X17 -> 17 | X18 -> 18 | X19 -> 19 + | X20 -> 20 | X21 -> 21 | X22 -> 22 | X23 -> 23 | X24 -> 24 + | X25 -> 25 | X26 -> 26 | X27 -> 27 | X28 -> 28 | X29 -> 29 + | X30 -> 30 + +let float_reg_to_dwarf = function + | D0 -> 64 | D1 -> 65 | D2 -> 66 | D3 -> 67 | D4 -> 68 + | D5 -> 69 | D6 -> 70 | D7 -> 71 | D8 -> 72 | D9 -> 73 + | D10 -> 74 | D11 -> 75 | D12 -> 76 | D13 -> 77 | D14 -> 78 + | D15 -> 79 | D16 -> 80 | D17 -> 81 | D18 -> 82 | D19 -> 83 + | D20 -> 84 | D21 -> 85 | D22 -> 86 | D23 -> 87 | D24 -> 88 + | D25 -> 89 | D26 -> 90 | D27 -> 91 | D28 -> 92 | D29 -> 93 + | D30 -> 94 | D31 -> 95 let preg_to_dwarf = function | IR r -> int_reg_to_dwarf r | FR r -> float_reg_to_dwarf r + | SP -> 31 | _ -> assert false let expand_function id fn = -- cgit From a99406bbd9c01dc04e79b14681a254fe22c9d424 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 28 Nov 2019 17:00:27 +0100 Subject: Fix for AArch64 alignment problem (#206) In addressing modes for load and store instructions, the offset must be a multiple of the memory size being accessed. When accessing global variables, this may not be the case if the alignment of the variable is less than its size. Errors occur at link time. This PR extends the check for a representable offset for the addressing of global variables to also check whether the variable is correctly aligned. Only if both conditions are met can we generate the short sequence Padrp / ADadr. Otherwise we go through the generic loadsymbol sequence. --- aarch64/Asmgen.v | 7 ++++++- aarch64/Asmgenproof1.v | 2 +- aarch64/extractionMachdep.v | 1 + cfrontend/C2C.ml | 5 +++++ 4 files changed, 13 insertions(+), 2 deletions(-) diff --git a/aarch64/Asmgen.v b/aarch64/Asmgen.v index 1c0e41a1..875f3fd1 100644 --- a/aarch64/Asmgen.v +++ b/aarch64/Asmgen.v @@ -20,6 +20,11 @@ Local Open Scope string_scope. Local Open Scope list_scope. Local Open Scope error_monad_scope. +(** Alignment check for symbols *) + +Parameter symbol_is_aligned : ident -> Z -> bool. +(** [symbol_is_aligned id sz] checks whether the symbol [id] is [sz] aligned *) + (** Extracting integer or float registers. *) Definition ireg_of (r: mreg) : res ireg := @@ -942,7 +947,7 @@ Definition transl_addressing (sz: Z) (addr: Op.addressing) (args: list mreg) (insn (ADimm X16 Int64.zero) :: k)) | Aglobal id ofs, nil => assertion (negb (Archi.pic_code tt)); - if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero + if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz then OK (Padrp X16 id ofs :: insn (ADadr X16 id ofs) :: k) else OK (loadsymbol X16 id ofs (insn (ADimm X16 Int64.zero) :: k)) | Ainstack ofs, nil => diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 663ee50b..6d44bcc8 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -1592,7 +1592,7 @@ Proof. simpl; rewrite Int64.add_zero; auto. intros. apply C; eauto with asmgen. - (* Aglobal *) - destruct (Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero); inv TR. + destruct (Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz); inv TR. + econstructor; econstructor; split. apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. split. simpl. Simpl. rewrite symbol_high_low. simpl in EV. congruence. diff --git a/aarch64/extractionMachdep.v b/aarch64/extractionMachdep.v index a447d12f..e82056e2 100644 --- a/aarch64/extractionMachdep.v +++ b/aarch64/extractionMachdep.v @@ -21,3 +21,4 @@ Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) (* Asm *) Extract Constant Asm.symbol_low => "fun _ _ _ -> assert false". Extract Constant Asm.symbol_high => "fun _ _ _ -> assert false". +Extract Constant Asmgen.symbol_is_aligned => "C2C.atom_is_aligned". diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index c1dfa9f4..9ae7bbd9 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -61,6 +61,11 @@ let atom_alignof a = with Not_found -> None +let atom_is_aligned a sz = + match atom_alignof a with + | None -> false + | Some align -> align mod (Z.to_int sz) = 0 + let atom_sections a = try (Hashtbl.find decl_atom a).a_sections -- cgit From eaea751c200213e0f86cf51c1fe93b7ba09c4227 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 2 Dec 2019 11:24:23 +0100 Subject: Adding info on how to add timings to a benchmark --- test/monniaux/README.md | 70 +++++++++++++++++++++++++++++++------------------ 1 file changed, 44 insertions(+), 26 deletions(-) diff --git a/test/monniaux/README.md b/test/monniaux/README.md index 67062e24..14b062da 100644 --- a/test/monniaux/README.md +++ b/test/monniaux/README.md @@ -38,31 +38,30 @@ prints something of the form `c3 cycles: 44131`. - `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: -``` -# You can define up to GCC4FLAGS and CCOMP4FLAGS -GCC0FLAGS?= -GCC1FLAGS?=$(ALL_GCCFLAGS) -O1 -GCC2FLAGS?=$(ALL_GCCFLAGS) -O2 -GCC3FLAGS?=$(ALL_GCCFLAGS) -O3 -GCC4FLAGS?= -CCOMP0FLAGS?= -CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -fno-postpass -CCOMP2FLAGS?=$(ALL_CCOMPFLAGS) -CCOMP3FLAGS?= -CCOMP4FLAGS?= - -# Prefix names -GCC0PREFIX?= -GCC1PREFIX?=.gcc.o1 -GCC2PREFIX?=.gcc.o2 -GCC3PREFIX?=.gcc.o3 -GCC4PREFIX?= -CCOMP0PREFIX?= -CCOMP1PREFIX?=.ccomp.o1 -CCOMP2PREFIX?=.ccomp.o2 -CCOMP3PREFIX?= -CCOMP4PREFIX?= -``` + + # You can define up to GCC4FLAGS and CCOMP4FLAGS + GCC0FLAGS?= + GCC1FLAGS?=$(ALL_GCCFLAGS) -O1 + GCC2FLAGS?=$(ALL_GCCFLAGS) -O2 + GCC3FLAGS?=$(ALL_GCCFLAGS) -O3 + GCC4FLAGS?= + CCOMP0FLAGS?= + CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -fno-postpass + CCOMP2FLAGS?=$(ALL_CCOMPFLAGS) + CCOMP3FLAGS?= + CCOMP4FLAGS?= + + # Prefix names + GCC0PREFIX?= + GCC1PREFIX?=.gcc.o1 + GCC2PREFIX?=.gcc.o2 + GCC3PREFIX?=.gcc.o3 + GCC4PREFIX?= + CCOMP0PREFIX?= + CCOMP1PREFIX?=.ccomp.o1 + CCOMP2PREFIX?=.ccomp.o2 + CCOMP3PREFIX?= + CCOMP4PREFIX?= The `PREFIX` are the prefixes to add to the secondary produced files (assembly, object, executable, ..). You should be careful that if a `FLAGS` is set, then the according `PREFIX` should be set as well. @@ -86,4 +85,23 @@ Once the benches are built, you can then run `run_benches.sh file.csv` where `fi If you just add a benchmark without any timing function, the resulting `measures.csv` file will be empty for lack of timing output. -TODO - how to add timings +To add a timing, you must use the functions whose prototypes are in `clock.h` + + #include "../clock.h" + /* ... */ + clock_prepare(); + /* ... */ + clock_start(); + /* .. computations .. */ + clock_stop(); + /* ... */ + print_total_clock(); // print to stdout + printerr_total_clock(); // print to stderr + +If the benchmark doesn't use `stdout` in a binary way you can use `print_total_clock()`. However, some benchmarks like `jpeg-6b` print their binary content to `stdout`, which then messes up the `grep` command when attempting to use it to extract the cycles from `stdout`. + +The solution is then to use `printerr_total_clock()` which will print the cycles to `stderr`, and use `EXECUTE_ARGS` ressembling this: + + EXECUTE_ARGS=-dct int -outfile __BASE__.jpg testimg.ppm 2> __BASE__.out + +`__BASE__` is a macro that gets expanded to the base name - that is, the `TARGET` concatenated with one of the `GCCiPREFIX` or `CCOMPiPREFIX`. For instance, in `jpeg-6b`, `__BASE__` could be `jpeg-6b.ccomp.o2`. -- cgit From 3074390115febf1fad3ee094edc59f36e496a6a4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 2 Dec 2019 15:58:25 +0100 Subject: Fixed trace selection - for now, it only prints them, and the chosen paths are random --- backend/Duplicateaux.ml | 49 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index d0df9b23..e76cd125 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -74,21 +74,24 @@ let bfs code entrypoint = in node_bfs @ (bfs_list code ln) in bfs_list code [entrypoint] +let ptree_get_some n ptree = get_some @@ PTree.get n ptree + let rec select_unvisited_node is_visited = function | [] -> failwith "Empty list" -| n :: ln -> if (get_some @@ PTree.get n is_visited) then n else select_unvisited_node is_visited ln +| n :: ln -> if not (ptree_get_some n is_visited) then n else select_unvisited_node is_visited ln -let best_successor_of node code = +let best_successor_of node code is_visited = match (PTree.get node code) with | None -> failwith "No such node in the code" | Some ti -> match ti with | Tleaf _ -> None - | Tnext (n,_) -> Some n + | Tnext (n,_) -> if not (ptree_get_some n is_visited) then Some n + else None -let best_predecessor_of node predecessors order = +let best_predecessor_of node predecessors 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) order) + | Some lp -> try Some (List.find (fun n -> (List.mem n lp) && (not (ptree_get_some n is_visited))) order) with Not_found -> None let get_predecessors code = @@ -107,24 +110,25 @@ let get_predecessors code = !preds end -(* Algorithm from Chang and Hwu 1988 +(* Algorithm mostly inspired from Chang and Hwu 1988 * "Trace Selection for Compiling Large C Application Programs to Microcode" *) -let select_trace code entrypoint = +let select_traces code entrypoint = let order = bfs code entrypoint in let predecessors = get_predecessors code in - let trace = ref [] in + let traces = ref [] in let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *) 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 let current = ref seed in begin is_visited := PTree.set seed true !is_visited; (* mark seed visited *) let quit_loop = ref false in begin while not !quit_loop do - let s = best_successor_of !current code in + let s = best_successor_of !current code !is_visited in match s with | None -> quit_loop := true (* if (s==0) exit loop *) | Some succ -> begin - trace := succ :: !trace; (* FIXME - reverse append *) + trace := !trace @ [succ]; is_visited := PTree.set succ true !is_visited; (* mark s visited *) current := succ end @@ -132,7 +136,7 @@ let select_trace code entrypoint = current := seed; quit_loop := false; while not !quit_loop do - let s = best_predecessor_of !current predecessors order in + let s = best_predecessor_of !current predecessors order !is_visited in match s with | None -> quit_loop := true (* if (s==0) exit loop *) | Some pred -> begin @@ -140,11 +144,12 @@ let select_trace code entrypoint = is_visited := PTree.set pred true !is_visited; (* mark s visited *) current := pred end - done + done; + traces := !trace :: !traces; end end done; - !trace + !traces end (* for debugging *) @@ -153,9 +158,19 @@ let print_trace trace = | [] -> () | n::ln -> (Printf.printf "%d " (P.to_int n); f ln) in begin - Printf.printf "Trace: ["; + Printf.printf "["; f trace; - Printf.printf "]\n" + Printf.printf "]" + end + +let print_traces traces = + let rec f = function + | [] -> () + | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt + in begin + Printf.printf "Traces: {"; + f traces; + Printf.printf "}\n"; end let rec make_identity_ptree_rec = function @@ -167,8 +182,8 @@ let make_identity_ptree f = make_identity_ptree_rec (PTree.elements (fn_code f)) (* For now, identity function *) let duplicate_aux f = let pTreeId = make_identity_ptree f in - let trace = select_trace (to_ttl_code @@ fn_code f) (fn_entrypoint f) + let traces = select_traces (to_ttl_code @@ fn_code f) (fn_entrypoint f) in begin - print_trace trace; + print_traces traces; (((fn_code f), (fn_entrypoint f)), pTreeId) end -- cgit From 553714035fc08f9b145b89b3dd7c455f06e917df Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Dec 2019 21:39:20 +0100 Subject: finish merge --- backend/Duplicate.v | 24 ++++++++++++---------- backend/Duplicateproof.v | 20 ++++++++++++++++-- backend/Lineartyping.v | 2 +- driver/Compiler.v | 50 +++++++++++++++++---------------------------- mppa_k1c/Asmblockgen.v | 2 +- mppa_k1c/Asmblockgenproof.v | 29 +++++++++++++++++--------- 6 files changed, 71 insertions(+), 56 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 3ad37c83..46f0855d 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -72,17 +72,19 @@ Definition verify_match_inst dupmap inst tinst := else Error(msg "Different operations in Iop") | _ => Error(msg "verify_match_inst Inop") end - | Iload m a lr r n => match tinst with - | Iload m' a' lr' r' n' => + | Iload tm m a lr r n => match tinst with + | Iload tm' m' a' lr' r' n' => do u <- verify_is_copy dupmap n n'; - if (chunk_eq m m') then - if (eq_addressing a a') then - if (list_eq_dec Pos.eq_dec lr lr') then - if (Pos.eq_dec r r') then OK tt - else Error (msg "Different r in Iload") - else Error (msg "Different lr in Iload") - else Error (msg "Different addressing in Iload") - else Error (msg "Different mchunk in Iload") + if (trapping_mode_eq tm tm') then + if (chunk_eq m m') then + if (eq_addressing a a') then + if (list_eq_dec Pos.eq_dec lr lr') then + if (Pos.eq_dec r r') then OK tt + else Error (msg "Different r in Iload") + else Error (msg "Different lr in Iload") + else Error (msg "Different addressing in Iload") + else Error (msg "Different mchunk in Iload") + else Error (msg "Different trapping_mode in Iload") | _ => Error (msg "verify_match_inst Iload") end | Istore m a lr r n => match tinst with @@ -195,4 +197,4 @@ Definition transf_fundef (f: fundef) : res fundef := transf_partial_fundef transf_function f. Definition transf_program (p: program) : res program := - transform_partial_program transf_fundef p. \ No newline at end of file + transform_partial_program transf_fundef p. diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 39b7a353..e66a1068 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -13,8 +13,8 @@ Inductive match_inst (dupmap: PTree.t node): instruction -> instruction -> Prop dupmap!n' = (Some n) -> match_inst dupmap (Inop n) (Inop n') | match_inst_op: forall n n' op lr r, dupmap!n' = (Some n) -> match_inst dupmap (Iop op lr r n) (Iop op lr r n') - | match_inst_load: forall n n' m a lr r, - dupmap!n' = (Some n) -> match_inst dupmap (Iload m a lr r n) (Iload m a lr r n') + | match_inst_load: forall n n' tm m a lr r, + dupmap!n' = (Some n) -> match_inst dupmap (Iload tm m a lr r n) (Iload tm m a lr r n') | match_inst_store: forall n n' m a lr r, dupmap!n' = (Some n) -> match_inst dupmap (Istore m a lr r n) (Istore m a lr r n') | match_inst_call: forall n n' s ri lr r, @@ -137,6 +137,7 @@ Proof. (* Iload *) - destruct i'; try (inversion H; fail). monadInv H. destruct x. eapply verify_is_copy_correct in EQ. + destruct (trapping_mode_eq _ _); try discriminate. destruct (chunk_eq _ _); try discriminate. destruct (eq_addressing _ _); try discriminate. destruct (list_eq_dec _ _ _); try discriminate. @@ -393,6 +394,21 @@ Proof. eexists. split. + eapply exec_Iload; eauto. erewrite eval_addressing_preserved; eauto. + econstructor; eauto. +(* Iload notrap1 *) + - eapply dupmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Iload_notrap1; eauto. erewrite eval_addressing_preserved; eauto. + + econstructor; eauto. +(* Iload notrap2 *) + - eapply dupmap_correct in DUPLIC; eauto. + destruct DUPLIC as (i' & H2 & H3). inv H3. + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Iload_notrap2; eauto. erewrite eval_addressing_preserved; eauto. + + econstructor; eauto. + (* Istore *) - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 994d2652..3fe61470 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -328,7 +328,7 @@ Local Opaque mreg_type. change ty_res with (snd (ty_args, ty_res)). rewrite <- TYOP. eapply type_of_operation_sound; eauto. red; intros; subst op. simpl in ISMOVE. destruct args; try discriminate. destruct args; discriminate. - apply wt_undef_regs; auto. + (* no longer needed apply wt_undef_regs; auto. *) - (* load *) simpl in *; InvBooleans. econstructor; eauto. diff --git a/driver/Compiler.v b/driver/Compiler.v index f948d595..72db86e9 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -141,8 +141,9 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 8) @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program - @@@ time "Unused globals" Unusedglob.transform_program @@ print (print_RTL 9) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 10) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -250,8 +251,8 @@ 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_redundancy Deadcodeproof.match_prog) - ::: mkpass Unusedglobproof.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 @@ -290,18 +291,19 @@ 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 (p9 := Renumber.transf_program p8) in *. - set (p10 := total_if optim_constprop Constprop.transf_program p9) in *. - set (p11 := total_if optim_constprop Renumber.transf_program p10) in *. - destruct (partial_if optim_CSE CSE.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate. - destruct (partial_if optim_redundancy Deadcode.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. - destruct (Unusedglob.transform_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. + destruct (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 *. + destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. + destruct (partial_if optim_redundancy Deadcode.transf_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. - destruct (Allocation.transf_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. - set (p16 := Tunneling.tunnel_program p15) in *. - destruct (Linearize.transf_program p16) as [p17|e] eqn:P17; simpl in T; try discriminate. - set (p18 := CleanupLabels.transf_program p17) in *. - destruct (partial_if debug Debugvar.transf_program p18) as [p19|e] eqn:P19; simpl in T; try discriminate. - destruct (Stacking.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. + 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. @@ -312,25 +314,12 @@ Proof. 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. -<<<<<<< HEAD - exists p10; split. apply total_if_match. apply Constpropproof.transf_program_match. - exists p11; split. apply total_if_match. apply Renumberproof.transf_program_match. - exists p12; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. - exists p13; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. - exists p14; split. apply Unusedglobproof.transf_program_match; auto. - exists p14bis; split. apply total_if_match. apply Allnontrapproof.transf_program_match. - exists p15; split. apply Allocproof.transf_program_match; auto. - exists p16; split. apply Tunnelingproof.transf_program_match. - exists p17; split. apply Linearizeproof.transf_program_match; auto. - exists p18; split. apply CleanupLabelsproof.transf_program_match; auto. - exists p19; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match. - exists p20; split. apply Stackingproof.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. exists p13; split. eapply partial_if_match; eauto. apply CSEproof.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. @@ -338,7 +327,6 @@ Proof. 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. ->>>>>>> origin/mppa-work exists tp; split. apply Asmgenproof.transf_program_match; auto. reflexivity. Qed. @@ -390,7 +378,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 p22)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p23)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -418,10 +406,10 @@ Ltac DestructM := eapply match_if_simulation. eassumption. exact CSEproof.transf_program_correct. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Unusedglobproof.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. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 5825fd04..50637723 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1116,7 +1116,7 @@ Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := | MBsetstack src ofs ty => before | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) | MBop op args res => before && negb (mreg_eq res MFP) - | MBload chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst MFP) | MBstore chunk addr args res => before end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index cdbaf16a..b3e0ee23 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1203,14 +1203,18 @@ Local Transparent destroyed_by_op. exists rs2, m1, ll. eexists. eexists. split. instantiate (1 := x). eauto. repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. + eapply basics_to_code_app; eauto. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. + simpl in EQ. assumption. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. } { exploit transl_load_correct_notrap2; eauto. @@ -1226,10 +1230,15 @@ Local Transparent destroyed_by_op. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. (* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. } - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. -- cgit From ec49c7b8bd4502c380b88c78baa674000db109fd Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 3 Dec 2019 13:01:51 +0100 Subject: Allow Coq 8.10.2. --- configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure b/configure index 8604a1d9..b964c124 100755 --- a/configure +++ b/configure @@ -530,7 +530,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.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1) + 8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1|8.10.2) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" -- cgit From 98764278b804517f733982071da37769816a4833 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Dec 2019 15:12:09 +0100 Subject: Converting Asm.v and Asmblockgenproof.v back to Unix format --- mppa_k1c/Asm.v | 1506 +++++++++---------- mppa_k1c/Asmblockgenproof.v | 3346 +++++++++++++++++++++---------------------- 2 files changed, 2426 insertions(+), 2426 deletions(-) diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e37176ef..189e0c76 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,753 +1,753 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) - -(** * Abstract syntax for K1c textual assembly language. - - Each emittable instruction is defined here. ';;' is also defined as an instruction. - The goal of this representation is to stay compatible with the rest of the generic backend of CompCert - We define [unfold : list bblock -> list instruction] - An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] - [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import ExtValues. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Import Asmvliw. -Require Import Linking. -Require Import Errors. - -(** Definitions for OCaml code *) -Definition label := positive. -Definition preg := preg. - -Inductive addressing : Type := - | AOff (ofs: offset) - | AReg (ro: ireg) - | ARegXS (ro: ireg) -. - -(** Syntax *) -Inductive instruction : Type := - (** pseudo instructions *) - | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) - | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Plabel (lbl: label) (**r define a code label *) - | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction (**r built-in function (pseudo) *) - | Psemi (**r semi colon separating bundles *) - | Pnop (**r instruction that does nothing *) - - (** Control flow instructions *) - | Pget (rd: ireg) (rs: preg) (**r get system register *) - | Pset (rd: preg) (rs: ireg) (**r set system register *) - | Pret (**r return *) - | Pcall (l: label) (**r function call *) - | Picall (rs: ireg) (**r function call on register *) - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pigoto (rs: ireg) (**r goto from register *) - | Pj_l (l: label) (**r jump to label *) - | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) - | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) - | Pjumptable (r: ireg) (labels: list label) - - (* For builtins *) - | Ploopdo (count: ireg) (loopend: label) - | Pgetn (n: int) (dst: ireg) - | Psetn (n: int) (src: ireg) - | Pwfxl (n: int) (src: ireg) - | Pwfxm (n: int) (src: ireg) - | Pldu (dst: ireg) (addr: ireg) - | Plbzu (dst: ireg) (addr: ireg) - | Plhzu (dst: ireg) (addr: ireg) - | Plwzu (dst: ireg) (addr: ireg) - | Pawait - | Psleep - | Pstop - | Pbarrier - | Pfence - | Pdinval - | Pdinvall (addr: ireg) - | Pdtouchl (addr: ireg) - | Piinval - | Piinvals (addr: ireg) - | Pitouchl (addr: ireg) - | Pdzerol (addr: ireg) -(*| Pafaddd (addr: ireg) (incr_res: ireg) - | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) - | Palclrd (dst: ireg) (addr: ireg) - | Palclrw (dst: ireg) (addr: ireg) - | Pclzll (rd rs: ireg) - | Pstsud (rd rs1 rs2: ireg) - - (** Loads **) - | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) - | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) - | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) - | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) - | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) - | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) - | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) - | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) - | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) - | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) - | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) - | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) - - (** Stores **) - | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) - | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) - | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) - | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) - | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) - | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) - - | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - - (** Arith RR *) - | Pmv (rd rs: ireg) (**r register move *) - | Pnegw (rd rs: ireg) (**r negate word *) - | Pnegl (rd rs: ireg) (**r negate long *) - | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) - | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) - | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) - - | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - - | Pfabsd (rd rs: ireg) (**r float absolute double *) - | Pfabsw (rd rs: ireg) (**r float absolute word *) - | Pfnegd (rd rs: ireg) (**r float negate double *) - | Pfnegw (rd rs: ireg) (**r float negate word *) - | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) - | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) - | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) - | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) - | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) - | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) - | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) - | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) - | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) - | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) - | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) - | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) - - (** Arith RI32 *) - | Pmake (rd: ireg) (imm: int) (**r load immediate *) - - (** Arith RI64 *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) - - (** Arith RF32 *) - | Pmakefs (rd: ireg) (imm: float32) - - (** Arith RF64 *) - | Pmakef (rd: ireg) (imm: float) - - (** Arith RRR *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) - | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) - | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) - | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) - - | Paddw (rd rs1 rs2: ireg) (**r add word *) - | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Psubw (rd rs1 rs2: ireg) (**r sub word *) - | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Pmulw (rd rs1 rs2: ireg) (**r mul word *) - | Pandw (rd rs1 rs2: ireg) (**r and word *) - | Pnandw (rd rs1 rs2: ireg) (**r nand word *) - | Porw (rd rs1 rs2: ireg) (**r or word *) - | Pnorw (rd rs1 rs2: ireg) (**r nor word *) - | Pxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pandnw (rd rs1 rs2: ireg) (**r andn word *) - | Pornw (rd rs1 rs2: ireg) (**r orn word *) - | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) - | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) - | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) - | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) - | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) - | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) - | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) - | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) - - | Paddl (rd rs1 rs2: ireg) (**r add long *) - | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) - | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) - | Pandl (rd rs1 rs2: ireg) (**r and long *) - | Pnandl (rd rs1 rs2: ireg) (**r nand long *) - | Porl (rd rs1 rs2: ireg) (**r or long *) - | Pnorl (rd rs1 rs2: ireg) (**r nor long *) - | Pxorl (rd rs1 rs2: ireg) (**r xor long *) - | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) - | Pandnl (rd rs1 rs2: ireg) (**r andn long *) - | Pornl (rd rs1 rs2: ireg) (**r orn long *) - | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) - | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) - | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) - | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) - | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) - | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) - | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) - - | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) - | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) - | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) - | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) - | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) - | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) - | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) - | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) - | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) - | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) - | Pfinvw (rd rs1: ireg) (**r Float invert word *) - - (** Arith RRI32 *) - | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) - - | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) - | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) - | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) - | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) - | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) - | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) - | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) - | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) - | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) - | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) - | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) - | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) - | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) - | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) - | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) - | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) - | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) - | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) - | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) - - (** Arith RRI64 *) - | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) - | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) - | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) - | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) - | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) - | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) - | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) - | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) - | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) - | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) - | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) -. - -(** Correspondance between Asmblock and Asm *) - -Definition control_to_instruction (c: control) := - match c with - | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res - | PCtlFlow Asmvliw.Pret => Pret - | PCtlFlow (Asmvliw.Pcall l) => Pcall l - | PCtlFlow (Asmvliw.Picall r) => Picall r - | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l - | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l - | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l - | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l - | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l - | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label - end. - -Definition basic_to_instruction (b: basic) := - match b with - (** Special basics *) - | Asmvliw.Pget rd rs => Pget rd rs - | Asmvliw.Pset rd rs => Pset rd rs - | Asmvliw.Pnop => Pnop - | Asmvliw.Pallocframe sz pos => Pallocframe sz pos - | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos - - (** PArith basics *) - (* R *) - | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs - - (* RR *) - | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs - | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs - | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs - | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs - | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs - | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs - | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start - | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start - | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start - | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start - | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs - | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs - | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs - | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs - | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs - | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs - | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs - | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs - | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs - | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs - | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs - | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs - | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs - | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs - | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs - - (* RI32 *) - | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm - - (* RI64 *) - | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm - - (* RF32 *) - | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm - - (* RF64 *) - | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm - - (* RRR *) - | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 - | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 - | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 - | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 - | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 - | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 - | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 - | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 - | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 - | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 - | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 - | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 - - | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 - | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 - | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 - | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 - | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 - | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 - | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 - | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 - | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 - | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 - | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 - - | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 - | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 - | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 - | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 - - (* RRI32 *) - | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm - | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm - | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm - | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm - | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm - | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm - | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm - | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm - | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm - | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm - | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm - | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm - | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm - | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm - | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm - | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm - | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm - | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm - | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm - | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm - | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm - | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm - | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm - - (* RRI64 *) - | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm - | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm - | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm - | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm - | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm - | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm - | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm - | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm - | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm - | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm - | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm - | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm - | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm - | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm - - (** ARRR *) - | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 - | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 - - (** ARR *) - | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start - | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start - - (** ARRI32 *) - | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm - - (** ARRI64 *) - | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm - (** Load *) - | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) - - | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) - | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) - - | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) - - | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) - - (** Store *) - | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) - - | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) - | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) - - | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) - - | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) - | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) - end. - -Section RELSEM. - -Definition code := list instruction. - -Fixpoint unfold_label (ll: list label) := - match ll with - | nil => nil - | l :: ll => Plabel l :: unfold_label ll - end. - -Fixpoint unfold_body (lb: list basic) := - match lb with - | nil => nil - | b :: lb => basic_to_instruction b :: unfold_body lb - end. - -Definition unfold_exit (oc: option control) := - match oc with - | None => nil - | Some c => control_to_instruction c :: nil - end. - -Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ - (match (body b), (exit b) with - | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => - unfold_body bo - | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil - end). - -Fixpoint unfold (lb: bblocks) := - match lb with - | nil => nil - | b :: lb => (unfold_bblock b) ++ unfold lb - end. - -Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; - correct: unfold fn_blocks = fn_code }. - -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -Definition genv := Genv.t fundef unit. - -Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). - -Definition fundef_proj (fu: fundef) : Asmvliw.fundef := - match fu with - | Internal f => Internal (function_proj f) - | External ef => External ef - end. - -Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := - match gd with - | Gfun f => Gfun (fundef_proj f) - | Gvar gu => Gvar gu - end. - -Program Definition genv_trans (ge: genv) : Asmvliw.genv := - {| Genv.genv_public := Genv.genv_public ge; - Genv.genv_symb := Genv.genv_symb ge; - Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); - Genv.genv_next := Genv.genv_next ge |}. -Next Obligation. - destruct ge. simpl in *. eauto. -Qed. Next Obligation. - destruct ge; simpl in *. - rewrite PTree.gmap1 in H. - destruct (genv_defs ! b) eqn:GEN. - - eauto. - - discriminate. -Qed. Next Obligation. - destruct ge; simpl in *. - eauto. -Qed. - -Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) - : list (ident * globdef Asmvliw.fundef unit) := - match l with - | nil => nil - | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l - end. - -Definition program_proj (p: program) : Asmvliw.program := - {| prog_defs := prog_defs_proj (prog_defs p); - prog_public := prog_public p; - prog_main := prog_main p - |}. - -End RELSEM. - -Definition semantics (p: program) := Asmvliw.semantics (program_proj p). - -(** Determinacy of the [Asm] semantics. *) - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. - intros. apply semantics_determinate. -Qed. - -(** transf_program *) - -Program Definition transf_function (f: Asmvliw.function) : function := - {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; - fn_code := unfold (Asmvliw.fn_blocks f) |}. - -Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. -Proof. - intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. -Qed. - -Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. - -Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. -Proof. - intros f. destruct f as [f|e]; simpl; auto. - rewrite transf_function_proj. auto. -Qed. - -Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. - -Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), - prog_defs p1 = prog_defs p2 -> - prog_public p1 = prog_public p2 -> - prog_main p1 = prog_main p2 -> - p1 = p2. -Proof. - intros. destruct p1. destruct p2. simpl in *. subst. auto. -Qed. - -Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. -Proof. - intros p. destruct p as [defs pub main]. unfold program_proj. simpl. - apply program_equals; simpl; auto. - induction defs. - - simpl; auto. - - simpl. rewrite IHdefs. - destruct a as [id gd]; simpl. - destruct gd as [f|v]; simpl; auto. - rewrite transf_fundef_proj. auto. -Qed. - -Definition match_prog (p: Asmvliw.program) (tp: program) := - match_program (fun _ f tf => tf = transf_fundef f) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = tp -> match_prog p tp. -Proof. - intros. rewrite <- H. eapply match_transform_program; eauto. -Qed. - -Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. -Proof. - intros. congruence. -Qed. - -Lemma match_program_transf: - forall p tp, match_prog p tp -> transf_program p = tp. -Proof. - intros p tp H. inversion_clear H. inv H1. - destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. - subst. unfold transf_program. unfold transform_program. simpl. - apply program_equals; simpl; auto. - induction H0; simpl; auto. - rewrite IHlist_forall2. apply cons_extract. - destruct a1 as [ida gda]. destruct b1 as [idb gdb]. - simpl in *. - inv H. inv H2. - - simpl in *. subst. auto. - - simpl in *. subst. inv H. auto. -Qed. - -Section PRESERVATION. - -Variable prog: Asmvliw.program. -Variable tprog: program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Definition match_states (s1 s2: state) := s1 = s2. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - - -Theorem transf_program_correct: - forward_simulation (Asmvliw.semantics prog) (semantics tprog). -Proof. - pose proof (match_program_transf prog tprog TRANSF) as TR. - subst. unfold semantics. rewrite transf_program_proj. - - eapply forward_simulation_step with (match_states := match_states); simpl; auto. - - intros. exists s1. split; auto. congruence. - - intros. inv H. auto. - - intros. exists s1'. inv H0. split; auto. congruence. -Qed. - -End PRESERVATION. +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** * Abstract syntax for K1c textual assembly language. + + Each emittable instruction is defined here. ';;' is also defined as an instruction. + The goal of this representation is to stay compatible with the rest of the generic backend of CompCert + We define [unfold : list bblock -> list instruction] + An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] + [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Asmvliw. +Require Import Linking. +Require Import Errors. + +(** Definitions for OCaml code *) +Definition label := positive. +Definition preg := preg. + +Inductive addressing : Type := + | AOff (ofs: offset) + | AReg (ro: ireg) + | ARegXS (ro: ireg) +. + +(** Syntax *) +Inductive instruction : Type := + (** pseudo instructions *) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Plabel (lbl: label) (**r define a code label *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Psemi (**r semi colon separating bundles *) + | Pnop (**r instruction that does nothing *) + + (** Control flow instructions *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (rs: ireg) (**r function call on register *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (rs: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) + | Pjumptable (r: ireg) (labels: list label) + + (* For builtins *) + | Ploopdo (count: ireg) (loopend: label) + | Pgetn (n: int) (dst: ireg) + | Psetn (n: int) (src: ireg) + | Pwfxl (n: int) (src: ireg) + | Pwfxm (n: int) (src: ireg) + | Pldu (dst: ireg) (addr: ireg) + | Plbzu (dst: ireg) (addr: ireg) + | Plhzu (dst: ireg) (addr: ireg) + | Plwzu (dst: ireg) (addr: ireg) + | Pawait + | Psleep + | Pstop + | Pbarrier + | Pfence + | Pdinval + | Pdinvall (addr: ireg) + | Pdtouchl (addr: ireg) + | Piinval + | Piinvals (addr: ireg) + | Pitouchl (addr: ireg) + | Pdzerol (addr: ireg) +(*| Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) + | Palclrd (dst: ireg) (addr: ireg) + | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) + + (** Loads **) + | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) + | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) + + (** Stores **) + | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) + | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) + | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + + | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + + (** Arith RR *) + | Pmv (rd rs: ireg) (**r register move *) + | Pnegw (rd rs: ireg) (**r negate word *) + | Pnegl (rd rs: ireg) (**r negate long *) + | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) + | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) + | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) + + | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + + | Pfabsd (rd rs: ireg) (**r float absolute double *) + | Pfabsw (rd rs: ireg) (**r float absolute word *) + | Pfnegd (rd rs: ireg) (**r float negate double *) + | Pfnegw (rd rs: ireg) (**r float negate word *) + | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) + | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) + | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) + | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) + | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) + | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) + | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) + | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) + | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) + | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) + | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) + | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) + + (** Arith RI32 *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + + (** Arith RI64 *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + + (** Arith RF32 *) + | Pmakefs (rd: ireg) (imm: float32) + + (** Arith RF64 *) + | Pmakef (rd: ireg) (imm: float) + + (** Arith RRR *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) + | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) + + | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Pmulw (rd rs1 rs2: ireg) (**r mul word *) + | Pandw (rd rs1 rs2: ireg) (**r and word *) + | Pnandw (rd rs1 rs2: ireg) (**r nand word *) + | Porw (rd rs1 rs2: ireg) (**r or word *) + | Pnorw (rd rs1 rs2: ireg) (**r nor word *) + | Pxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pandnw (rd rs1 rs2: ireg) (**r andn word *) + | Pornw (rd rs1 rs2: ireg) (**r orn word *) + | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) + | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) + | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) + | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) + | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) + | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) + | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) + + | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) + | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | Pandl (rd rs1 rs2: ireg) (**r and long *) + | Pnandl (rd rs1 rs2: ireg) (**r nand long *) + | Porl (rd rs1 rs2: ireg) (**r or long *) + | Pnorl (rd rs1 rs2: ireg) (**r nor long *) + | Pxorl (rd rs1 rs2: ireg) (**r xor long *) + | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) + | Pandnl (rd rs1 rs2: ireg) (**r andn long *) + | Pornl (rd rs1 rs2: ireg) (**r orn long *) + | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) + | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) + | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) + | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) + | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) + | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) + | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) + + | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) + | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) + | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) + | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) + | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) + | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) + | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) + | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) + | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) + | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) + | Pfinvw (rd rs1: ireg) (**r Float invert word *) + + (** Arith RRI32 *) + | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) + + | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) + | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) + | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) + | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) + | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) + | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) + | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) + | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) + | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) + | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) + | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) + | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) + | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) + | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) + | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) + + (** Arith RRI64 *) + | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) + | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) + | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) + | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) + | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) + | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) + | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) + | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) + | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) + | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) + | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) +. + +(** Correspondance between Asmblock and Asm *) + +Definition control_to_instruction (c: control) := + match c with + | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res + | PCtlFlow Asmvliw.Pret => Pret + | PCtlFlow (Asmvliw.Pcall l) => Pcall l + | PCtlFlow (Asmvliw.Picall r) => Picall r + | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l + | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l + | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l + | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l + | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l + | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label + end. + +Definition basic_to_instruction (b: basic) := + match b with + (** Special basics *) + | Asmvliw.Pget rd rs => Pget rd rs + | Asmvliw.Pset rd rs => Pset rd rs + | Asmvliw.Pnop => Pnop + | Asmvliw.Pallocframe sz pos => Pallocframe sz pos + | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos + + (** PArith basics *) + (* R *) + | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + + (* RR *) + | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs + | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs + | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs + | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs + | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs + | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs + | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start + | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start + | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start + | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start + | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs + | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs + | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs + | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs + | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs + | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs + | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs + | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs + | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs + | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs + | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs + + (* RI32 *) + | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm + + (* RI64 *) + | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm + + (* RF32 *) + | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm + + (* RF64 *) + | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm + + (* RRR *) + | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 + | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 + | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 + | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 + | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 + | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 + | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 + | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 + | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 + | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 + + | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 + | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 + | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 + | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 + | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 + | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 + | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 + | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 + | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 + + | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 + | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 + | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 + | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 + + (* RRI32 *) + | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm + | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm + | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm + | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm + | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm + | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm + | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm + | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm + | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm + | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm + | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm + | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm + | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm + | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm + | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm + | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm + | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm + | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm + + (* RRI64 *) + | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm + | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm + | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm + | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm + | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm + | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm + | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm + | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm + | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm + | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm + | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm + + (** ARRR *) + | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 + + (** ARR *) + | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start + | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start + + (** ARRI32 *) + | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm + + (** ARRI64 *) + | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm + (** Load *) + | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) + + | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) + | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) + + | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) + + | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) + + (** Store *) + | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) + + | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) + | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) + + | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) + + | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) + | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) + end. + +Section RELSEM. + +Definition code := list instruction. + +Fixpoint unfold_label (ll: list label) := + match ll with + | nil => nil + | l :: ll => Plabel l :: unfold_label ll + end. + +Fixpoint unfold_body (lb: list basic) := + match lb with + | nil => nil + | b :: lb => basic_to_instruction b :: unfold_body lb + end. + +Definition unfold_exit (oc: option control) := + match oc with + | None => nil + | Some c => control_to_instruction c :: nil + end. + +Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ + (match (body b), (exit b) with + | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => + unfold_body bo + | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil + end). + +Fixpoint unfold (lb: bblocks) := + match lb with + | nil => nil + | b :: lb => (unfold_bblock b) ++ unfold lb + end. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; + correct: unfold fn_blocks = fn_code }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). + +Definition fundef_proj (fu: fundef) : Asmvliw.fundef := + match fu with + | Internal f => Internal (function_proj f) + | External ef => External ef + end. + +Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := + match gd with + | Gfun f => Gfun (fundef_proj f) + | Gvar gu => Gvar gu + end. + +Program Definition genv_trans (ge: genv) : Asmvliw.genv := + {| Genv.genv_public := Genv.genv_public ge; + Genv.genv_symb := Genv.genv_symb ge; + Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); + Genv.genv_next := Genv.genv_next ge |}. +Next Obligation. + destruct ge. simpl in *. eauto. +Qed. Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gmap1 in H. + destruct (genv_defs ! b) eqn:GEN. + - eauto. + - discriminate. +Qed. Next Obligation. + destruct ge; simpl in *. + eauto. +Qed. + +Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) + : list (ident * globdef Asmvliw.fundef unit) := + match l with + | nil => nil + | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l + end. + +Definition program_proj (p: program) : Asmvliw.program := + {| prog_defs := prog_defs_proj (prog_defs p); + prog_public := prog_public p; + prog_main := prog_main p + |}. + +End RELSEM. + +Definition semantics (p: program) := Asmvliw.semantics (program_proj p). + +(** Determinacy of the [Asm] semantics. *) + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. + intros. apply semantics_determinate. +Qed. + +(** transf_program *) + +Program Definition transf_function (f: Asmvliw.function) : function := + {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; + fn_code := unfold (Asmvliw.fn_blocks f) |}. + +Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. +Proof. + intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. +Qed. + +Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. + +Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. +Proof. + intros f. destruct f as [f|e]; simpl; auto. + rewrite transf_function_proj. auto. +Qed. + +Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. + +Definition match_prog (p: Asmvliw.program) (tp: program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + +Section PRESERVATION. + +Variable prog: Asmvliw.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Definition match_states (s1 s2: state) := s1 = s2. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Theorem transf_program_correct: + forward_simulation (Asmvliw.semantics prog) (semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. + subst. unfold semantics. rewrite transf_program_proj. + + eapply forward_simulation_step with (match_states := match_states); simpl; auto. + - intros. exists s1. split; auto. congruence. + - intros. inv H. auto. + - intros. exists s1'. inv H0. split; auto. congruence. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index b3e0ee23..e130df45 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,274 +1,274 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for RISC-V generation: main proof. *) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. -Require Import Axioms. - -Module MB := Machblock. -Module AB := Asmvliw. - -Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Section PRESERVATION. - -Variable prog: Machblock.program. -Variable tprog: Asmvliw.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - omega. -Qed. - +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for RISC-V generation: main proof. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. +Require Import Axioms. + +Module MB := Machblock. +Module AB := Asmvliw. + +Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Machblock.program. +Variable tprog: Asmvliw.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) - -Lemma gen_bblocks_label: - forall hd bdy ex tbb tc, - gen_bblocks hd bdy ex = tbb::tc -> - header tbb = hd. -Proof. - intros until tc. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Lemma gen_bblocks_label2: - forall hd bdy ex tbb1 tbb2, - gen_bblocks hd bdy ex = tbb1::tbb2::nil -> - header tbb2 = nil. -Proof. - intros until tbb2. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - + +Lemma gen_bblocks_label: + forall hd bdy ex tbb tc, + gen_bblocks hd bdy ex = tbb::tc -> + header tbb = hd. +Proof. + intros until tc. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma gen_bblocks_label2: + forall hd bdy ex tbb1 tbb2, + gen_bblocks hd bdy ex = tbb1::tbb2::nil -> + header tbb2 = nil. +Proof. + intros until tbb2. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + Remark in_dec_transl: - forall lbl hd, - (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). -Proof. - intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. -Qed. - -Lemma transl_is_label: - forall lbl bb tbb f ep tc, - transl_block f bb ep = OK (tbb::tc) -> - is_label lbl tbb = MB.is_label lbl bb. -Proof. - intros until tc. intros TLB. - destruct tbb as [thd tbdy tex]; simpl in *. - monadInv TLB. - unfold is_label. simpl. - apply gen_bblocks_label in H0. simpl in H0. subst. - rewrite in_dec_transl. auto. -Qed. - -Lemma transl_is_label_false2: - forall lbl bb f ep tbb1 tbb2, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb2 = false. -Proof. - intros until tbb2. intros TLB. - destruct tbb2 as [thd tbdy tex]; simpl in *. - monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. - apply is_label_correct_false. simpl. auto. -Qed. - -Lemma transl_is_label2: - forall f bb ep tbb1 tbb2 lbl, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb1 = MB.is_label lbl bb - /\ is_label lbl tbb2 = false. -Proof. - intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. -Qed. - -Lemma transl_block_nonil: - forall f c ep tc, - transl_block f c ep = OK tc -> - tc <> nil. -Proof. - intros. monadInv H. unfold gen_bblocks. - destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. - all: discriminate. -Qed. - -Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, - ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). -Proof. - intros. intro. monadInv H. - unfold gen_bblocks in H0. - destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. - all: discriminate. -Qed. - -Lemma find_label_transl_false: - forall x f lbl bb ep x', - transl_block f bb ep = OK x -> - MB.is_label lbl bb = false -> - find_label lbl (x++x') = find_label lbl x'. -Proof. - intros until x'. intros TLB MBis; simpl; auto. - destruct x as [|x0 x1]; simpl; auto. - destruct x1 as [|x1 x2]; simpl; auto. - - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. - - destruct x2 as [|x2 x3]; simpl; auto. - + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. - erewrite transl_is_label_false2; eauto. - + apply transl_block_limit in TLB. destruct TLB. -Qed. - -Lemma transl_blocks_label: - forall lbl f c tc ep, - transl_blocks f c ep = OK tc -> - match MB.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. - destruct (MB.is_label lbl a) eqn:MBis. - - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } - simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. - rewrite ABis. - eexists. eexists. split; eauto. simpl transl_blocks. - assert (MB.header a <> nil). - { apply MB.is_label_correct_true in MBis. - destruct (MB.header a). contradiction. discriminate. } - destruct (MB.header a); try contradiction. - rewrite EQ. simpl. rewrite EQ1. simpl. auto. - - apply IHc in EQ1. destruct (MB.find_label lbl c). - + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. - erewrite find_label_transl_false; eauto. - + erewrite find_label_transl_false; eauto. -Qed. - -Lemma find_label_nil: - forall bb lbl c, - header bb = nil -> - find_label lbl (bb::c) = find_label lbl c. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. subst. - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { erewrite <- is_label_correct_false. simpl. auto. } - rewrite H. auto. -Qed. - + forall lbl hd, + (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). +Proof. + intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. +Qed. + +Lemma transl_is_label: + forall lbl bb tbb f ep tc, + transl_block f bb ep = OK (tbb::tc) -> + is_label lbl tbb = MB.is_label lbl bb. +Proof. + intros until tc. intros TLB. + destruct tbb as [thd tbdy tex]; simpl in *. + monadInv TLB. + unfold is_label. simpl. + apply gen_bblocks_label in H0. simpl in H0. subst. + rewrite in_dec_transl. auto. +Qed. + +Lemma transl_is_label_false2: + forall lbl bb f ep tbb1 tbb2, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb2 = false. +Proof. + intros until tbb2. intros TLB. + destruct tbb2 as [thd tbdy tex]; simpl in *. + monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. + apply is_label_correct_false. simpl. auto. +Qed. + +Lemma transl_is_label2: + forall f bb ep tbb1 tbb2 lbl, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb1 = MB.is_label lbl bb + /\ is_label lbl tbb2 = false. +Proof. + intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. +Qed. + +Lemma transl_block_nonil: + forall f c ep tc, + transl_block f c ep = OK tc -> + tc <> nil. +Proof. + intros. monadInv H. unfold gen_bblocks. + destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. + all: discriminate. +Qed. + +Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, + ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). +Proof. + intros. intro. monadInv H. + unfold gen_bblocks in H0. + destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. + all: discriminate. +Qed. + +Lemma find_label_transl_false: + forall x f lbl bb ep x', + transl_block f bb ep = OK x -> + MB.is_label lbl bb = false -> + find_label lbl (x++x') = find_label lbl x'. +Proof. + intros until x'. intros TLB MBis; simpl; auto. + destruct x as [|x0 x1]; simpl; auto. + destruct x1 as [|x1 x2]; simpl; auto. + - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. + - destruct x2 as [|x2 x3]; simpl; auto. + + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. + erewrite transl_is_label_false2; eauto. + + apply transl_block_limit in TLB. destruct TLB. +Qed. + +Lemma transl_blocks_label: + forall lbl f c tc ep, + transl_blocks f c ep = OK tc -> + match MB.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. + destruct (MB.is_label lbl a) eqn:MBis. + - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } + simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. + rewrite ABis. + eexists. eexists. split; eauto. simpl transl_blocks. + assert (MB.header a <> nil). + { apply MB.is_label_correct_true in MBis. + destruct (MB.header a). contradiction. discriminate. } + destruct (MB.header a); try contradiction. + rewrite EQ. simpl. rewrite EQ1. simpl. auto. + - apply IHc in EQ1. destruct (MB.find_label lbl c). + + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. + erewrite find_label_transl_false; eauto. + + erewrite find_label_transl_false; eauto. +Qed. + +Lemma find_label_nil: + forall bb lbl c, + header bb = nil -> + find_label lbl (bb::c) = find_label lbl c. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. subst. + assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { erewrite <- is_label_correct_false. simpl. auto. } + rewrite H. auto. +Qed. + Theorem transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match MB.find_label lbl f.(MB.fn_code) with - | None => find_label lbl tf.(fn_blocks) = None - | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. - monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. - eapply transl_blocks_label; eauto. -Qed. - -End TRANSL_LABEL. - + forall lbl f tf, + transf_function f = OK tf -> + match MB.find_label lbl f.(MB.fn_code) with + | None => find_label lbl tf.(fn_blocks) = None + | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + eapply transl_blocks_label; eauto. +Qed. + +End TRANSL_LABEL. + (** A valid branch in a piece of Machblock code translates to a valid ``go to'' transition in the generated Asmblock code. *) - -Lemma find_label_goto_label: - forall f tf lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - transf_function f = OK tf -> - rs PC = Vptr b ofs -> - MB.find_label lbl f.(MB.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros (tc & A & B). - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) - -Lemma return_address_exists: + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + MB.find_label lbl f.(MB.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros (tc & A & B). + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: forall b f c, is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. eapply Asmblockgenproof0.return_address_exists; eauto. - -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. + +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. exists x; exists true; split; auto. - repeat constructor. + repeat constructor. - exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - +Qed. + +(** * Proof of semantic preservation *) + (** Semantic preservation is proved using a complex simulation diagram - of the following form. -<< + of the following form. +<< MB.step ----------------------------------------> header body exit @@ -283,54 +283,54 @@ Qed. | / match_asmstate \ | st'1 ---------------------------------------> st'2 AB.step * ->> +>> The invariant between each MB.step/AB.step is the [match_states] predicate below. However, we also need to introduce an intermediary state [Codestate] which allows us to reason on a finer grain, executing header, body and exit separately. - + This [Codestate] consists in a state like [Asmblock.State], except that the code is directly stored in the state, much like [Machblock.State]. It also features additional useful elements to keep track of while executing a bblock. *) - -Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. -Proof. - intros. change (IR FP) with (preg_of MFP). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. - -Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), - match_states (Machblock.State s fb sp c ms m) - (Asmvliw.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Machblock.Callstate s fb ms m) - (Asmvliw.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Machblock.Returnstate s ms m) - (Asmvliw.State rs m'). - -Record codestate := + +Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of MFP). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_states (Machblock.State s fb sp c ms m) + (Asmvliw.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Machblock.Callstate s fb ms m) + (Asmvliw.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machblock.Returnstate s ms m) + (Asmvliw.State rs m'). + +Record codestate := Codestate { pstate: state; (**r projection to Asmblock.state *) - pheader: list label; + pheader: list label; pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) @@ -341,869 +341,869 @@ Record codestate := (* The part that deals with Machblock <-> Codestate agreement * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) -Inductive match_codestate fb: Machblock.state -> codestate -> Prop := - | match_codestate_intro: - forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m0) - (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) - (TIC: transl_instr_control f (MB.exit bb) = OK tbi) - (TBLS: transl_blocks f c false = OK tc) - (AG: agree ms sp rs0) - (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) - , - match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - {| pstate := (Asmvliw.State rs0 m0); - pheader := (MB.header bb); - pbody1 := tbc; +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m0) + (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) + (TIC: transl_instr_control f (MB.exit bb) = OK tbi) + (TBLS: transl_blocks f c false = OK tc) + (AG: agree ms sp rs0) + (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) + , + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + {| pstate := (Asmvliw.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc; pbody2 := extract_basic tbi; - pctl := extract_ctl tbi; + pctl := extract_ctl tbi; ep := ep; - rem := tc; + rem := tc; cur := tbb - |} -. - + |} +. + (* The part ensuring that the code in Codestate actually resides at [rs PC] *) -Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := - | match_asmstate_some: - forall rs f tf tc m tbb ofs ep tbdy tex lhd - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (TRANSF: transf_function f = OK tf) - (PCeq: rs PC = Vptr fb ofs) - (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) - , - match_asmstate fb - {| pstate := (Asmvliw.State rs m); - pheader := lhd; - pbody1 := tbdy; - pbody2 := extract_basic tex; - pctl := extract_ctl tex; +Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := + | match_asmstate_some: + forall rs f tf tc m tbb ofs ep tbdy tex lhd + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (TRANSF: transf_function f = OK tf) + (PCeq: rs PC = Vptr fb ofs) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) + , + match_asmstate fb + {| pstate := (Asmvliw.State rs m); + pheader := lhd; + pbody1 := tbdy; + pbody2 := extract_basic tex; + pctl := extract_ctl tex; ep := ep; - rem := tc; + rem := tc; cur := tbb |} - (Asmvliw.State rs m) -. - + (Asmvliw.State rs m) +. + (* Useful for dealing with the many cases in some proofs *) -Ltac exploreInst := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ |- context[if ?b then _ else _] ] => destruct b - | [ |- context[match ?m with | _ => _ end] ] => destruct m - | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - end. - +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + (** Some translation properties *) -Lemma transl_blocks_nonil: - forall f bb c tc ep, - transl_blocks f (bb::c) ep = OK tc -> - exists tbb tc', tc = tbb :: tc'. -Proof. +Lemma transl_blocks_nonil: + forall f bb c tc ep, + transl_blocks f (bb::c) ep = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. - destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - - destruct x1; simpl; eauto. -Qed. - -Lemma no_builtin_preserved: - forall f ex x2, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x2 -> - (exists i, extract_ctl x2 = Some (PCtlFlow i)) - \/ extract_ctl x2 = None. -Proof. - intros until x2. intros Hbuiltin TIC. - destruct ex. - - destruct c. - (* MBcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBtailcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBbuiltin *) - + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). - apply Hbuiltin. contradict H; auto. - (* MBgoto *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBcond *) - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. - * unfold transl_opt_compuimm. exploreInst; simpl; eauto. - * unfold transl_opt_compluimm. exploreInst; simpl; eauto. - * unfold transl_comp_float64. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. - * unfold transl_comp_float32. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. - (* MBjumptable *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBreturn *) - + simpl in TIC. monadInv TIC. simpl. eauto. - - monadInv TIC. simpl; auto. -Qed. - -Lemma transl_blocks_distrib: - forall c f bb tbb tc ep, - transl_blocks f (bb::c) ep = OK (tbb::tc) - -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) - -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) - /\ transl_blocks f c false = OK tc. -Proof. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. + - destruct x1; simpl; eauto. +Qed. + +Lemma no_builtin_preserved: + forall f ex x2, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x2 -> + (exists i, extract_ctl x2 = Some (PCtlFlow i)) + \/ extract_ctl x2 = None. +Proof. + intros until x2. intros Hbuiltin TIC. + destruct ex. + - destruct c. + (* MBcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBtailcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBbuiltin *) + + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). + apply Hbuiltin. contradict H; auto. + (* MBgoto *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBcond *) + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. + * unfold transl_opt_compuimm. exploreInst; simpl; eauto. + * unfold transl_opt_compluimm. exploreInst; simpl; eauto. + * unfold transl_comp_float64. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. + * unfold transl_comp_float32. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. + (* MBjumptable *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBreturn *) + + simpl in TIC. monadInv TIC. simpl. eauto. + - monadInv TIC. simpl; auto. +Qed. + +Lemma transl_blocks_distrib: + forall c f bb tbb tc ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. +Proof. intros until ep0. intros TLBS Hbuiltin. - destruct bb as [hd bdy ex]. - monadInv TLBS. monadInv EQ. - exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. - - destruct H as [i Hectl]. - unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. - simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite Hectl. auto. - - unfold gen_bblocks in H0. rewrite H in H0. - destruct x1 as [|bi x1]. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. -Qed. - -Lemma gen_bblocks_nobuiltin: - forall thd tbdy tex tbb, - (tbdy <> nil \/ extract_ctl tex <> None) -> - (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> - gen_bblocks thd tbdy tex = tbb :: nil -> - header tbb = thd - /\ body tbb = tbdy ++ extract_basic tex - /\ exit tbb = extract_ctl tex. -Proof. - intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl tex) eqn:ECTL. - - destruct c. - + destruct i; try (inv GENB; simpl; auto; fail). - assert False. eapply Hnobuiltin. eauto. destruct H. - + inv GENB. simpl. auto. - - inversion Hnonil. - + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. - + contradict H; simpl; auto. -Qed. - -Lemma transl_instr_basic_nonil: - forall k f bi ep x, - transl_instr_basic f bi ep k = OK x -> - x <> nil. -Proof. - intros until x. intros TIB. - destruct bi. - - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. - - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. - - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. - - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. - unfold transl_cond_op in EQ0. exploreInst; try discriminate. - unfold transl_cond_float64. exploreInst; try discriminate. - unfold transl_cond_notfloat64. exploreInst; try discriminate. - unfold transl_cond_float32. exploreInst; try discriminate. - unfold transl_cond_notfloat32. exploreInst; try discriminate. - - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. - - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. -Qed. - -Lemma transl_basic_code_nonil: - forall bdy f x ep, - bdy <> nil -> - transl_basic_code f bdy ep = OK x -> - x <> nil. -Proof. - induction bdy as [|bi bdy]. - intros. contradict H0; auto. - destruct bdy as [|bi2 bdy]. - - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. - - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. - monadInv TBC. - assert (x0 <> nil). - eapply IHbdy; eauto. subst bdy'. discriminate. - eapply transl_instr_basic_nonil; eauto. -Qed. - -Lemma transl_instr_control_nonil: - forall ex f x, - ex <> None -> - transl_instr_control f ex = OK x -> - extract_ctl x <> None. -Proof. - intros ex f x Hnonil TIC. - destruct ex as [ex|]. - - clear Hnonil. destruct ex. - all: try (simpl in TIC; exploreInst; discriminate). - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. - * unfold transl_opt_compuimm. exploreInst; try discriminate. - * unfold transl_opt_compluimm. exploreInst; try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. - - contradict Hnonil; auto. -Qed. - -Lemma transl_instr_control_nobuiltin: - forall f ex x, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x -> - (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). -Proof. - intros until x. intros Hnobuiltin TIC. intros until res. - unfold transl_instr_control in TIC. exploreInst. - all: try discriminate. - - assert False. eapply Hnobuiltin; eauto. destruct H. - - unfold transl_cbranch in TIC. exploreInst. - all: try discriminate. - * unfold transl_opt_compuimm. exploreInst. all: try discriminate. - * unfold transl_opt_compluimm. exploreInst. all: try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. -Qed. - + destruct bb as [hd bdy ex]. + monadInv TLBS. monadInv EQ. + exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. + - destruct H as [i Hectl]. + unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. + simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite Hectl. auto. + - unfold gen_bblocks in H0. rewrite H in H0. + destruct x1 as [|bi x1]. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. +Qed. + +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + (tbdy <> nil \/ extract_ctl tex <> None) -> + (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy ++ extract_basic tex + /\ exit tbb = extract_ctl tex. +Proof. + intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl tex) eqn:ECTL. + - destruct c. + + destruct i; try (inv GENB; simpl; auto; fail). + assert False. eapply Hnobuiltin. eauto. destruct H. + + inv GENB. simpl. auto. + - inversion Hnonil. + + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. + + contradict H; simpl; auto. +Qed. + +Lemma transl_instr_basic_nonil: + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> + x <> nil. +Proof. + intros until x. intros TIB. + destruct bi. + - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. + - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. + - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. + - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. + unfold transl_cond_op in EQ0. exploreInst; try discriminate. + unfold transl_cond_float64. exploreInst; try discriminate. + unfold transl_cond_notfloat64. exploreInst; try discriminate. + unfold transl_cond_float32. exploreInst; try discriminate. + unfold transl_cond_notfloat32. exploreInst; try discriminate. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x ep, + bdy <> nil -> + transl_basic_code f bdy ep = OK x -> + x <> nil. +Proof. + induction bdy as [|bi bdy]. + intros. contradict H0; auto. + destruct bdy as [|bi2 bdy]. + - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. + - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. + monadInv TBC. + assert (x0 <> nil). + eapply IHbdy; eauto. subst bdy'. discriminate. + eapply transl_instr_basic_nonil; eauto. +Qed. + +Lemma transl_instr_control_nonil: + forall ex f x, + ex <> None -> + transl_instr_control f ex = OK x -> + extract_ctl x <> None. +Proof. + intros ex f x Hnonil TIC. + destruct ex as [ex|]. + - clear Hnonil. destruct ex. + all: try (simpl in TIC; exploreInst; discriminate). + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. + * unfold transl_opt_compuimm. exploreInst; try discriminate. + * unfold transl_opt_compluimm. exploreInst; try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. + - contradict Hnonil; auto. +Qed. + +Lemma transl_instr_control_nobuiltin: + forall f ex x, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x -> + (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). +Proof. + intros until x. intros Hnobuiltin TIC. intros until res. + unfold transl_instr_control in TIC. exploreInst. + all: try discriminate. + - assert False. eapply Hnobuiltin; eauto. destruct H. + - unfold transl_cbranch in TIC. exploreInst. + all: try discriminate. + * unfold transl_opt_compuimm. exploreInst. all: try discriminate. + * unfold transl_opt_compluimm. exploreInst. all: try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. +Qed. + (* Proving that one can decompose a [match_state] relation into a [match_codestate] and a [match_asmstate], along with some helpful properties tying both relations together *) -Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m, - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - (MB.body bb <> nil \/ MB.exit bb <> None) -> - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - match_states mbs abs -> - exists cs fb f tbb tc ep, - match_codestate fb mbs cs /\ match_asmstate fb cs abs - /\ Genv.find_funct_ptr ge fb = Some (Internal f) - /\ transl_blocks f (bb::c) ep = OK (tbb::tc) - /\ body tbb = pbody1 cs ++ pbody2 cs - /\ exit tbb = pctl cs +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m, + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + (MB.body bb <> nil \/ MB.exit bb <> None) -> + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + match_states mbs abs -> + exists cs fb f tbb tc ep, + match_codestate fb mbs cs /\ match_asmstate fb cs abs + /\ Genv.find_funct_ptr ge fb = Some (Internal f) + /\ transl_blocks f (bb::c) ep = OK (tbb::tc) + /\ body tbb = pbody1 cs ++ pbody2 cs + /\ exit tbb = pctl cs /\ cur cs = tbb /\ rem cs = tc - /\ pstate cs = abs. -Proof. - intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. - inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. - exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. - monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. - { inversion Hnotempty. - - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). - left. eapply transl_basic_code_nonil; eauto. - - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). - right. eapply transl_instr_control_nonil; eauto. } - eapply transl_instr_control_nobuiltin; eauto. - intros (Hth & Htbdy & Htexit). - exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; + /\ pstate cs = abs. +Proof. + intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. + inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. + monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. + { inversion Hnotempty. + - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). + left. eapply transl_basic_code_nonil; eauto. + - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). + right. eapply transl_instr_control_nonil; eauto. } + eapply transl_instr_control_nobuiltin; eauto. + intros (Hth & Htbdy & Htexit). + exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. - repeat split. 1-2: econstructor; eauto. - { destruct (MB.header bb). eauto. discriminate. } eauto. - unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. - rewrite TLBS. simpl. rewrite H2. - all: simpl; auto. -Qed. - -Definition mb_remove_body (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. - -Lemma exec_straight_pnil: - forall c rs1 m1 rs2 m2, + repeat split. 1-2: econstructor; eauto. + { destruct (MB.header bb). eauto. discriminate. } eauto. + unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. + rewrite TLBS. simpl. rewrite H2. + all: simpl; auto. +Qed. + +Definition mb_remove_body (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma exec_straight_pnil: + forall c rs1 m1 rs2 m2, exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 -> - exec_straight tge c rs1 m1 nil rs2 m2. -Proof. - intros. eapply exec_straight_trans. eapply H. econstructor; eauto. -Qed. - -Lemma transl_block_nobuiltin: - forall f bb ep tbb, - (MB.body bb <> nil \/ MB.exit bb <> None) -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - transl_block f bb ep = OK (tbb :: nil) -> - exists c c', - transl_basic_code f (MB.body bb) ep = OK c - /\ transl_instr_control f (MB.exit bb) = OK c' - /\ body tbb = c ++ extract_basic c' - /\ exit tbb = extract_ctl c'. -Proof. - intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. -Qed. - -Lemma nextblock_preserves: - forall rs rs' bb r, - rs' = nextblock bb rs -> - data_preg r = true -> - rs r = rs' r. -Proof. - intros. destruct r; try discriminate. - subst. Simpl. -Qed. - + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb ep tbb, + (MB.body bb <> nil \/ MB.exit bb <> None) -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + transl_block f bb ep = OK (tbb :: nil) -> + exists c c', + transl_basic_code f (MB.body bb) ep = OK c + /\ transl_instr_control f (MB.exit bb) = OK c' + /\ body tbb = c ++ extract_basic c' + /\ exit tbb = extract_ctl c'. +Proof. + intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. +Qed. + +Lemma nextblock_preserves: + forall rs rs' bb r, + rs' = nextblock bb rs -> + data_preg r = true -> + rs r = rs' r. +Proof. + intros. destruct r; try discriminate. + subst. Simpl. +Qed. + Remark cons3_app {A: Type}: - forall a b c (l: list A), - a :: b :: c :: l = (a :: b :: c :: nil) ++ l. -Proof. - intros. simpl. auto. -Qed. - -Lemma exec_straight_opt_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight_opt tge c rs1 m1 c' rs2 m2 -> - exists body, - exec_body tge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. intros EXES. - inv EXES. - - exists nil. split; auto. - - eapply exec_straight_body2. auto. -Qed. - -Lemma extract_basics_to_code: - forall lb c, - extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -Lemma extract_ctl_basics_to_code: - forall lb c, - extract_ctl (basics_to_code lb ++ c) = extract_ctl c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - + forall a b c (l: list A), + a :: b :: c :: l = (a :: b :: c :: nil) ++ l. +Proof. + intros. simpl. auto. +Qed. + +Lemma exec_straight_opt_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight_opt tge c rs1 m1 c' rs2 m2 -> + exists body, + exec_body tge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. intros EXES. + inv EXES. + - exists nil. split; auto. + - eapply exec_straight_body2. auto. +Qed. + +Lemma extract_basics_to_code: + forall lb c, + extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +Lemma extract_ctl_basics_to_code: + forall lb c, + extract_ctl (basics_to_code lb ++ c) = extract_ctl c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + (* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by yourself the steps *) -Theorem step_simu_control: +Theorem step_simu_control: forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, - MB.body bb' = nil -> - (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> - Genv.find_funct_ptr tge fb = Some (Internal fn) -> - pstate cs2 = (Asmvliw.State rs2 m2) -> - pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + MB.body bb' = nil -> + (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + pstate cs2 = (Asmvliw.State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> cur cs2 = tbb -> - match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> - match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> - (exists rs3 m3 rs4 m4, - exec_body tge tbdy2 rs2 m2 = Next rs3 m3 - /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 - /\ match_states S'' (State rs4 m4)). -Proof. - intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. - inv ESTEP. - - inv MCS. inv MAS. simpl in *. + (exists rs3 m3 rs4 m4, + exec_body tge tbdy2 rs2 m2 = Next rs3 m3 + /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. + inv ESTEP. + - inv MCS. inv MAS. simpl in *. inv Hpstate. - destruct ctl. - + (* MBcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct s1 as [rf|fid]; simpl in H7. - * (* Indirect call *) - monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. - revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - { econstructor; eauto. } - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. - - * (* Direct call *) - monadInv H1. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - econstructor; eauto. - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. - Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. - + (* MBtailcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. - destruct s1 as [rf|fid]; simpl in H13. - * monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - - assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - { simpl. eauto. } - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). - { clear - EQ. destruct x; repeat split; try discriminate. - all: unfold ireg_of in EQ; destruct rf; try discriminate. } - Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. - * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } - + (* MBbuiltin (contradiction) *) - assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). - rewrite <- H in H1. contradict H1; auto. - + (* MBgoto *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. - remember (nextblock tbb rs2) as rs2'. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - exploit find_label_goto_label. - eauto. eauto. - instantiate (2 := rs2'). - { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } - eauto. - intros (tc' & rs' & GOTO & AT2 & INV). - - eexists. eexists. repeat eexists. repeat split. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. - econstructor; eauto. - rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. - eapply agree_exten; eauto with asmgen. - assert (forall r : preg, r <> PC -> rs' r = rs2 r). - { intros. destruct r. - - destruct g. all: rewrite INV; Simpl; auto. - - rewrite INV; Simpl; auto. - - contradiction. } - eauto with asmgen. - congruence. - + (* MBcond *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - * (* MBcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. - 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. - unfold Val.offset_ptr. rewrite PCeq. eauto. - intros (tc' & rs3 & GOTOL & TLPC & Hrs3). - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - - * (* MBcond false *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - - exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - + (* MBjumptable *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - monadInv H1. - generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. - - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. - - repeat eexists. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. - econstructor; eauto. - eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. - { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. - destruct (preg_eq r' GPR63). subst. contradiction. - destruct (preg_eq r' GPR62). subst. contradiction. - destruct r'; Simpl. } - discriminate. - + (* MBreturn *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - assert (f1 = f) by congruence. subst f1. - - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - + destruct ctl. + + (* MBcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct s1 as [rf|fid]; simpl in H7. + * (* Indirect call *) + monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. + revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + { econstructor; eauto. } + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. + + * (* Direct call *) + monadInv H1. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. + destruct s1 as [rf|fid]; simpl in H13. + * monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + + assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + { simpl. eauto. } + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). + { clear - EQ. destruct x; repeat split; try discriminate. + all: unfold ireg_of in EQ; destruct rf; try discriminate. } + Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. + * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } + + (* MBbuiltin (contradiction) *) + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + + (* MBgoto *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. + remember (nextblock tbb rs2) as rs2'. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + exploit find_label_goto_label. + eauto. eauto. + instantiate (2 := rs2'). + { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } + eauto. + intros (tc' & rs' & GOTO & AT2 & INV). + + eexists. eexists. repeat eexists. repeat split. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. + econstructor; eauto. + rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. + eapply agree_exten; eauto with asmgen. + assert (forall r : preg, r <> PC -> rs' r = rs2 r). + { intros. destruct r. + - destruct g. all: rewrite INV; Simpl; auto. + - rewrite INV; Simpl; auto. + - contradiction. } + eauto with asmgen. + congruence. + + (* MBcond *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + * (* MBcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. + 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. + unfold Val.offset_ptr. rewrite PCeq. eauto. + intros (tc' & rs3 & GOTOL & TLPC & Hrs3). + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + * (* MBcond false *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + + exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + (* MBjumptable *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + monadInv H1. + generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. + + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. + + repeat eexists. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. + econstructor; eauto. + eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. + { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. + destruct (preg_eq r' GPR63). subst. contradiction. + destruct (preg_eq r' GPR62). subst. contradiction. + destruct r'; Simpl. } + discriminate. + + (* MBreturn *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + assert (f1 = f) by congruence. subst f1. + + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. destruct bb' as [hd' bdy' ex']; simpl in *. subst. - monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. - simpl. repeat eexists. - econstructor. 4: instantiate (3 := false). all:eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - assert (f = f0) by congruence. subst f0. econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - discriminate. -Qed. - -Definition mb_remove_first (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. - -Lemma exec_straight_body: - forall c c' lc rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 c' rs2 m2 -> - code_to_basics c = Some lc -> - exists l ll, - c = l ++ c' - /\ code_to_basics l = Some ll - /\ exec_body tge ll rs1 m1 = Next rs2 m2. -Proof. - induction c; try (intros; inv H; fail). - intros until m2. intros EXES CTB. inv EXES. - - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. - - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. - eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. - exists (i ::g l'),(i::ll). repeat (split; simpl; auto). - rewrite CTB. auto. - rewrite H1. auto. -Qed. - -Lemma basics_to_code_app: - forall c l x ll, - basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - c = ll ++ x. -Proof. - intros. apply (f_equal code_to_basics) in H. - erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. - rewrite code_to_basics_id in H. inv H. auto. -Qed. - -Lemma basics_to_code_app2: - forall i c l x ll, - (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - i :: c = ll ++ x. -Proof. - intros until ll. intros. - exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. - all: eauto. -Qed. - + monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. + simpl. repeat eexists. + econstructor. 4: instantiate (3 := false). all:eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + assert (f = f0) by congruence. subst f0. econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + discriminate. +Qed. + +Definition mb_remove_first (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. + +Lemma exec_straight_body: + forall c c' lc rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 c' rs2 m2 -> + code_to_basics c = Some lc -> + exists l ll, + c = l ++ c' + /\ code_to_basics l = Some ll + /\ exec_body tge ll rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros until m2. intros EXES CTB. inv EXES. + - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. + - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. + eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. + exists (i ::g l'),(i::ll). repeat (split; simpl; auto). + rewrite CTB. auto. + rewrite H1. auto. +Qed. + +Lemma basics_to_code_app: + forall c l x ll, + basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + c = ll ++ x. +Proof. + intros. apply (f_equal code_to_basics) in H. + erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. + rewrite code_to_basics_id in H. inv H. auto. +Qed. + +Lemma basics_to_code_app2: + forall i c l x ll, + (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + i :: c = ll ++ x. +Proof. + intros until ll. intros. + exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. + all: eauto. +Qed. + (* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) Theorem step_simu_basic: - forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, - MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> - basic_step ge s fb sp ms m bi ms' m' -> - pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 l cs2 tbdy', - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, + MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 l cs2 tbdy', + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} - /\ tbdy = l ++ tbdy' - /\ exec_body tge l rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). -Proof. - intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. - simpl in *. inv Hpstate. - rewrite Hbody in TBC. monadInv TBC. - inv BSTEP. - - - (* MBgetstack *) - simpl in EQ0. - unfold Mach.load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - exploit loadind_correct; eauto with asmgen. - intros (rs2 & EXECS & Hrs'1 & Hrs'2). - eapply exec_straight_body in EXECS. - 2: eapply code_to_basics_id; eauto. - destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). - exists rs2, m1, Hlbi. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + /\ tbdy = l ++ tbdy' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). +Proof. + intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. + rewrite Hbody in TBC. monadInv TBC. + inv BSTEP. + + - (* MBgetstack *) + simpl in EQ0. + unfold Mach.load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + exploit loadind_correct; eauto with asmgen. + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. + 2: eapply code_to_basics_id; eauto. + destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). + exists rs2, m1, Hlbi. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } subst. simpl in Hheadereq. - + eapply match_codestate_intro; eauto. { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } - eapply agree_set_mreg; eauto with asmgen. + eapply agree_set_mreg; eauto with asmgen. intro Hep. simpl in Hep. destruct (andb_prop _ _ Hep). clear Hep. rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity. discriminate. apply preg_of_not_FP; assumption. reflexivity. - - (* MBsetstack *) - simpl in EQ0. - unfold Mach.store_stack in H. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - exploit storeind_correct; eauto with asmgen. - rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs', m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + - (* MBsetstack *) + simpl in EQ0. + unfold Mach.store_stack in H. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + exploit storeind_correct; eauto with asmgen. + rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs', m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - - eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. - - (* MBgetparam *) - simpl in EQ0. - - assert (f0 = f) by congruence; subst f0. - unfold Mach.load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. - - monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. + - (* MBgetparam *) + simpl in EQ0. + + assert (f0 = f) by congruence; subst f0. + unfold Mach.load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. + + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. destruct ep0 eqn:EPeq. - (* RTMP contains parent *) - + exploit loadind_correct. eexact EQ1. - instantiate (2 := rs1). rewrite DXP; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & BTC & CTB & EXECB). - exists rs2, m1, ll. eexists. - eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - { eapply basics_to_code_app; eauto. } - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + (* RTMP contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & BTC & CTB & EXECB). + exists rs2, m1, ll. eexists. + eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + { eapply basics_to_code_app; eauto. } + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } subst. - eapply match_codestate_intro; eauto. - - eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. - simpl; intros. rewrite R; auto with asmgen. - apply preg_of_not_FP; auto. - + eapply match_codestate_intro; eauto. + + eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_FP; auto. + (* RTMP does not contain parent *) - + rewrite chunk_of_Tptr in A. - exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. - exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. - intros [rs3 [S [T U]]]. - - exploit exec_straight_trans. - eapply P. - eapply S. - intros EXES. - - eapply exec_straight_body in EXES. - 2: simpl. 2: erewrite code_to_basics_id; eauto. - destruct EXES as (l & ll & BTC & CTB & EXECB). - exists rs3, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app2; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. - eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs2#FP <- (rs3#FP)). intros. - rewrite Pregmap.gso; auto with asmgen. - congruence. - intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. - simpl; intros. rewrite U; auto with asmgen. - apply preg_of_not_FP; auto. - - (* MBop *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_operation tge sp op (map ms args) m' = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. - eapply preg_vals; eauto. - 2: eexact H0. - all: eauto. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + + rewrite chunk_of_Tptr in A. + exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. + 2: simpl. 2: erewrite code_to_basics_id; eauto. + destruct EXES as (l & ll & BTC & CTB & EXECB). + exists rs3, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app2; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs2#FP <- (rs3#FP)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_FP; auto. + - (* MBop *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_operation tge sp op (map ms args) m' = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. + eapply preg_vals; eauto. + 2: eexact H0. + all: eauto. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - apply agree_set_undef_mreg with rs1; auto. - apply Val.lessdef_trans with v'; auto. - simpl; intros. destruct (andb_prop _ _ H1); clear H1. - rewrite R; auto. apply preg_of_not_FP; auto. -Local Transparent destroyed_by_op. - destruct op; simpl; auto; congruence. - - (* MBload *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + apply agree_set_undef_mreg with rs1; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_FP; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; congruence. + - (* MBload *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. eapply agree_set_mreg; eauto with asmgen. intro Hep. simpl in Hep. destruct (andb_prop _ _ Hep). clear Hep. subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity. apply preg_of_not_FP; assumption. reflexivity. - - - (* notrap1 cannot happen *) - simpl in EQ0. unfold transl_load in EQ0. - destruct addr; simpl in H. - all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; - monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; - destruct args as [|h0 t0]; try discriminate; - destruct t0 as [|h1 t1]; try discriminate; - destruct t1 as [|h2 t2]; try discriminate. - - - (* MBload notrap2 TODO *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - - destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. - { - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. + + - (* notrap1 cannot happen *) + simpl in EQ0. unfold transl_load in EQ0. + destruct addr; simpl in H. + all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; + monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; + destruct args as [|h0 t0]; try discriminate; + destruct t0 as [|h1 t1]; try discriminate; + destruct t1 as [|h2 t2]; try discriminate. + + - (* MBload notrap2 TODO *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + + destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. + { + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. @@ -1215,406 +1215,406 @@ Local Transparent destroyed_by_op. destruct ep0; simpl in *; congruence. apply preg_of_not_FP. destruct ep0; simpl in *; congruence. - } - { - exploit transl_load_correct_notrap2; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. + } + { + exploit transl_load_correct_notrap2; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl. intro. rewrite R; try congruence. apply DXP. destruct ep0; simpl in *; congruence. apply preg_of_not_FP. destruct ep0; simpl in *; congruence. - } - - (* MBstore *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + } + - (* MBstore *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. - eapply agree_undef_regs; eauto with asmgen. + eapply agree_undef_regs; eauto with asmgen. intro Hep. simpl in Hep. subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity. -Qed. - -Lemma exec_body_trans: - forall l l' rs0 m0 rs1 m1 rs2 m2, - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_body tge l' rs1 m1 = Next rs2 m2 -> - exec_body tge (l++l') rs0 m0 = Next rs2 m2. -Proof. - induction l. - - simpl. congruence. - - intros until m2. intros EXEB1 EXEB2. - inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. - simpl. rewrite EBI. eapply IHl; eauto. -Qed. - -Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. - -Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. -Next Obligation. - destruct tbb. simpl. auto. -Qed. - -Inductive exec_header: codestate -> codestate -> Prop := - | exec_header_cons: forall cs1, - exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; +Qed. + +Lemma exec_body_trans: + forall l l' rs0 m0 rs1 m1 rs2 m2, + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_body tge l' rs1 m1 = Next rs2 m2 -> + exec_body tge (l++l') rs0 m0 = Next rs2 m2. +Proof. + induction l. + - simpl. congruence. + - intros until m2. intros EXEB1 EXEB2. + inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. + simpl. rewrite EBI. eapply IHl; eauto. +Qed. + +Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. + +Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. +Next Obligation. + destruct tbb. simpl. auto. +Qed. + +Inductive exec_header: codestate -> codestate -> Prop := + | exec_header_cons: forall cs1, + exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; - cur := cur cs1 |}. - + cur := cur cs1 |}. + (* Theorem (A) in the diagram, the easiest of all *) Theorem step_simu_header: - forall bb s fb sp c ms m rs1 m1 cs1, - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists cs1', - exec_header cs1 cs1' - /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). -Proof. - intros until cs1. intros Hpstate MCS. - eexists. split; eauto. - econstructor; eauto. - inv MCS. simpl in *. inv Hpstate. - econstructor; eauto. -Qed. - -Lemma step_matchasm_header: - forall fb cs1 cs1' s1, - match_asmstate fb cs1 s1 -> - exec_header cs1 cs1' -> - match_asmstate fb cs1' s1. -Proof. - intros until s1. intros MAS EXH. - inv MAS. inv EXH. - simpl. econstructor; eauto. -Qed. - + forall bb s fb sp c ms m rs1 m1 cs1, + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists cs1', + exec_header cs1 cs1' + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros until cs1. intros Hpstate MCS. + eexists. split; eauto. + econstructor; eauto. + inv MCS. simpl in *. inv Hpstate. + econstructor; eauto. +Qed. + +Lemma step_matchasm_header: + forall fb cs1 cs1' s1, + match_asmstate fb cs1 s1 -> + exec_header cs1 cs1' -> + match_asmstate fb cs1' s1. +Proof. + intros until s1. intros MAS EXH. + inv MAS. inv EXH. + simpl. econstructor; eauto. +Qed. + (* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) Theorem step_simu_body: - forall bb s fb sp c ms m rs1 m1 ms' cs1 m', - MB.header bb = nil -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - body_step ge s fb sp (MB.body bb) ms m ms' m' -> - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 cs2 ep, - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', + MB.header bb = nil -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 cs2 ep, + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} - /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). -Proof. - intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. - inv BSTEP. + /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. + inv BSTEP. exists rs1, m1, cs1, (ep cs1). - inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). - econstructor; eauto. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. - rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. - exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. - intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). - simpl in *. - exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. - intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). - exists rs3, m3, cs3, ep. - repeat (split; simpl; auto). subst. simpl in *. auto. - rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. -Qed. - -Lemma exec_body_pc: - forall l rs1 m1 rs2 m2, - exec_body tge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma exec_body_control: - forall b rs1 m1 rs2 m2 rs3 m3 fn, - exec_body tge (body b) rs1 m1 = Next rs2 m2 -> - exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> - exec_bblock_rel tge fn b rs1 m1 rs3 m3. -Proof. - intros until fn. intros EXEB EXECTL. - econstructor; eauto. inv EXECTL. - unfold exec_bblock. rewrite EXEB. auto. -Qed. - -Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. - -Lemma mbsize_eqz: - forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. - remember (length _) as a. remember (length_opt _) as b. - assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. - inv H0. inv H1. destruct bdy; destruct ex; auto. - all: try discriminate. -Qed. - -Lemma mbsize_neqz: - forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. - destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). - contradict H. unfold mbsize. simpl. auto. -Qed. - + inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). + econstructor; eauto. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. + rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). + simpl in *. + exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). + exists rs3, m3, cs3, ep. + repeat (split; simpl; auto). subst. simpl in *. auto. + rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. +Qed. + +Lemma exec_body_pc: + forall l rs1 m1 rs2 m2, + exec_body tge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma exec_body_control: + forall b rs1 m1 rs2 m2 rs3 m3 fn, + exec_body tge (body b) rs1 m1 = Next rs2 m2 -> + exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> + exec_bblock_rel tge fn b rs1 m1 rs3 m3. +Proof. + intros until fn. intros EXEB EXECTL. + econstructor; eauto. inv EXECTL. + unfold exec_bblock. rewrite EXEB. auto. +Qed. + +Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. + +Lemma mbsize_eqz: + forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. + remember (length _) as a. remember (length_opt _) as b. + assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. + inv H0. inv H1. destruct bdy; destruct ex; auto. + all: try discriminate. +Qed. + +Lemma mbsize_neqz: + forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. + destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). + contradict H. unfold mbsize. simpl. auto. +Qed. + (* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) (* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) -Lemma step_simulation_bblock': - forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, - bb' = mb_remove_header bb -> - body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> - bb'' = mb_remove_body bb' -> - (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. -Proof. - intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. - destruct (mbsize bb) eqn:SIZE. - - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). - destruct bb as [hd bdy ex]; simpl in *; subst. - inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. - monadInv H2. simpl in *. inv ESTEP. inv BSTEP. - eexists. split. eapply plus_one. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - assert (x = tf) by congruence. subst x. - eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. - unfold exec_bblock. simpl. eauto. - econstructor. eauto. eauto. eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - intros. discriminate. - - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } - intros Hnotempty. - - (* initial setting *) - exploit match_state_codestate. - 2: eapply Hnotempty. - all: eauto. - intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). - - (* step_simu_header part *) - assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } - destruct H as (rs1 & m1 & Hpstate2). subst. - assert (f = fb). { inv MCS. auto. } subst fb. - exploit step_simu_header. - 2: eapply MCS. - all: eauto. - intros (cs1' & EXEH & MCS2). - - (* step_simu_body part *) - assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } - exploit step_simu_body. - 3: eapply BSTEP. - 4: eapply MCS2. - all: eauto. rewrite Hpstate'. eauto. - intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). - - (* step_simu_control part *) - assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). - { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } - destruct H as (tf & FIND'). - assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). - { inv MAS. simpl in *. eauto. } - destruct H as (tex & Hpbody2 & Hpctl). - inv EXEH. simpl in *. - subst. exploit step_simu_control. - 9: eapply MCS'. all: simpl. - 10: eapply ESTEP. - all: simpl; eauto. +Lemma step_simulation_bblock': + forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, + bb' = mb_remove_header bb -> + body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> + bb'' = mb_remove_body bb' -> + (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. +Proof. + intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. + destruct (mbsize bb) eqn:SIZE. + - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. + inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + monadInv H2. simpl in *. inv ESTEP. inv BSTEP. + eexists. split. eapply plus_one. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + assert (x = tf) by congruence. subst x. + eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. + unfold exec_bblock. simpl. eauto. + econstructor. eauto. eauto. eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + intros. discriminate. + - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } + intros Hnotempty. + + (* initial setting *) + exploit match_state_codestate. + 2: eapply Hnotempty. + all: eauto. + intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). + + (* step_simu_header part *) + assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } + destruct H as (rs1 & m1 & Hpstate2). subst. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 2: eapply MCS. + all: eauto. + intros (cs1' & EXEH & MCS2). + + (* step_simu_body part *) + assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } + exploit step_simu_body. + 3: eapply BSTEP. + 4: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). + { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } + destruct H as (tf & FIND'). + assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). + { inv MAS. simpl in *. eauto. } + destruct H as (tex & Hpbody2 & Hpctl). + inv EXEH. simpl in *. + subst. exploit step_simu_control. + 9: eapply MCS'. all: simpl. + 10: eapply ESTEP. + all: simpl; eauto. rewrite Hpbody2. rewrite Hpctl. { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. - erewrite exec_body_pc; eauto. } - intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). - - (* bringing the pieces together *) - exploit exec_body_trans. - eapply EXEB. - eauto. - intros EXEB2. - exploit exec_body_control; eauto. - rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. - rewrite Hexit. rewrite Hpctl. eauto. - intros EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. eapply plus_one. rewrite Hpstate2. - assert (exists ofs, rs1 PC = Vptr f ofs). - { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } - destruct H0 as (ofs & Hrs1pc). - eapply exec_step_internal; eauto. - - (* proving the initial find_bblock *) - rewrite Hpstate2 in MAS. inv MAS. simpl in *. - assert (f1 = f0) by congruence. subst f0. - rewrite PCeq in Hrs1pc. inv Hrs1pc. - exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. + erewrite exec_body_pc; eauto. } + intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). + + (* bringing the pieces together *) + exploit exec_body_trans. + eapply EXEB. + eauto. + intros EXEB2. + exploit exec_body_control; eauto. + rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. + rewrite Hexit. rewrite Hpctl. eauto. + intros EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. eapply plus_one. rewrite Hpstate2. + assert (exists ofs, rs1 PC = Vptr f ofs). + { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } + destruct H0 as (ofs & Hrs1pc). + eapply exec_step_internal; eauto. + + (* proving the initial find_bblock *) + rewrite Hpstate2 in MAS. inv MAS. simpl in *. + assert (f1 = f0) by congruence. subst f0. + rewrite PCeq in Hrs1pc. inv Hrs1pc. + exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. - eapply find_bblock_tail; eauto. -Qed. - + eapply find_bblock_tail; eauto. +Qed. + Theorem step_simulation_bblock: - forall sf f sp bb ms m ms' m' S2 c, - body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. -Proof. - intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. - eapply step_simulation_bblock'; eauto. - all: destruct bb as [hd bdy ex]; simpl in *; eauto. - inv ESTEP. - - econstructor. inv H; try (econstructor; eauto; fail). - - econstructor. -Qed. - + forall sf f sp bb ms m ms' m' S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. +Proof. + intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. + all: destruct bb as [hd bdy ex]; simpl in *; eauto. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. +Qed. + (** Dealing now with the builtin case *) - -Definition split (c: MB.code) := - match c with - | nil => nil - | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} - :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c - end. - -Lemma cons_ok_eq3 {A: Type} : - forall (x:A) y z x' y' z', - x = x' -> y = y' -> z = z' -> - OK (x::y::z) = OK (x'::y'::z'). -Proof. - intros. subst. auto. -Qed. - -Lemma transl_blocks_split_builtin: - forall bb c ep f ef args res, - MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> - transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. -Proof. - intros until res. intros Hexit Hbody. simpl split. - unfold transl_blocks. fold transl_blocks. unfold transl_block. - simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. - remember (transl_blocks _ _ _) as tlbs. - destruct tbc; destruct tbi; destruct tlbs. - all: try simpl; auto. - - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. - unfold gen_bblocks. simpl. destruct l. - + exploit transl_basic_code_nonil; eauto. intro. destruct H. - + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. -Qed. - -Lemma transl_code_at_pc_split_builtin: - forall rs f f0 bb c ep tf tc ef args res, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> - transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. -Proof. - intros until res. intros Hbody Hexit AT. inv AT. - econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. -Qed. - -Theorem match_states_split_builtin: - forall sf f sp bb c rs m ef args res S1, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. -Proof. - intros until S1. intros Hbody Hexit MS. - inv MS. - econstructor; eauto. - eapply transl_code_at_pc_split_builtin; eauto. -Qed. - + +Definition split (c: MB.code) := + match c with + | nil => nil + | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} + :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c + end. + +Lemma cons_ok_eq3 {A: Type} : + forall (x:A) y z x' y' z', + x = x' -> y = y' -> z = z' -> + OK (x::y::z) = OK (x'::y'::z'). +Proof. + intros. subst. auto. +Qed. + +Lemma transl_blocks_split_builtin: + forall bb c ep f ef args res, + MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> + transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. +Proof. + intros until res. intros Hexit Hbody. simpl split. + unfold transl_blocks. fold transl_blocks. unfold transl_block. + simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. + remember (transl_blocks _ _ _) as tlbs. + destruct tbc; destruct tbi; destruct tlbs. + all: try simpl; auto. + - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. + unfold gen_bblocks. simpl. destruct l. + + exploit transl_basic_code_nonil; eauto. intro. destruct H. + + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. +Qed. + +Lemma transl_code_at_pc_split_builtin: + forall rs f f0 bb c ep tf tc ef args res, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> + transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. +Proof. + intros until res. intros Hbody Hexit AT. inv AT. + econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. +Qed. + +Theorem match_states_split_builtin: + forall sf f sp bb c rs m ef args res S1, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. +Proof. + intros until S1. intros Hbody Hexit MS. + inv MS. + econstructor; eauto. + eapply transl_code_at_pc_split_builtin; eauto. +Qed. + Theorem step_simulation_builtin: - forall ef args res bb sf f sp c ms m t S2, - MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. -Proof. - intros until S2. intros Hbody Hexit ESTEP S1' MS. - inv MS. inv AT. monadInv H2. monadInv EQ. - rewrite Hbody in EQ0. monadInv EQ0. - rewrite Hexit in EQ. monadInv EQ. - rewrite Hexit in ESTEP. inv ESTEP. inv H4. - - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H1); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - econstructor; split. apply plus_one. - simpl in H3. - eapply exec_step_builtin. eauto. eauto. - eapply find_bblock_tail; eauto. - simpl. eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x0). - unfold nextblock, incrPC. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextblock. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. - apply Pregmap.gso; auto with asmgen. - congruence. -Qed. - -Lemma next_sep: - forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - congruence. -Qed. - + forall ef args res bb sf f sp c ms m t S2, + MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. +Proof. + intros until S2. intros Hbody Hexit ESTEP S1' MS. + inv MS. inv AT. monadInv H2. monadInv EQ. + rewrite Hbody in EQ0. monadInv EQ0. + rewrite Hexit in EQ. monadInv EQ. + rewrite Hexit in ESTEP. inv ESTEP. inv H4. + + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H1); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + econstructor; split. apply plus_one. + simpl in H3. + eapply exec_step_builtin. eauto. eauto. + eapply find_bblock_tail; eauto. + simpl. eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x0). + unfold nextblock, incrPC. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextblock. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + apply Pregmap.gso; auto with asmgen. + congruence. +Qed. + +Lemma next_sep: + forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + congruence. +Qed. + (* Measure to prove finite stuttering, see the other backends *) Definition measure (s: MB.state) : nat := match s with @@ -1625,193 +1625,193 @@ Definition measure (s: MB.state) : nat := (* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs for the internal and external function cases *) -Theorem step_simulation: - forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros. - -- (* bblock *) - left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. - all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; - try (rewrite MBE; try discriminate); eauto). - + (* MBbuiltin *) - destruct (MB.body bb) eqn:MBB. - * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. - * eapply match_states_split_builtin in MS; eauto. - 2: rewrite MBB; discriminate. - simpl split in MS. - rewrite <- MBB in H. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. - assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } - rewrite H1 in H. subst. - exploit step_simulation_bblock. eapply H. - discriminate. - simpl. constructor. - eauto. - intros (S2' & PLUS1 & MS'). - rewrite MBE in MS'. - assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) - (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) - rs' m') t s'). - { inv H0. inv H3. econstructor. econstructor; eauto. } - exploit step_simulation_builtin. - 4: eapply MS'. - all: simpl; eauto. - intros (S3' & PLUS'' & MS''). - exists S3'. split; eauto. - eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. - + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. - -- (* internal function *) - inv MS. - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. - unfold Mach.store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - simpl chunk_of_type in F. - exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. - intros [m3' [P Q]]. - (* Execution of function prologue *) +Theorem step_simulation: + forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros. + +- (* bblock *) + left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. + all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; + try (rewrite MBE; try discriminate); eauto). + + (* MBbuiltin *) + destruct (MB.body bb) eqn:MBB. + * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. + * eapply match_states_split_builtin in MS; eauto. + 2: rewrite MBB; discriminate. + simpl split in MS. + rewrite <- MBB in H. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. + assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } + rewrite H1 in H. subst. + exploit step_simulation_bblock. eapply H. + discriminate. + simpl. constructor. + eauto. + intros (S2' & PLUS1 & MS'). + rewrite MBE in MS'. + assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) + (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) + rs' m') t s'). + { inv H0. inv H3. econstructor. econstructor; eauto. } + exploit step_simulation_builtin. + 4: eapply MS'. + all: simpl; eauto. + intros (S3' & PLUS'' & MS''). + exists S3'. split; eauto. + eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. + +- (* internal function *) + inv MS. + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. + unfold Mach.store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + (* Execution of function prologue *) monadInv EQ0. - set (tfbody := make_prologue f x0) in *. - set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. - set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). - exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. - intros (rs' & U' & V'). - exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). + set (tfbody := make_prologue f x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). + exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). { rewrite chunk_of_Tptr in P. - assert (rs' GPRA = rs0 RA). { apply V'. } - assert (rs' SP = rs2 SP). { apply V'; discriminate. } - rewrite H4. rewrite H3. - rewrite ATLR. + assert (rs' GPRA = rs0 RA). { apply V'. } + assert (rs' SP = rs2 SP). { apply V'; discriminate. } + rewrite H4. rewrite H3. + rewrite ATLR. change (rs2 SP) with sp. eexact P. } - intros (rs3 & U & V). - assert (EXEC_PROLOGUE: exists rs3', - exec_straight_blocks tge tf - tf.(fn_blocks) rs0 m' - x0 rs3' m3' - /\ forall r, r <> PC -> rs3' r = rs3 r). - { eexists. split. - - change (fn_blocks tf) with tfbody; unfold tfbody. - econstructor; eauto. unfold exec_bblock. simpl exec_body. - rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. - Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. - rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. - simpl. apply next_sep; eauto. reflexivity. - - intros. destruct V' as (V'' & V'). destruct r. - + Simpl. - destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } - + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. - + contradiction. - } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). - exploit exec_straight_steps_2; eauto using functions_transl. - simpl fn_blocks. simpl fn_blocks in g. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3' m3'); split. - eapply exec_straight_steps_1; eauto. - simpl fn_blocks. simpl fn_blocks in g. omega. - constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_set_other; auto with asmgen. - apply agree_change_sp with (parent_sp s). - apply agree_undef_regs with rs0. auto. -Local Transparent destroyed_at_function_entry. - simpl; intros; Simpl. - unfold sp; congruence. - - intros. - assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. - assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - intros. rewrite Heqrs3'. rewrite V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. discriminate. - -- (* external function *) - inv MS. - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. - apply agree_set_pair; auto. - apply agree_undef_caller_save_regs; auto. - -- (* return *) - inv MS. - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. - -Lemma transf_initial_states: - forall st1, MB.initial_state prog st1 -> - exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Mach.Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. assumption. - compute in H1. inv H1. - generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. -Qed. - -Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := - Asmblockgenproof0.return_address_offset. - -Theorem transf_program_correct: - forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_star with (measure := measure). - - apply senv_preserved. - - eexact transf_initial_states. - - eexact transf_final_states. - - exact step_simulation. -Qed. - -End PRESERVATION. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: exists rs3', + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3' + /\ forall r, r <> PC -> rs3' r = rs3 r). + { eexists. split. + - change (fn_blocks tf) with tfbody; unfold tfbody. + econstructor; eauto. unfold exec_bblock. simpl exec_body. + rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. + Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. + rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. + simpl. apply next_sep; eauto. reflexivity. + - intros. destruct V' as (V'' & V'). destruct r. + + Simpl. + destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } + + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. + + contradiction. + } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. + simpl; intros; Simpl. + unfold sp; congruence. + + intros. + assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. + assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + intros. rewrite Heqrs3'. rewrite V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. discriminate. + +- (* external function *) + inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, MB.initial_state prog st1 -> + exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Mach.Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := + Asmblockgenproof0.return_address_offset. + +Theorem transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - exact step_simulation. +Qed. + +End PRESERVATION. -- cgit From 06388a555dcbb56a9c7cd7ebe45cc66a71454597 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Dec 2019 16:51:53 +0100 Subject: Traces now stop at Icall/Ibuiltin/Ijumptable --- backend/Duplicateaux.ml | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index e76cd125..a323f64d 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -25,11 +25,11 @@ let to_ttl_inst = function | Iop (op, lr, r, n) -> Tnext (n, Iop(op, lr, r, n)) | Iload (m, a, lr, r, n) -> Tnext (n, Iload(m, a, lr, r, n)) | Istore (m, a, lr, r, n) -> Tnext (n, Istore(m, a, lr, r, n)) -| Icall (s, ri, lr, r, n) -> Tnext (n, Icall(s, ri, lr, r, n)) +| Icall (s, ri, lr, r, n) -> Tleaf (Icall(s, ri, lr, r, n)) | Itailcall (s, ri, lr) -> Tleaf (Itailcall(s, ri, lr)) -| Ibuiltin (ef, lbr, br, n) -> Tnext (n, Ibuiltin(ef, lbr, br, n)) +| Ibuiltin (ef, lbr, br, n) -> Tleaf (Ibuiltin(ef, lbr, br, n)) | Icond (cond, lr, n, n') -> Tnext (select_one n n', Icond(cond, lr, n, n')) -| Ijumptable (r, ln) -> Tnext (List.hd ln, Ijumptable(r, ln)) +| Ijumptable (r, ln) -> Tleaf (Ijumptable(r, ln)) let rec to_ttl_code_rec = function | [] -> PTree.empty @@ -64,11 +64,16 @@ let bfs code entrypoint = match PTree.get node code with | None -> failwith "No such node" | Some ti -> [node] @ match ti with - | Tleaf i -> [] + | Tleaf i -> (match i with + | Icall(_, _, _, _, n) -> bfs_list code [n] + | Ibuiltin(_, _, _, n) -> bfs_list code [n] + | Ijumptable(_, ln) -> bfs_list code ln + | Itailcall _ | Ireturn _ -> [] + | _ -> failwith "Tleaf case not handled in bfs" ) | Tnext (n,i) -> (bfs_list code [n]) @ match i with | Icond (_, _, n1, n2) -> bfs_list code [n1; n2] - | Ijumptable (_, ln) -> bfs_list code ln - | _ -> [] + | Inop _ | Iop _ | Iload _ | Istore _ -> [] + | _ -> failwith "Tnext case not handled in bfs" end else [] in node_bfs @ (bfs_list code ln) -- cgit From 2863726fee9ef741a2456ded7d7bfc15bd8111b4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 5 Dec 2019 10:59:29 +0100 Subject: bfs --> dfs --- backend/Duplicateaux.ml | 50 +++++++++++++++++++++++++------------------------ 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index a323f64d..66b33a8c 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -52,32 +52,31 @@ let get_some = function | None -> failwith "Did not get some" | Some thing -> thing -(* FIXME - heuristic : starting from entrypoint, then going downward *) -let bfs code entrypoint = +let dfs code entrypoint = let visited = ref (PTree.map (fun n i -> false) code) in - let rec bfs_list code = function + let rec dfs_list code = function | [] -> [] | node :: ln -> - let node_bfs = + let node_dfs = if not (get_some @@ PTree.get node !visited) then begin visited := PTree.set node true !visited; match PTree.get node code with | None -> failwith "No such node" | Some ti -> [node] @ match ti with | Tleaf i -> (match i with - | Icall(_, _, _, _, n) -> bfs_list code [n] - | Ibuiltin(_, _, _, n) -> bfs_list code [n] - | Ijumptable(_, ln) -> bfs_list code ln + | Icall(_, _, _, _, n) -> dfs_list code [n] + | Ibuiltin(_, _, _, n) -> dfs_list code [n] + | Ijumptable(_, ln) -> dfs_list code ln | Itailcall _ | Ireturn _ -> [] - | _ -> failwith "Tleaf case not handled in bfs" ) - | Tnext (n,i) -> (bfs_list code [n]) @ match i with - | Icond (_, _, n1, n2) -> bfs_list code [n1; n2] + | _ -> failwith "Tleaf case not handled in dfs" ) + | Tnext (n,i) -> (dfs_list code [n]) @ match i with + | Icond (_, _, n1, n2) -> dfs_list code [n1; n2] | Inop _ | Iop _ | Iload _ | Istore _ -> [] - | _ -> failwith "Tnext case not handled in bfs" + | _ -> failwith "Tnext case not handled in dfs" end else [] - in node_bfs @ (bfs_list code ln) - in bfs_list code [entrypoint] + in node_dfs @ (dfs_list code ln) + in dfs_list code [entrypoint] let ptree_get_some n ptree = get_some @@ PTree.get n ptree @@ -115,10 +114,21 @@ let get_predecessors code = !preds end +(* for debugging *) +let print_intlist l = + let rec f = function + | [] -> () + | n::ln -> (Printf.printf "%d " (P.to_int n); f ln) + in begin + Printf.printf "["; + f l; + Printf.printf "]" + end + (* Algorithm mostly inspired from Chang and Hwu 1988 * "Trace Selection for Compiling Large C Application Programs to Microcode" *) let select_traces code entrypoint = - let order = bfs code entrypoint in + let order = dfs code entrypoint in let predecessors = get_predecessors code in let traces = ref [] in let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *) @@ -154,19 +164,11 @@ let select_traces code entrypoint = end end done; + Printf.printf "DFS: \n"; print_intlist order; !traces end -(* for debugging *) -let print_trace trace = - let rec f = function - | [] -> () - | n::ln -> (Printf.printf "%d " (P.to_int n); f ln) - in begin - Printf.printf "["; - f trace; - Printf.printf "]" - end +let print_trace t = print_intlist t let print_traces traces = let rec f = function -- cgit From 59e9d82827f89f71f955de299cf2bffbf2de81bf Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 5 Dec 2019 12:41:59 +0100 Subject: [BROKEN] Started BFS - does not compile --- backend/Duplicateaux.ml | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 66b33a8c..4517a685 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -78,6 +78,36 @@ let dfs code entrypoint = in node_dfs @ (dfs_list code ln) in dfs_list code [entrypoint] +let bfs code entrypoint = + in let visited = ref (PTree.map (fun n i -> false) code) + and bfs_list = ref [] + and to_visit = Queue.create () + and node = ref entrypoint + in begin + Queue.add entrypoint to_visit; + while not Queue.is_empty to_visit do + node := Queue.pop to_visit; + if not (get_some @@ PTree.get !node !visited) then begin + visited := PTree.set !node true !visited; + match PTree.get !node code with + | None -> failwith "No such node" + | Some ti -> + bfs_list := ti :: !bfs_list; + match ti with + | Tleaf i -> ( 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 _ -> () + | _ -> failwith "Tleaf case not handled in bfs" ) + | Tnext (_, i) -> ( match i with + | 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 + | _ -> failwith "Tnext case not handled in bfs" ) + end + done + end + let ptree_get_some n ptree = get_some @@ PTree.get n ptree let rec select_unvisited_node is_visited = function -- cgit From e2c64b54bf5df0927c684a70167378c91cba0ff4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 6 Dec 2019 13:49:48 +0100 Subject: make it compile for ARM --- backend/Duplicateproof.v | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index e66a1068..ebb17774 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -392,21 +392,21 @@ Proof. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. - + eapply exec_Iload; eauto. erewrite eval_addressing_preserved; eauto. + + eapply exec_Iload; eauto; (* is the follow still needed?*) erewrite eval_addressing_preserved; eauto. + econstructor; eauto. (* Iload notrap1 *) - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. - + eapply exec_Iload_notrap1; eauto. erewrite eval_addressing_preserved; eauto. + + eapply exec_Iload_notrap1; eauto; erewrite eval_addressing_preserved; eauto. + econstructor; eauto. (* Iload notrap2 *) - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. - + eapply exec_Iload_notrap2; eauto. erewrite eval_addressing_preserved; eauto. + + eapply exec_Iload_notrap2; eauto; erewrite eval_addressing_preserved; eauto. + econstructor; eauto. (* Istore *) @@ -414,7 +414,7 @@ Proof. destruct DUPLIC as (i' & H2 & H3). inv H3. pose symbols_preserved as SYMPRES. eexists. split. - + eapply exec_Istore; eauto. erewrite eval_addressing_preserved; eauto. + + eapply exec_Istore; eauto; erewrite eval_addressing_preserved; eauto. + econstructor; eauto. (* Icall *) - eapply dupmap_correct in DUPLIC; eauto. -- cgit From 37d341f2bd001263f0771036eef8adaef1c4c748 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 6 Dec 2019 15:44:06 +0100 Subject: [BROKEN] Compiles, not tested --- backend/Duplicateaux.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 4517a685..f7871be8 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -79,13 +79,13 @@ let dfs code entrypoint = in dfs_list code [entrypoint] let bfs code entrypoint = - in let visited = ref (PTree.map (fun n i -> false) code) + let visited = ref (PTree.map (fun n i -> false) code) and bfs_list = ref [] and to_visit = Queue.create () and node = ref entrypoint in begin Queue.add entrypoint to_visit; - while not Queue.is_empty to_visit do + while not (Queue.is_empty to_visit) do node := Queue.pop to_visit; if not (get_some @@ PTree.get !node !visited) then begin visited := PTree.set !node true !visited; @@ -102,7 +102,7 @@ let bfs code entrypoint = | _ -> failwith "Tleaf case not handled in bfs" ) | Tnext (_, i) -> ( match i with | 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 + | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, n) | Istore (_, _, _, _, n) -> Queue.add n to_visit | _ -> failwith "Tnext case not handled in bfs" ) end done -- cgit From 45ec8ff0599e5172e0bcdc23a6cf38933df18566 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 6 Dec 2019 16:15:07 +0100 Subject: Adding breadth first search --- backend/Duplicateaux.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index f7871be8..04c3edbb 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -92,7 +92,7 @@ let bfs code entrypoint = match PTree.get !node code with | None -> failwith "No such node" | Some ti -> - bfs_list := ti :: !bfs_list; + bfs_list := !bfs_list @ [!node]; match ti with | Tleaf i -> ( match i with | Icall(_, _, _, _, n) -> Queue.add n to_visit @@ -105,7 +105,8 @@ let bfs code entrypoint = | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, n) | Istore (_, _, _, _, n) -> Queue.add n to_visit | _ -> failwith "Tnext case not handled in bfs" ) end - done + done; + !bfs_list end let ptree_get_some n ptree = get_some @@ PTree.get n ptree @@ -159,6 +160,7 @@ let print_intlist l = * "Trace Selection for Compiling Large C Application Programs to Microcode" *) let select_traces code entrypoint = let order = dfs code entrypoint in + let bfs_order = bfs code entrypoint in let predecessors = get_predecessors code in let traces = ref [] in let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *) @@ -194,7 +196,8 @@ let select_traces code entrypoint = end end done; - Printf.printf "DFS: \n"; print_intlist order; + Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; + Printf.printf "BFS: \t"; print_intlist bfs_order; Printf.printf "\n"; !traces end -- cgit From 1cc98a193dcf83aff89fe22a3b23d4881b7123f9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 6 Dec 2019 18:58:25 +0100 Subject: merge w/ non trapping loads --- backend/Duplicateaux.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 04c3edbb..a655e76b 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -23,7 +23,7 @@ let to_ttl_inst = function | Ireturn o -> Tleaf (Ireturn o) | Inop n -> Tnext (n, Inop n) | Iop (op, lr, r, n) -> Tnext (n, Iop(op, lr, r, n)) -| Iload (m, a, lr, r, n) -> Tnext (n, Iload(m, a, lr, r, n)) +| Iload (tm, m, a, lr, r, n) -> Tnext (n, Iload(tm, m, a, lr, r, n)) | Istore (m, a, lr, r, n) -> Tnext (n, Istore(m, a, lr, r, n)) | Icall (s, ri, lr, r, n) -> Tleaf (Icall(s, ri, lr, r, n)) | Itailcall (s, ri, lr) -> Tleaf (Itailcall(s, ri, lr)) @@ -102,7 +102,7 @@ let bfs code entrypoint = | _ -> failwith "Tleaf case not handled in bfs" ) | Tnext (_, i) -> ( match i with | 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 + | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) -> Queue.add n to_visit | _ -> failwith "Tnext case not handled in bfs" ) end done; @@ -134,7 +134,7 @@ let get_predecessors code = let process_inst (node, ti) = match ti with | Tleaf _ -> () | Tnext (_, i) -> let succ = match i with - | Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,n) | Istore (_,_,_,_,n) + | Inop n | Iop (_,_,_,n) | Iload (_, _,_,_,_,n) | Istore (_,_,_,_,n) | Icall (_,_,_,_,n) | Ibuiltin (_, _, _, n) -> [n] | Icond (_,_,n1,n2) -> [n1;n2] | Ijumptable (_,ln) -> ln -- cgit From 5382048e0eef1a726119172067a4d6afdf7881fb Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Dec 2019 17:33:31 +0100 Subject: Rajout du calcul de dominateurs - pas testé MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- backend/Duplicateaux.ml | 59 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 43 insertions(+), 16 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index a655e76b..069741de 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -111,6 +111,49 @@ let bfs code entrypoint = let ptree_get_some n ptree = get_some @@ PTree.get n ptree +let get_predecessors 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 + +module PInt = struct + type t = P.t + let compare x y = compare (P.to_int x) (P.to_int y) +end + +module PSet = Set.Make(PInt) + +let dominators code entrypoint = + let bfs_order = bfs code entrypoint + and predecessors = get_predecessors code + in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code) + in begin + List.iter (fun n -> + let preds = get_some @@ PTree.get n predecessors + and single = PSet.singleton n + in match preds with + | [] -> doms := PTree.set n single !doms + | p::lp -> + let set_p = get_some @@ PTree.get p !doms + and set_lp = List.map (fun p -> get_some @@ PTree.get p !doms) lp + in let inter = List.fold_left PSet.inter set_p set_lp + in let union = PSet.union inter single + in doms := PTree.set n union !doms + ) bfs_order; + !doms + 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 @@ -129,22 +172,6 @@ let best_predecessor_of node predecessors order is_visited = | Some lp -> try Some (List.find (fun n -> (List.mem n lp) && (not (ptree_get_some n is_visited))) order) with Not_found -> None -let get_predecessors 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 - (* for debugging *) let print_intlist l = let rec f = function -- cgit From e127c4f8bd81032cf77cfff889b5a904ff85e657 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Dec 2019 11:57:44 +0100 Subject: Calcul de dominateurs a l'air de marcher --- backend/Duplicateaux.ml | 232 ++++++++++++++++++++++++++++++------------------ 1 file changed, 144 insertions(+), 88 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 82d1f8ef..b9bc40bc 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -15,11 +15,128 @@ open TTL (** RTL to TTL *) -(* FIXME - for now, random choice *) +let get_some = function +| None -> failwith "Did not get some" +| Some thing -> thing + +let bfs code entrypoint = + let visited = ref (PTree.map (fun n i -> false) code) + and bfs_list = ref [] + and to_visit = Queue.create () + and node = ref entrypoint + in begin + Queue.add entrypoint to_visit; + while not (Queue.is_empty to_visit) do + node := Queue.pop to_visit; + if not (get_some @@ PTree.get !node !visited) then begin + visited := PTree.set !node true !visited; + match PTree.get !node code with + | None -> failwith "No such node" + | Some i -> + bfs_list := !bfs_list @ [!node]; + 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 + end + done; + !bfs_list + end + +let get_predecessors_rtl code = + 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 _ -> [] + 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 select_one n n' = if Random.bool () then n else n' +module PInt = struct + type t = P.t + let compare x y = compare (P.to_int x) (P.to_int y) +end -let to_ttl_inst = function +module PSet = Set.Make(PInt) + +let get_dominators code entrypoint = + let bfs_order = bfs code entrypoint + and predecessors = get_predecessors_rtl code + in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code) + in begin + List.iter (fun n -> + let preds = get_some @@ PTree.get n predecessors + and single = PSet.singleton n + in match preds with + | [] -> doms := PTree.set n single !doms + | p::lp -> + let set_p = get_some @@ PTree.get p !doms + and set_lp = List.map (fun p -> get_some @@ PTree.get p !doms) lp + in let inter = List.fold_left PSet.inter set_p set_lp + in let union = PSet.union inter single + in doms := PTree.set n union !doms + ) bfs_order; + !doms + end + +let print_intlist l = + let rec f = function + | [] -> () + | n::ln -> (Printf.printf "%d " (P.to_int n); f ln) + in begin + Printf.printf "["; + f l; + Printf.printf "]" + 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 "}" + end + +let print_dominators dominators = + let domlist = PTree.elements dominators + in begin + Printf.printf "{\n"; + List.iter (fun (n, doms) -> + Printf.printf "\t"; + Printf.printf "%d:" (P.to_int n); + print_intset doms; + Printf.printf "\n" + ) domlist + end + +let get_directions code entrypoint = + let bfs_order = bfs code entrypoint + and directions = ref (PTree.map (fun n i -> false) code) (* false <=> fallthru *) + and dominators = get_dominators code entrypoint + in begin + Printf.printf "Dominators: "; + print_dominators dominators; + List.iter (fun n -> + match (get_some @@ PTree.get n code) with + | Icond (cond, lr, n, n') -> directions := PTree.set n (Random.bool ()) !directions + | _ -> () + ) bfs_order; + !directions + end + + +let to_ttl_inst direction = function | Ireturn o -> Tleaf (Ireturn o) | Inop n -> Tnext (n, Inop n) | Iop (op, lr, r, n) -> Tnext (n, Iop(op, lr, r, n)) @@ -28,17 +145,23 @@ let to_ttl_inst = function | Icall (s, ri, lr, r, n) -> Tleaf (Icall(s, ri, lr, r, n)) | Itailcall (s, ri, lr) -> Tleaf (Itailcall(s, ri, lr)) | Ibuiltin (ef, lbr, br, n) -> Tleaf (Ibuiltin(ef, lbr, br, n)) -| Icond (cond, lr, n, n') -> Tnext (select_one n n', Icond(cond, lr, n, n')) +| Icond (cond, lr, n, n') -> (match direction with + | false -> Tnext (n', Icond(cond, lr, n, n')) + | true -> Tnext (n, Icond(cond, lr, n, n'))) | Ijumptable (r, ln) -> Tleaf (Ijumptable(r, ln)) -let rec to_ttl_code_rec = function +let rec to_ttl_code_rec directions = function | [] -> PTree.empty -| m::lm -> let (n, i) = m in PTree.set n (to_ttl_inst i) (to_ttl_code_rec lm) +| m::lm -> let (n, i) = m + in let direction = get_some @@ PTree.get n directions + in PTree.set n (to_ttl_inst direction i) (to_ttl_code_rec directions lm) -let to_ttl_code code = begin - Random.init(0); (* using same seed to make it deterministic *) - to_ttl_code_rec (PTree.elements code) -end +let to_ttl_code code entrypoint = + let directions = get_directions code entrypoint + in begin + Random.init(0); (* using same seed to make it deterministic *) + to_ttl_code_rec directions (PTree.elements code) + end (** Trace selection on TTL *) @@ -48,10 +171,7 @@ let rec exists_false_rec = function let exists_false boolmap = exists_false_rec (PTree.elements boolmap) -let get_some = function -| None -> failwith "Did not get some" -| Some thing -> thing - +(* DFS on TTL to guide the exploration *) let dfs code entrypoint = let visited = ref (PTree.map (fun n i -> false) code) in let rec dfs_list code = function @@ -78,40 +198,9 @@ let dfs code entrypoint = in node_dfs @ (dfs_list code ln) in dfs_list code [entrypoint] -let bfs code entrypoint = - let visited = ref (PTree.map (fun n i -> false) code) - and bfs_list = ref [] - and to_visit = Queue.create () - and node = ref entrypoint - in begin - Queue.add entrypoint to_visit; - while not (Queue.is_empty to_visit) do - node := Queue.pop to_visit; - if not (get_some @@ PTree.get !node !visited) then begin - visited := PTree.set !node true !visited; - match PTree.get !node code with - | None -> failwith "No such node" - | Some ti -> - bfs_list := !bfs_list @ [!node]; - match ti with - | Tleaf i -> ( 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 _ -> () - | _ -> failwith "Tleaf case not handled in bfs" ) - | Tnext (_, i) -> ( match i with - | 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 - | _ -> failwith "Tnext case not handled in bfs" ) - end - done; - !bfs_list - end - let ptree_get_some n ptree = get_some @@ PTree.get n ptree -let get_predecessors code = +let get_predecessors_ttl code = let preds = ref (PTree.map (fun n i -> []) code) in let process_inst (node, ti) = match ti with | Tleaf _ -> () @@ -127,32 +216,7 @@ let get_predecessors code = !preds end -module PInt = struct - type t = P.t - let compare x y = compare (P.to_int x) (P.to_int y) -end - -module PSet = Set.Make(PInt) - -let dominators code entrypoint = - let bfs_order = bfs code entrypoint - and predecessors = get_predecessors code - in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code) - in begin - List.iter (fun n -> - let preds = get_some @@ PTree.get n predecessors - and single = PSet.singleton n - in match preds with - | [] -> doms := PTree.set n single !doms - | p::lp -> - let set_p = get_some @@ PTree.get p !doms - and set_lp = List.map (fun p -> get_some @@ PTree.get p !doms) lp - in let inter = List.fold_left PSet.inter set_p set_lp - in let union = PSet.union inter single - in doms := PTree.set n union !doms - ) bfs_order; - !doms - end +let rtl_proj code = PTree.map (fun n ti -> match ti with Tleaf i | Tnext(_, i) -> i) code let rec select_unvisited_node is_visited = function | [] -> failwith "Empty list" @@ -172,23 +236,11 @@ let best_predecessor_of node predecessors order is_visited = | Some lp -> try Some (List.find (fun n -> (List.mem n lp) && (not (ptree_get_some n is_visited))) order) with Not_found -> None -(* for debugging *) -let print_intlist l = - let rec f = function - | [] -> () - | n::ln -> (Printf.printf "%d " (P.to_int n); f ln) - in begin - Printf.printf "["; - f l; - Printf.printf "]" - end - (* Algorithm mostly inspired from Chang and Hwu 1988 * "Trace Selection for Compiling Large C Application Programs to Microcode" *) let select_traces code entrypoint = let order = dfs code entrypoint in - let bfs_order = bfs code entrypoint in - let predecessors = get_predecessors code in + let predecessors = get_predecessors_ttl code in let traces = ref [] in let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *) while exists_false !is_visited do (* while (there are unvisited nodes) *) @@ -224,7 +276,6 @@ let select_traces code entrypoint = end done; Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; - Printf.printf "BFS: \t"; print_intlist bfs_order; Printf.printf "\n"; !traces end @@ -248,5 +299,10 @@ let make_identity_ptree f = make_identity_ptree_rec (PTree.elements f.fn_code) (* For now, identity function *) let duplicate_aux f = - let pTreeId = make_identity_ptree f - in ((f.fn_code, f.fn_entrypoint), pTreeId) + let pTreeId = make_identity_ptree f in + let entrypoint = fn_entrypoint f in + let traces = select_traces (to_ttl_code (fn_code f) entrypoint) entrypoint + in begin + print_traces traces; + (((fn_code f), (fn_entrypoint f)), pTreeId) + end -- cgit From bf0161e61415b981cef50d589e9c94273c580070 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Dec 2019 17:58:43 +0100 Subject: Dominators approach not working well ==> opting for visit approach --- backend/Duplicateaux.ml | 96 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 73 insertions(+), 23 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index b9bc40bc..803e1c14 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -68,26 +68,6 @@ end module PSet = Set.Make(PInt) -let get_dominators code entrypoint = - let bfs_order = bfs code entrypoint - and predecessors = get_predecessors_rtl code - in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code) - in begin - List.iter (fun n -> - let preds = get_some @@ PTree.get n predecessors - and single = PSet.singleton n - in match preds with - | [] -> doms := PTree.set n single !doms - | p::lp -> - let set_p = get_some @@ PTree.get p !doms - and set_lp = List.map (fun p -> get_some @@ PTree.get p !doms) lp - in let inter = List.fold_left PSet.inter set_p set_lp - in let union = PSet.union inter single - in doms := PTree.set n union !doms - ) bfs_order; - !doms - end - let print_intlist l = let rec f = function | [] -> () @@ -108,6 +88,40 @@ let print_intset s = Printf.printf "}" end +(* FIXME - dominators not working well because the order of dataflow update isn't right *) + (* +let get_dominators code entrypoint = + let bfs_order = bfs code entrypoint + and predecessors = get_predecessors_rtl code + in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code) + in begin + Printf.printf "BFS: "; + print_intlist bfs_order; + Printf.printf "\n"; + List.iter (fun n -> + let preds = get_some @@ PTree.get n predecessors + and single = PSet.singleton n + in match preds with + | [] -> doms := PTree.set n single !doms + | p::lp -> + let set_p = get_some @@ PTree.get p !doms + and set_lp = List.map (fun p -> get_some @@ PTree.get p !doms) lp + in let inter = List.fold_left PSet.inter set_p set_lp + in let union = PSet.union inter single + in begin + Printf.printf "----------------------------------------\n"; + Printf.printf "n = %d\n" (P.to_int n); + Printf.printf "set_p = "; print_intset set_p; Printf.printf "\n"; + Printf.printf "set_lp = ["; List.iter (fun s -> print_intset s; Printf.printf ", ") set_lp; Printf.printf "]\n"; + Printf.printf "=> inter = "; print_intset inter; Printf.printf "\n"; + Printf.printf "=> union = "; print_intset union; Printf.printf "\n"; + doms := PTree.set n union !doms + end + ) bfs_order; + !doms + end +*) + let print_dominators dominators = let domlist = PTree.elements dominators in begin @@ -120,13 +134,49 @@ let print_dominators dominators = ) domlist end +type vstate = Unvisited | Processed | Visited + +(** Getting loop branches with a DFS visit : + * Each node is either Unvisited, Visited, or Processed + * pre-order: node becomes Processed + * post-order: node becomes Visited + * + * If we come accross an edge to a Processed node, it's a loop! + *) +let get_loop_headers code entrypoint = + 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 + | [] -> () + | node :: ln -> + match (get_some @@ PTree.get node !visited) with + | Visited -> () + | Processed -> begin + is_loop_header := PTree.set node true !is_loop_header; + visited := PTree.set node Visited !visited + end + | Unvisited -> 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 @ ln) + end + in begin + dfs_visit code [entrypoint]; + !is_loop_header + end + let get_directions code entrypoint = let bfs_order = bfs code entrypoint + (* and is_loop_header = get_loop_headers code entrypoint *) and directions = ref (PTree.map (fun n i -> false) code) (* false <=> fallthru *) - and dominators = get_dominators code entrypoint in begin - Printf.printf "Dominators: "; - print_dominators dominators; List.iter (fun n -> match (get_some @@ PTree.get n code) with | Icond (cond, lr, n, n') -> directions := PTree.set n (Random.bool ()) !directions -- cgit From f90e89cc5375383ad905ef08c782d3f7a9f639da Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Dec 2019 12:53:49 +0100 Subject: Loop headers detection works! --- backend/Duplicateaux.ml | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 803e1c14..524122cd 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -165,18 +165,33 @@ let get_loop_headers code entrypoint = | Icond (_, _, n1, n2) -> [n1; n2] | Itailcall _ | Ireturn _ -> [] | Ijumptable (_, ln) -> ln - ) in dfs_visit code (next_visits @ ln) + ) in dfs_visit code next_visits; + visited := PTree.set node Visited !visited; + dfs_visit code ln end in begin dfs_visit code [entrypoint]; !is_loop_header 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 "]" + end + let get_directions code entrypoint = let bfs_order = bfs code entrypoint - (* and is_loop_header = get_loop_headers code entrypoint *) + and is_loop_header = get_loop_headers code entrypoint and directions = ref (PTree.map (fun n i -> false) code) (* false <=> fallthru *) in begin + Printf.printf "Loop headers: "; + ptree_printbool is_loop_header; + Printf.printf "\n"; List.iter (fun n -> match (get_some @@ PTree.get n code) with | Icond (cond, lr, n, n') -> directions := PTree.set n (Random.bool ()) !directions @@ -185,7 +200,6 @@ let get_directions code entrypoint = !directions end - let to_ttl_inst direction = function | Ireturn o -> Tleaf (Ireturn o) | Inop n -> Tnext (n, Inop n) -- cgit From 54fb9faab6a53fad126fd57c3d58b232ff181cd1 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 11 Dec 2019 14:10:32 +0100 Subject: The SP register has dwarf register number 31. --- aarch64/Asmexpand.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index 55922e9e..471ad501 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -435,7 +435,7 @@ let preg_to_dwarf = function let expand_function id fn = try set_current_function fn; - expand id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code; + expand id (* sp= *) 31 preg_to_dwarf expand_instruction fn.fn_code; Errors.OK (get_current_function ()) with Error s -> Errors.Error (Errors.msg (coqstring_of_camlstring s)) -- cgit From 05dd74d92c2589eeb6a933138a484896c4eb6969 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Dec 2019 14:16:51 +0100 Subject: Function to look ahead unconditionally --- backend/Duplicateaux.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 524122cd..569f4c51 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -184,6 +184,18 @@ let ptree_printbool pt = Printf.printf "]" end +(* Looks ahead (until a branch) to see if a node further down verifies + * 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 (get_some @@ PTree.get n is_loop_header) then false + else look_ahead code n is_loop_header predicate + let get_directions code entrypoint = let bfs_order = bfs code entrypoint and is_loop_header = get_loop_headers code entrypoint -- cgit From ec1d36a68e3bb7d217c8ce2cf81025f4ab3e454d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Dec 2019 15:08:02 +0100 Subject: Implemented call, return, store and loop heuristics --- backend/Duplicateaux.ml | 57 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 55 insertions(+), 2 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 569f4c51..70c95d32 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -187,7 +187,7 @@ let ptree_printbool pt = (* Looks ahead (until a branch) to see if a node further down verifies * the given predicate *) let rec look_ahead code node is_loop_header predicate = - if (predicate node) then true + if (predicate @@ get_some @@ PTree.get node code) then true else match (get_some @@ PTree.get node code) with | Ireturn _ | Itailcall _ | Icond _ | Ijumptable _ -> false | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, _, n) @@ -196,6 +196,49 @@ let rec look_ahead code node is_loop_header predicate = if (get_some @@ PTree.get n is_loop_header) then false else look_ahead code n is_loop_header predicate +exception HeuristicSucceeded + +let do_call_heuristic code ifso ifnot is_loop_header preferred = + let predicate = function + | Icall _ -> true + | _ -> false + in if (look_ahead code ifso is_loop_header predicate) then + (preferred := false; raise HeuristicSucceeded) + else if (look_ahead code ifnot is_loop_header predicate) then + (preferred := true; raise HeuristicSucceeded) + else () + +let do_opcode_heuristic code cond ifso ifnot is_loop_header preferred = () + (* TODO - the condition is architecture dependent, so each archi should + have a heuristic function in its folder *) + +let do_return_heuristic code ifso ifnot is_loop_header preferred = + let predicate = function + | Ireturn _ -> true + | _ -> false + in if (look_ahead code ifso is_loop_header predicate) then + (preferred := false; raise HeuristicSucceeded) + else if (look_ahead code ifnot is_loop_header predicate) then + (preferred := true; raise HeuristicSucceeded) + else () + +let do_store_heuristic code ifso ifnot is_loop_header preferred = + let predicate = function + | Istore _ -> true + | _ -> false + in if (look_ahead code ifso is_loop_header predicate) then + (preferred := false; raise HeuristicSucceeded) + else if (look_ahead code ifnot is_loop_header predicate) then + (preferred := true; raise HeuristicSucceeded) + else () + +let do_loop_heuristic code ifso ifnot is_loop_header preferred = + if (get_some @@ PTree.get ifso is_loop_header) then + (preferred := true; raise HeuristicSucceeded) + else if (get_some @@ PTree.get ifnot is_loop_header) then + (preferred := false; raise HeuristicSucceeded) + else () + let get_directions code entrypoint = let bfs_order = bfs code entrypoint and is_loop_header = get_loop_headers code entrypoint @@ -206,7 +249,17 @@ let get_directions code entrypoint = Printf.printf "\n"; List.iter (fun n -> match (get_some @@ PTree.get n code) with - | Icond (cond, lr, n, n') -> directions := PTree.set n (Random.bool ()) !directions + | Icond (cond, lr, ifso, ifnot) -> + let preferred = ref false + in (try + do_call_heuristic code ifso ifnot is_loop_header preferred; + do_opcode_heuristic code cond ifso ifnot is_loop_header preferred; + do_return_heuristic code ifso ifnot is_loop_header preferred; + do_store_heuristic code ifso ifnot is_loop_header preferred; + do_loop_heuristic code ifso ifnot is_loop_header preferred; + preferred := Random.bool () + with HeuristicSucceeded -> () + ); directions := PTree.set n !preferred !directions | _ -> () ) bfs_order; !directions -- cgit From e11a1b3ccac5cb60472ad507a71b0600ac3b5f8f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Dec 2019 16:37:26 +0100 Subject: Fixing loop heuristic for the way CompCert handles loops --- backend/Duplicateaux.ml | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 70c95d32..71f44776 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -187,21 +187,24 @@ let ptree_printbool pt = (* Looks ahead (until a branch) to see if a node further down verifies * the given predicate *) let rec look_ahead code node is_loop_header predicate = - if (predicate @@ get_some @@ PTree.get node code) then true + 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 (get_some @@ PTree.get n is_loop_header) then false - else look_ahead code n is_loop_header predicate + 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 + ) exception HeuristicSucceeded let do_call_heuristic code ifso ifnot is_loop_header preferred = - let predicate = function + let predicate n = (function | Icall _ -> true - | _ -> false + | _ -> false) @@ get_some @@ PTree.get n code in if (look_ahead code ifso is_loop_header predicate) then (preferred := false; raise HeuristicSucceeded) else if (look_ahead code ifnot is_loop_header predicate) then @@ -213,9 +216,9 @@ let do_opcode_heuristic code cond ifso ifnot is_loop_header preferred = () have a heuristic function in its folder *) let do_return_heuristic code ifso ifnot is_loop_header preferred = - let predicate = function + let predicate n = (function | Ireturn _ -> true - | _ -> false + | _ -> false) @@ get_some @@ PTree.get n code in if (look_ahead code ifso is_loop_header predicate) then (preferred := false; raise HeuristicSucceeded) else if (look_ahead code ifnot is_loop_header predicate) then @@ -223,9 +226,9 @@ let do_return_heuristic code ifso ifnot is_loop_header preferred = else () let do_store_heuristic code ifso ifnot is_loop_header preferred = - let predicate = function + let predicate n = (function | Istore _ -> true - | _ -> false + | _ -> false) @@ get_some @@ PTree.get n code in if (look_ahead code ifso is_loop_header predicate) then (preferred := false; raise HeuristicSucceeded) else if (look_ahead code ifnot is_loop_header predicate) then @@ -233,9 +236,10 @@ let do_store_heuristic code ifso ifnot is_loop_header preferred = else () let do_loop_heuristic code ifso ifnot is_loop_header preferred = - if (get_some @@ PTree.get ifso is_loop_header) then + let predicate n = get_some @@ PTree.get n is_loop_header + in if (look_ahead code ifso is_loop_header predicate) then (preferred := true; raise HeuristicSucceeded) - else if (get_some @@ PTree.get ifnot is_loop_header) then + else if (look_ahead code ifnot is_loop_header predicate) then (preferred := false; raise HeuristicSucceeded) else () @@ -257,6 +261,7 @@ let get_directions code entrypoint = do_return_heuristic code ifso ifnot is_loop_header preferred; do_store_heuristic code ifso ifnot is_loop_header preferred; do_loop_heuristic code ifso ifnot is_loop_header preferred; + Printf.printf "Random choice for %d\n" (P.to_int n); preferred := Random.bool () with HeuristicSucceeded -> () ); directions := PTree.set n !preferred !directions @@ -288,6 +293,9 @@ let rec to_ttl_code_rec directions = function let to_ttl_code code entrypoint = let directions = get_directions code entrypoint in begin + Printf.printf "Non-ifso directions: "; + ptree_printbool directions; + Printf.printf "\n"; Random.init(0); (* using same seed to make it deterministic *) to_ttl_code_rec directions (PTree.elements code) end -- cgit From 9937f23871513d4bf77db5b541a93f6327365f1e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 11 Dec 2019 19:08:50 +0100 Subject: begin overlap proofs --- mppa_k1c/Asmblockdeps.v | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c7cfe43c..2b2627e7 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -22,6 +22,8 @@ Require Import Parallelizability. Require Import Asmvliw Permutation. Require Import Chunks. +Require Import Lia. + Open Scope impure. (** Definition of L *) @@ -208,6 +210,47 @@ Definition store_eval (so: store_op) (l: list value) := | _, _ => None end. +Local Open Scope Z. + +Definition no_overlap_segments l1 h1 l2 h2 := + (h1 <=? l2) || (h2 <=? l1). + +Definition in_segment l h x := + (l <=? x) && (x + (in_segment l2 h2 x) = true -> + (no_overlap_segments l1 h1 l2 h2) = false. +Proof. + unfold in_segment, no_overlap_segments. + intros until x. + intros H1 H2. + destruct (andb_true_iff (l1 <=? x) (x + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1'] = Some (Memstate m2). + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From fd1d1f8c981332afad01b36915bc5b06d4066f70 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Dec 2019 15:24:27 +0100 Subject: some subgoal was proved --- mppa_k1c/Asmblockdeps.v | 67 ++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 61 insertions(+), 6 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2b2627e7..0f534350 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -244,13 +244,68 @@ Proof. rewrite Z.leb_le. lia. Qed. - -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1', - store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1'] = Some (Memstate m2). +Definition no_overlap_chunks + (ofs1 : offset) (chunk1 : memory_chunk) + (ofs2 : offset) (chunk2 : memory_chunk) := + no_overlap_segments (Ptrofs.unsigned ofs1) + ((Ptrofs.unsigned ofs1) + (size_chunk chunk1)) + (Ptrofs.unsigned ofs2) + ((Ptrofs.unsigned ofs2) + (size_chunk chunk2)). + +Definition same_memory (m m' : mem) := + forall chunk block ofs, + (Mem.load chunk m block ofs) = (Mem.load chunk m' block ofs). + +(* use something like load_store_other *) +Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', + (no_overlap_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2))=true -> + same_memory m0 m0' -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0'] = Some (Memstate m1') -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> + same_memory m2 m2'. +Proof. + intros until m2'. + intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. + unfold same_memory. + intros rchunk rblock rofs. + unfold no_overlap_chunks in NO_OVERLAP. + unfold no_overlap_segments in NO_OVERLAP. + rewrite orb_true_iff in NO_OVERLAP. + rewrite Z.leb_le in NO_OVERLAP. + rewrite Z.leb_le in NO_OVERLAP. + destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. + destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + destruct Ge. + destruct (eval_offset ofs1) as [ i1 |]; try congruence. + destruct (eval_offset ofs2) as [ i2 |]; try congruence. + unfold Mem.storev in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store (store_chunk n1) m0 _ _ _) eqn:HS0; try congruence. + inv STORE0. + destruct (Mem.store (store_chunk n2) m1 _ _ _) eqn:HS1; try congruence. + inv STORE1. + destruct (Mem.store (store_chunk n2) m0' _ _ _) eqn:HS0'; try congruence. + inv STORE0'. + destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. + inv STORE1'. + destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. + { admit. + } + { (* read from different base block *) + rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. + rewrite (Mem.load_store_other (store_chunk n1) m0 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m1 HS0) by tauto. + rewrite (Mem.load_store_other (store_chunk n1) m1' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m2' HS1') by tauto. + rewrite (Mem.load_store_other (store_chunk n2) m0' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m1' HS0') by tauto. + apply SAME. + } +Admitted. + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From 16f2ac997f1de1d8d519eab9a4907de171ea02d8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Dec 2019 11:22:10 +0100 Subject: set_disjoint --- lib/Maps.v | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/lib/Maps.v b/lib/Maps.v index 9e44a7fe..1dec59a2 100644 --- a/lib/Maps.v +++ b/lib/Maps.v @@ -958,6 +958,36 @@ Module PTree <: TREE. intros. apply fold1_xelements with (l := @nil (positive * A)). Qed. + Local Open Scope positive. + Lemma set_disjoint1: + forall (A: Type)(i d : elt) (m: t A) (x y: A), + set (i + d) y (set i x m) = set i x (set (i + d) y m). + Proof. + induction i; destruct d; destruct m; intro; simpl; trivial; + intro; congruence. + Qed. + + Local Open Scope positive. + Lemma set_disjoint: + forall (A: Type)(i j : elt) (m: t A) (x y: A), + i <> j -> + set j y (set i x m) = set i x (set j y m). + Proof. + intros. + destruct (Pos.compare_spec i j) as [Heq | Hlt | Hlt]. + { congruence. } + { + rewrite (Pos.lt_iff_add i j) in Hlt. + destruct Hlt as [d Hd]. + subst j. + apply set_disjoint1. + } + rewrite (Pos.lt_iff_add j i) in Hlt. + destruct Hlt as [d Hd]. + subst i. + symmetry. + apply set_disjoint1. + Qed. End PTree. (** * An implementation of maps over type [positive] *) @@ -1035,6 +1065,15 @@ Module PMap <: MAP. intros. unfold set. simpl. decEq. apply PTree.set2. Qed. + Local Open Scope positive. + Lemma set_disjoint: + forall (A: Type) (i j : elt) (x y: A) (m: t A), + i <> j -> + set j y (set i x m) = set i x (set j y m). + Proof. + intros. unfold set. decEq. apply PTree.set_disjoint. assumption. + Qed. + End PMap. (** * An implementation of maps over any type that injects into type [positive] *) @@ -1102,6 +1141,16 @@ Module IMap(X: INDEXED_TYPE). intros. unfold set. apply PMap.set2. Qed. + Lemma set_disjoint: + forall (A: Type) (i j : elt) (x y: A) (m: t A), + i <> j -> + set j y (set i x m) = set i x (set j y m). + Proof. + intros. unfold set. apply PMap.set_disjoint. + intro INEQ. + assert (i = j) by (apply X.index_inj; auto). + auto. + Qed. End IMap. Module ZIndexed. -- cgit From 452f2fcb343fc5b579aa3fa122c8b97c170b14af Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Dec 2019 13:01:59 +0100 Subject: swap writes in memory --- common/Memory.v | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/common/Memory.v b/common/Memory.v index cfd13601..f14a19d7 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -38,6 +38,7 @@ Require Import Floats. Require Import Values. Require Export Memdata. Require Export Memtype. +Require Import Lia. Definition default_notrap_load_value (chunk : memory_chunk) := Vundef. @@ -541,6 +542,48 @@ Proof. induction vl; simpl; intros. auto. rewrite IHvl. auto. Qed. +Remark set_setN_swap_disjoint: + forall vl: list memval, + forall v: memval, + forall m : ZMap.t memval, + forall p pl: Z, + ~ (Intv.In p (pl, pl + Z.of_nat (length vl))) -> + (setN vl pl (ZMap.set p v m)) = (ZMap.set p v (setN vl pl m)). +Proof. + induction vl; simpl; trivial. + intros. + unfold Intv.In in *; simpl in *. + rewrite ZMap.set_disjoint by lia. + apply IHvl. + lia. +Qed. + +Lemma set_swap_disjoint: + forall vl1 vl2: list memval, + forall m : ZMap.t memval, + forall p1 p2: Z, + Intv.disjoint (p1, p1 + Z.of_nat (length vl1)) + (p2, p2 + Z.of_nat (length vl2)) -> + (setN vl1 p1 (setN vl2 p2 m)) = (setN vl2 p2 (setN vl1 p1 m)). +Proof. + induction vl1; simpl; trivial. + intros until p2. intro DISJOINT. + rewrite <- set_setN_swap_disjoint. + { rewrite IHvl1. + reflexivity. + unfold Intv.disjoint, Intv.In in *. + simpl in *. + intro. + intro BOUNDS. + apply DISJOINT. + lia. + } + unfold Intv.disjoint, Intv.In in *. + simpl in *. + apply DISJOINT. + lia. +Qed. + (** [store chunk m b ofs v] perform a write in memory state [m]. Value [v] is stored at address [b] and offset [ofs]. Return the updated memory store, or [None] if the accessed bytes -- cgit From db03f4f3f90d7eab399177fc3f27ac027c10bc9f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Dec 2019 13:10:01 +0100 Subject: progress in chunks --- mppa_k1c/Asmblockdeps.v | 54 +++++++++---------------------------------------- 1 file changed, 9 insertions(+), 45 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 0f534350..c54cc317 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -212,46 +212,13 @@ Definition store_eval (so: store_op) (l: list value) := Local Open Scope Z. -Definition no_overlap_segments l1 h1 l2 h2 := - (h1 <=? l2) || (h2 <=? l1). - -Definition in_segment l h x := - (l <=? x) && (x - (in_segment l2 h2 x) = true -> - (no_overlap_segments l1 h1 l2 h2) = false. -Proof. - unfold in_segment, no_overlap_segments. - intros until x. - intros H1 H2. - destruct (andb_true_iff (l1 <=? x) (x + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> same_memory m0 m0' -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> @@ -271,11 +238,7 @@ Proof. intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. unfold same_memory. intros rchunk rblock rofs. - unfold no_overlap_chunks in NO_OVERLAP. - unfold no_overlap_segments in NO_OVERLAP. - rewrite orb_true_iff in NO_OVERLAP. - rewrite Z.leb_le in NO_OVERLAP. - rewrite Z.leb_le in NO_OVERLAP. + unfold disjoint_chunks in NO_OVERLAP. destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. destruct va as [base | ]; try congruence. @@ -295,7 +258,8 @@ Proof. destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. inv STORE1'. destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. - { admit. + { subst rblock. + admit. } { (* read from different base block *) rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. -- cgit From 70bd68aabcbf27ce525bb565b85fb41e3db4ded3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Dec 2019 19:06:56 +0100 Subject: store_store_other --- common/Memory.v | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 84 insertions(+), 1 deletion(-) diff --git a/common/Memory.v b/common/Memory.v index f14a19d7..50e339e1 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -558,7 +558,7 @@ Proof. lia. Qed. -Lemma set_swap_disjoint: +Lemma setN_swap_disjoint: forall vl1 vl2: list memval, forall m : ZMap.t memval, forall p1 p2: Z, @@ -1215,6 +1215,89 @@ Local Hint Resolve store_valid_block_1 store_valid_block_2: mem. Local Hint Resolve store_valid_access_1 store_valid_access_2 store_valid_access_3: mem. +Remark mem_same_proof_irr : + forall m1 m2 : mem, + (mem_contents m1) = (mem_contents m2) -> + (mem_access m1) = (mem_access m2) -> + (nextblock m1) = (nextblock m2) -> + m1 = m2. +Proof. + destruct m1 as [contents1 access1 nextblock1 access_max1 nextblock_noaccess1 default1]. + destruct m2 as [contents2 access2 nextblock2 access_max2 nextblock_noaccess2 default2]. + simpl. + intros. + subst contents2. + subst access2. + subst nextblock2. + f_equal; apply proof_irr. +Qed. + +Theorem store_store_other: + forall chunk b ofs v chunk' b' ofs' v' m0 m1 m1', + b' <> b + \/ ofs' + size_chunk chunk' <= ofs + \/ ofs + size_chunk chunk <= ofs' -> + store chunk m0 b ofs v = Some m1 -> + store chunk' m0 b' ofs' v' = Some m1' -> + store chunk' m1 b' ofs' v' = + store chunk m1' b ofs v. +Proof. + intros until m1'. + intro DISJOINT. + intros W0 W0'. + assert (valid_access m1' chunk b ofs Writable) as WRITEABLE1' by eauto with mem. + (* { + eapply store_valid_access_1. + apply W0'. + eapply store_valid_access_3. + apply W0. + } *) + assert (valid_access m1 chunk' b' ofs' Writable) as WRITABLE1 by eauto with mem. + (* { + eapply store_valid_access_1. + apply W0. + eapply store_valid_access_3. + apply W0'. + } *) + unfold store in *. + destruct (valid_access_dec m0 chunk b ofs Writable). + 2: congruence. + destruct (valid_access_dec m1 chunk' b' ofs' Writable). + 2: contradiction. + destruct (valid_access_dec m0 chunk' b' ofs' Writable). + 2: congruence. + destruct (valid_access_dec m1' chunk b ofs Writable). + 2: contradiction. + f_equal. + inv W0; simpl in *. + inv W0'; simpl in *. + apply mem_same_proof_irr; simpl; trivial. + destruct (eq_block b b'). + { subst b'. + rewrite PMap.gss. + rewrite PMap.gss. + rewrite PMap.set2. + rewrite PMap.set2. + f_equal. + apply setN_swap_disjoint. + unfold Intv.disjoint. + rewrite encode_val_length. + rewrite <- size_chunk_conv. + rewrite encode_val_length. + rewrite <- size_chunk_conv. + unfold Intv.In; simpl. + intros. + destruct DISJOINT. contradiction. + lia. + } + { + rewrite PMap.set_disjoint by congruence. + rewrite PMap.gso by congruence. + rewrite PMap.gso by congruence. + reflexivity. + } +Qed. + Lemma load_store_overlap: forall chunk m1 b ofs v m2 chunk' ofs' v', store chunk m1 b ofs v = Some m2 -> -- cgit From ce3f5cd4afdd5f5794b9c0a7480947b25e3685d0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Dec 2019 08:58:12 +0100 Subject: comment out theorem that cannot be proved --- mppa_k1c/Asmblockdeps.v | 62 ++++++++++++++++++++++++++----------------------- 1 file changed, 33 insertions(+), 29 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c54cc317..4d53763c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -212,6 +212,12 @@ Definition store_eval (so: store_op) (l: list value) := Local Open Scope Z. +Remark size_chunk_positive: forall chunk, + (size_chunk chunk) > 0. +Proof. + destruct chunk; simpl; lia. +Qed. + Definition disjoint_chunks (ofs1 : offset) (chunk1 : memory_chunk) (ofs2 : offset) (chunk2 : memory_chunk) := @@ -220,56 +226,54 @@ Definition disjoint_chunks ((Ptrofs.unsigned ofs2), ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). -Definition same_memory (m m' : mem) := - forall chunk block ofs, - (Mem.load chunk m block ofs) = (Mem.load chunk m' block ofs). - +(* THIS CANNOT BE PROVED DUE TO OVERFLOW WRAPPING (* use something like load_store_other *) Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> - same_memory m0 m0' -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0'] = Some (Memstate m1') -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> - same_memory m2 m2'. + m2 = m2'. Proof. intros until m2'. - intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. - unfold same_memory. - intros rchunk rblock rofs. - unfold disjoint_chunks in NO_OVERLAP. + intros DISJOINT STORE0 STORE1 STORE0' STORE1'. + unfold disjoint_chunks in DISJOINT. destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. destruct va as [base | ]; try congruence. unfold exec_store_deps_offset in *. destruct Ge. - destruct (eval_offset ofs1) as [ i1 |]; try congruence. - destruct (eval_offset ofs2) as [ i2 |]; try congruence. + unfold eval_offset in *; simpl in *. unfold Mem.storev in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store (store_chunk n1) m0 _ _ _) eqn:HS0; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. inv STORE0. - destruct (Mem.store (store_chunk n2) m1 _ _ _) eqn:HS1; try congruence. + destruct (Mem.store _ _ _ _) eqn:E1 in STORE1; try congruence. inv STORE1. - destruct (Mem.store (store_chunk n2) m0' _ _ _) eqn:HS0'; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0' in STORE0'; try congruence. inv STORE0'. - destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. + destruct (Mem.store _ _ _ _) eqn:E1' in STORE1'; try congruence. inv STORE1'. - destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. - { subst rblock. - admit. - } - { (* read from different base block *) - rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. - rewrite (Mem.load_store_other (store_chunk n1) m0 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m1 HS0) by tauto. - rewrite (Mem.load_store_other (store_chunk n1) m1' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m2' HS1') by tauto. - rewrite (Mem.load_store_other (store_chunk n2) m0' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m1' HS0') by tauto. - apply SAME. - } -Admitted. - + assert (Some m2 = Some m2'). + 2: congruence. + rewrite <- E1. + rewrite <- E1'. + eapply Mem.store_store_other. + { + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (store_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1, 2: lia. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + try lia. + } +*) + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From 34518ae5db9ca7c04d9ce5d90261ede3c9d0e550 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 16 Dec 2019 14:45:56 +0100 Subject: swap stores at disjoint offsets --- mppa_k1c/Asmblockdeps.v | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4d53763c..759b4396 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -218,6 +218,12 @@ Proof. destruct chunk; simpl; lia. Qed. +Remark size_chunk_small: forall chunk, + (size_chunk chunk) <= 8. +Proof. + destruct chunk; simpl; lia. +Qed. + Definition disjoint_chunks (ofs1 : offset) (chunk1 : memory_chunk) (ofs2 : offset) (chunk2 : memory_chunk) := @@ -226,18 +232,20 @@ Definition disjoint_chunks ((Ptrofs.unsigned ofs2), ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). -(* THIS CANNOT BE PROVED DUE TO OVERFLOW WRAPPING -(* use something like load_store_other *) -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', +Definition small_offset_threshold := 18446744073709551608. + +Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0'] = Some (Memstate m1') -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> m2 = m2'. Proof. intros until m2'. - intros DISJOINT STORE0 STORE1 STORE0' STORE1'. + intros DISJOINT SMALL1 SMALL2 STORE0 STORE1 STORE0' STORE1'. unfold disjoint_chunks in DISJOINT. destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. @@ -261,18 +269,24 @@ Proof. rewrite <- E1. rewrite <- E1'. eapply Mem.store_store_other. - { - right. - pose proof (size_chunk_positive (store_chunk n1)). - pose proof (size_chunk_positive (store_chunk n2)). - destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; - unfold Intv.empty in DIS; simpl in DIS. - 1, 2: lia. - destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + 2, 3: eassumption. + + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (store_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (store_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1, 2: lia. + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; - try lia. - } -*) + change Ptrofs.modulus with 18446744073709551616 in *; + lia. +Qed. Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with -- cgit From 26775340b173fd631e850f0a553ddab25c934fbc Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 16 Dec 2019 16:03:12 +0100 Subject: Stub for opcode heuristic --- backend/DuplicateOpcodeHeuristic.mli | 10 ++++++++++ backend/Duplicateaux.ml | 6 ++---- mppa_k1c/DuplicateOpcodeHeuristic.ml | 4 ++++ 3 files changed, 16 insertions(+), 4 deletions(-) create mode 100644 backend/DuplicateOpcodeHeuristic.mli create mode 100644 mppa_k1c/DuplicateOpcodeHeuristic.ml diff --git a/backend/DuplicateOpcodeHeuristic.mli b/backend/DuplicateOpcodeHeuristic.mli new file mode 100644 index 00000000..a4cc4848 --- /dev/null +++ b/backend/DuplicateOpcodeHeuristic.mli @@ -0,0 +1,10 @@ +(** Define opcode heuristics used for the instruction duplication oracle + * In particular, it is used to figure out which "branch" should be privileged + * when selecting a trace. + *) + +(* The bool reference should be updated to [true] if the condition is supposed + * to hold, [false] if it is supposed to not hold + * The function should raise HeuristicSucceeded if it succeeded to predict a branch, + * and do nothing otherwise *) +val opcode_heuristic : RTL.code -> Op.condition -> RTL.node -> RTL.node -> bool ref -> unit diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 71f44776..1fecd0d9 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -211,9 +211,7 @@ let do_call_heuristic code ifso ifnot is_loop_header preferred = (preferred := true; raise HeuristicSucceeded) else () -let do_opcode_heuristic code cond ifso ifnot is_loop_header preferred = () - (* TODO - the condition is architecture dependent, so each archi should - have a heuristic function in its folder *) +let do_opcode_heuristic code cond ifso ifnot preferred = DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot preferred let do_return_heuristic code ifso ifnot is_loop_header preferred = let predicate n = (function @@ -257,7 +255,7 @@ let get_directions code entrypoint = let preferred = ref false in (try do_call_heuristic code ifso ifnot is_loop_header preferred; - do_opcode_heuristic code cond ifso ifnot is_loop_header preferred; + do_opcode_heuristic code cond ifso ifnot preferred; do_return_heuristic code ifso ifnot is_loop_header preferred; do_store_heuristic code ifso ifnot is_loop_header preferred; do_loop_heuristic code ifso ifnot is_loop_header preferred; diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..fe9307f2 --- /dev/null +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,4 @@ +(* open Camlcoq *) +(* open Op *) + +let opcode_heuristic code cond ifso ifnot preferred = () -- cgit From dc7ba7bf86828da813e60d60dc9627cbd6ddcf0e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 16 Dec 2019 16:45:14 +0100 Subject: swap load and store at disjoint offsets --- mppa_k1c/Asmblockdeps.v | 54 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 53 insertions(+), 1 deletion(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 759b4396..2cdf9499 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -234,7 +234,8 @@ Definition disjoint_chunks Definition small_offset_threshold := 18446744073709551608. -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', +Lemma store_store_disjoint_offsets : + forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> (Ptrofs.unsigned ofs1) < small_offset_threshold -> (Ptrofs.unsigned ofs2) < small_offset_threshold -> @@ -288,6 +289,57 @@ Proof. lia. Qed. +Lemma load_store_disjoint_offsets : + forall n1 n2 tm ofs1 ofs2 vs va m0 m1, + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (load_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> + store_eval (OStoreRRO n1 ofs1) [vs; va; Memstate m0] = Some (Memstate m1) -> + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m1] = + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m0]. +Proof. + intros until m1. + intros DISJOINT SMALL1 SMALL2 STORE0. + destruct vs as [v | ]; simpl in STORE0; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + unfold eval_offset in *; simpl in *. + unfold exec_load_deps_offset. + unfold Mem.storev, Mem.loadv in *. + destruct Ge in *. + unfold eval_offset in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + inv STORE0. + assert ( + (Mem.load (load_chunk n2) m1 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) = + (Mem.load (load_chunk n2) m0 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) ) as LOADS. + { + eapply Mem.load_store_other. + eassumption. + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (load_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (load_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1,2: lia. + + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + change Ptrofs.modulus with 18446744073709551616 in *; + lia. + } + destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence. +Qed. + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From aed1bf936b69464f99a92133a43d51664295d780 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 16 Dec 2019 16:55:40 +0100 Subject: Opcode heuristic done for K1c --- backend/DuplicateOpcodeHeuristic.mli | 2 ++ backend/Duplicateaux.ml | 2 +- mppa_k1c/DuplicateOpcodeHeuristic.ml | 32 ++++++++++++++++++++++++++++++-- 3 files changed, 33 insertions(+), 3 deletions(-) diff --git a/backend/DuplicateOpcodeHeuristic.mli b/backend/DuplicateOpcodeHeuristic.mli index a4cc4848..b4c9f1ef 100644 --- a/backend/DuplicateOpcodeHeuristic.mli +++ b/backend/DuplicateOpcodeHeuristic.mli @@ -3,6 +3,8 @@ * when selecting a trace. *) +exception HeuristicSucceeded + (* The bool reference should be updated to [true] if the condition is supposed * to hold, [false] if it is supposed to not hold * The function should raise HeuristicSucceeded if it succeeded to predict a branch, diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 1fecd0d9..a987d73f 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -261,7 +261,7 @@ let get_directions code entrypoint = do_loop_heuristic code ifso ifnot is_loop_header preferred; Printf.printf "Random choice for %d\n" (P.to_int n); preferred := Random.bool () - with HeuristicSucceeded -> () + with HeuristicSucceeded | DuplicateOpcodeHeuristic.HeuristicSucceeded -> () ); directions := PTree.set n !preferred !directions | _ -> () ) bfs_order; diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml index fe9307f2..690553ce 100644 --- a/mppa_k1c/DuplicateOpcodeHeuristic.ml +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -1,4 +1,32 @@ (* open Camlcoq *) -(* open Op *) +open Op +open Integers -let opcode_heuristic code cond ifso ifnot preferred = () +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = + let decision = match cond with + | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccompf c | Ccompfs c -> (match c with + | Ceq -> Some false + | Cne -> Some true + | _ -> None + ) + | Cnotcompf c | Cnotcompfs c -> (match c with + | Ceq -> Some true + | Cne -> Some false + | _ -> None + ) + | _ -> None + in match decision with + | Some b -> (preferred := b; raise HeuristicSucceeded) + | None -> () -- cgit From 4dfcd7d4be18e8bc437ca170782212aa06635a95 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 13 Dec 2019 18:16:06 +0100 Subject: Remove `__builtin_nop` for some architectures. (#208) The `__builtin_nop` function is documented only for PowerPC. It was added to the other architectures by copy paste, but has no known uses. So, remove `__builtin_nop` from all architectures but PowerPC. --- aarch64/Asm.v | 4 +--- aarch64/Asmexpand.ml | 2 -- aarch64/TargetPrinter.ml | 3 --- arm/Asm.v | 2 -- arm/AsmToJSON.ml | 3 +-- arm/Asmexpand.ml | 2 -- arm/TargetPrinter.ml | 2 -- riscV/Asm.v | 4 +--- riscV/Asmexpand.ml | 2 -- riscV/TargetPrinter.ml | 2 -- x86/Asm.v | 2 -- x86/Asmexpand.ml | 3 --- x86/CBuiltins.ml | 3 --- x86/TargetPrinter.ml | 2 -- 14 files changed, 3 insertions(+), 33 deletions(-) diff --git a/aarch64/Asm.v b/aarch64/Asm.v index 47cd3051..87fcae8e 100644 --- a/aarch64/Asm.v +++ b/aarch64/Asm.v @@ -298,7 +298,6 @@ Inductive instruction: Type := | Pbtbl (r1: ireg) (tbl: list label) (**r N-way branch through a jump table *) | Pbuiltin (ef: external_function) (args: list (builtin_arg preg)) (res: builtin_res preg) (**r built-in function (pseudo) *) - | Pnop (**r no operation *) | Pcfi_adjust (ofs: int) (**r .cfi_adjust debug directive *) | Pcfi_rel_offset (ofs: int) (**r .cfi_rel_offset debug directive *) . @@ -1112,8 +1111,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmsub _ _ _ _ _ | Pfnmadd _ _ _ _ _ | Pfnmsub _ _ _ _ _ - | Pnop - | Pcfi_adjust _ + | Pcfi_adjust _ | Pcfi_rel_offset _ => Stuck end. diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index 471ad501..cbe1cf2f 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -327,8 +327,6 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () - | "__builtin_nop", [], _ -> - emit Pnop (* Byte swap *) | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> emit (Prev(W, res, a1)) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index e54673dd..f64083c4 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -473,9 +473,6 @@ module Target : TARGET = (* Floating-point conditional select *) | Pfsel(rd, r1, r2, c) -> fprintf oc " fcsel %a, %a, %a, %s\n" dreg rd dreg r1 dreg r2 (condition_name c) - (* No-op *) - | Pnop -> - fprintf oc " nop\n" (* Pseudo-instructions expanded in Asmexpand *) | Pallocframe(sz, linkofs) -> assert false | Pfreeframe(sz, linkofs) -> assert false diff --git a/arm/Asm.v b/arm/Asm.v index 194074ac..7f447c76 100644 --- a/arm/Asm.v +++ b/arm/Asm.v @@ -232,7 +232,6 @@ Inductive instruction : Type := | Prev16: ireg -> ireg -> instruction (**r reverse bytes and reverse bits. *) | Prsc: ireg -> ireg -> shift_op -> instruction (**r reverse subtract without carry. *) | Psbc: ireg -> ireg -> shift_op -> instruction (**r add with carry *) - | Pnop : instruction (**r nop instruction *) (* Add, sub, rsb versions with s suffix *) | Padds: ireg -> ireg -> shift_op -> instruction (**r integer addition with update of condition flags *) | Psubs: ireg -> ireg -> shift_op -> instruction (**r integer subtraction with update of condition flags *) @@ -815,7 +814,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfsqrt _ _ | Prsc _ _ _ | Psbc _ _ _ - | Pnop | Padds _ _ _ | Psubs _ _ _ | Prsbs _ _ _ diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml index e850fed6..599d3d7b 100644 --- a/arm/AsmToJSON.ml +++ b/arm/AsmToJSON.ml @@ -34,7 +34,7 @@ let mnemonic_names = StringSet.of_list "Pfuitos"; "Pinlineasm"; "Pisb"; "Plabel"; "Pldr"; "Ploadsymbol_lbl"; "Pldr_p"; "Pldrb"; "Pldrb_p"; "Pldrh"; "Pldrh_p"; "Pldrsb"; "Pldrsh"; "Plsl"; "Plsr"; "Pmla"; "Pmov"; "Pmovite"; "Pfmovite"; "Pmovt"; "Pmovw"; - "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Pnop"; "Porr"; "Ppush"; "Prev"; + "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Porr"; "Ppush"; "Prev"; "Prev16"; "Prsb"; "Prsbs"; "Prsc"; "Psbc"; "Psbfx"; "Psdiv"; "Psmull"; "Pstr"; "Pstr_p"; "Pstrb"; "Pstrb_p"; "Pstrh"; "Pstrh_p"; "Psub"; "Psubs"; "Pudiv";"Pumull" ] @@ -268,7 +268,6 @@ let pp_instructions pp ic = | Pmovw(r1, n) -> instruction pp "Pmovw" [Ireg r1; Long n] | Pmul(r1, r2, r3) -> instruction pp "Pmul" [Ireg r1; Ireg r2; Ireg r3] | Pmvn(r1, so) -> instruction pp "Pmvn" [Ireg r1; Shift so] - | Pnop -> instruction pp "Pnop" [] | Porr(r1, r2, so) -> instruction pp "Porr" [Ireg r1; Ireg r2; Shift so] | Ppush(rl) -> instruction pp "Ppush" (List.map (fun r -> Ireg r) rl) | Prev(r1, r2) -> instruction pp "Prev" [Ireg r1; Ireg r2] diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index 89aab5c7..5c7e5ad4 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -409,8 +409,6 @@ let expand_builtin_inline name args res = (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a - | "__builtin_nop", [], _ -> - emit Pnop (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 03e06a65..c19f36b0 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -306,8 +306,6 @@ struct fprintf oc " vsqrt.f64 %a, %a\n" freg f1 freg f2 | Psbc (r1,r2,sa) -> fprintf oc " sbc %a, %a, %a\n" ireg r1 ireg r2 shift_op sa - | Pnop -> - fprintf oc " nop\n" | Pstr(r1, r2, sa) | Pstr_a(r1, r2, sa) -> fprintf oc " str %a, [%a, %a]\n" ireg r1 ireg r2 shift_op sa | Pstrb(r1, r2, sa) -> diff --git a/riscV/Asm.v b/riscV/Asm.v index dc410a3b..50caab12 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -344,8 +344,7 @@ Inductive instruction : Type := | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction (**r built-in function (pseudo) *) - | Pnop : instruction. (**r nop instruction *) + -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) (** The pseudo-instructions are the following: @@ -986,7 +985,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmsubd _ _ _ _ | Pfnmaddd _ _ _ _ | Pfnmsubd _ _ _ _ - | Pnop => Stuck end. diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 3e734747..3c1ef39f 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -468,8 +468,6 @@ let expand_builtin_inline name args res = (fun rl -> emit (Pmulw (rl, X a, X b)); emit (Pmulhuw (rh, X a, X b))) - | "__builtin_nop", [], _ -> - emit Pnop (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 64bcea4c..9cd8236c 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -564,8 +564,6 @@ module Target : TARGET = fprintf oc " jr x5\n"; jumptables := (lbl, tbl) :: !jumptables; fprintf oc "%s end pseudoinstr btbl\n" comment - | Pnop -> - fprintf oc " nop\n" | Pbuiltin(ef, args, res) -> begin match ef with | EF_annot(kind,txt, targs) -> diff --git a/x86/Asm.v b/x86/Asm.v index 58e28c40..bbed28cb 100644 --- a/x86/Asm.v +++ b/x86/Asm.v @@ -284,7 +284,6 @@ Inductive instruction: Type := | Pmovsb | Pmovsw | Pmovw_rm (rd: ireg) (ad: addrmode) - | Pnop | Prep_movsl | Psbbl_rr (rd: ireg) (r2: ireg) | Psqrtsd (rd: freg) (r1: freg) @@ -1003,7 +1002,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmovsb | Pmovsw | Pmovw_rm _ _ - | Pnop | Prep_movsl | Psbbl_rr _ _ | Psqrtsd _ _ diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index 16426ce3..5cf52b5e 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -473,9 +473,6 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () - (* no operation *) - | "__builtin_nop", [], _ -> - emit Pnop (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml index f4f40a31..e7f714c7 100644 --- a/x86/CBuiltins.ml +++ b/x86/CBuiltins.ml @@ -73,9 +73,6 @@ let builtins = { (TVoid [], [TPtr(TInt(IUShort, []), []); TInt(IUShort, [])], false); "__builtin_write32_reversed", (TVoid [], [TPtr(TInt(IUInt, []), []); TInt(IUInt, [])], false); - (* no operation *) - "__builtin_nop", - (TVoid [], [], false); ] } diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 6159437e..30468fac 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -797,8 +797,6 @@ module Target(System: SYSTEM):TARGET = fprintf oc " movsw\n"; | Pmovw_rm (rd, a) -> fprintf oc " movw %a, %a\n" addressing a ireg16 rd - | Pnop -> - fprintf oc " nop\n" | Prep_movsl -> fprintf oc " rep movsl\n" | Psbbl_rr (res,a1) -> -- cgit From 4b042d572b943c8cb3b86b61e3282bba58f488ab Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 19 Dec 2019 23:36:01 +0100 Subject: Added error for unknown builtin functions. (#208) Previously, using an unknown builtin function was treated like any other call to an undeclared function: a warning was emitted, and an error occurred at link-time. With this commit, using an unknown builtin function is an error, like in Clang. --- cparser/Elab.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 2b04340e..3dbb9d45 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -1853,7 +1853,12 @@ let elab_expr ctx loc env a = having declared it *) match a1 with | VARIABLE n when not (Env.ident_is_bound env n) -> - warning Implicit_function_declaration "implicit declaration of function '%s' is invalid in C99" n; + let is_builtin = String.length n > 10 + && String.sub n 0 10 = "__builtin_" in + if is_builtin then + error "use of unknown builtin '%s'" n + else + warning Implicit_function_declaration "implicit declaration of function '%s' is invalid in C99" n; let ty = TFun(TInt(IInt, []), None, false, []) in (* Check against other definitions and enter in env *) let (id, sto, env, ty, linkage) = -- cgit From 7077c2ea9e86f001e805d7a2a5e7fcdfd0a8ece8 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 2 Jan 2020 14:58:37 +0100 Subject: Revert "Remove `__builtin_nop` for some architectures. (#208)" This reverts commit 4dfcd7d4be18e8bc437ca170782212aa06635a95. --- aarch64/Asm.v | 4 +++- aarch64/Asmexpand.ml | 2 ++ aarch64/TargetPrinter.ml | 3 +++ arm/Asm.v | 2 ++ arm/AsmToJSON.ml | 3 ++- arm/Asmexpand.ml | 2 ++ arm/TargetPrinter.ml | 2 ++ riscV/Asm.v | 4 +++- riscV/Asmexpand.ml | 2 ++ riscV/TargetPrinter.ml | 2 ++ x86/Asm.v | 2 ++ x86/Asmexpand.ml | 3 +++ x86/CBuiltins.ml | 3 +++ x86/TargetPrinter.ml | 2 ++ 14 files changed, 33 insertions(+), 3 deletions(-) diff --git a/aarch64/Asm.v b/aarch64/Asm.v index 87fcae8e..47cd3051 100644 --- a/aarch64/Asm.v +++ b/aarch64/Asm.v @@ -298,6 +298,7 @@ Inductive instruction: Type := | Pbtbl (r1: ireg) (tbl: list label) (**r N-way branch through a jump table *) | Pbuiltin (ef: external_function) (args: list (builtin_arg preg)) (res: builtin_res preg) (**r built-in function (pseudo) *) + | Pnop (**r no operation *) | Pcfi_adjust (ofs: int) (**r .cfi_adjust debug directive *) | Pcfi_rel_offset (ofs: int) (**r .cfi_rel_offset debug directive *) . @@ -1111,7 +1112,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmsub _ _ _ _ _ | Pfnmadd _ _ _ _ _ | Pfnmsub _ _ _ _ _ - | Pcfi_adjust _ + | Pnop + | Pcfi_adjust _ | Pcfi_rel_offset _ => Stuck end. diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index cbe1cf2f..471ad501 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -327,6 +327,8 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () + | "__builtin_nop", [], _ -> + emit Pnop (* Byte swap *) | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> emit (Prev(W, res, a1)) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index f64083c4..e54673dd 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -473,6 +473,9 @@ module Target : TARGET = (* Floating-point conditional select *) | Pfsel(rd, r1, r2, c) -> fprintf oc " fcsel %a, %a, %a, %s\n" dreg rd dreg r1 dreg r2 (condition_name c) + (* No-op *) + | Pnop -> + fprintf oc " nop\n" (* Pseudo-instructions expanded in Asmexpand *) | Pallocframe(sz, linkofs) -> assert false | Pfreeframe(sz, linkofs) -> assert false diff --git a/arm/Asm.v b/arm/Asm.v index 7f447c76..194074ac 100644 --- a/arm/Asm.v +++ b/arm/Asm.v @@ -232,6 +232,7 @@ Inductive instruction : Type := | Prev16: ireg -> ireg -> instruction (**r reverse bytes and reverse bits. *) | Prsc: ireg -> ireg -> shift_op -> instruction (**r reverse subtract without carry. *) | Psbc: ireg -> ireg -> shift_op -> instruction (**r add with carry *) + | Pnop : instruction (**r nop instruction *) (* Add, sub, rsb versions with s suffix *) | Padds: ireg -> ireg -> shift_op -> instruction (**r integer addition with update of condition flags *) | Psubs: ireg -> ireg -> shift_op -> instruction (**r integer subtraction with update of condition flags *) @@ -814,6 +815,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfsqrt _ _ | Prsc _ _ _ | Psbc _ _ _ + | Pnop | Padds _ _ _ | Psubs _ _ _ | Prsbs _ _ _ diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml index 599d3d7b..e850fed6 100644 --- a/arm/AsmToJSON.ml +++ b/arm/AsmToJSON.ml @@ -34,7 +34,7 @@ let mnemonic_names = StringSet.of_list "Pfuitos"; "Pinlineasm"; "Pisb"; "Plabel"; "Pldr"; "Ploadsymbol_lbl"; "Pldr_p"; "Pldrb"; "Pldrb_p"; "Pldrh"; "Pldrh_p"; "Pldrsb"; "Pldrsh"; "Plsl"; "Plsr"; "Pmla"; "Pmov"; "Pmovite"; "Pfmovite"; "Pmovt"; "Pmovw"; - "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Porr"; "Ppush"; "Prev"; + "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Pnop"; "Porr"; "Ppush"; "Prev"; "Prev16"; "Prsb"; "Prsbs"; "Prsc"; "Psbc"; "Psbfx"; "Psdiv"; "Psmull"; "Pstr"; "Pstr_p"; "Pstrb"; "Pstrb_p"; "Pstrh"; "Pstrh_p"; "Psub"; "Psubs"; "Pudiv";"Pumull" ] @@ -268,6 +268,7 @@ let pp_instructions pp ic = | Pmovw(r1, n) -> instruction pp "Pmovw" [Ireg r1; Long n] | Pmul(r1, r2, r3) -> instruction pp "Pmul" [Ireg r1; Ireg r2; Ireg r3] | Pmvn(r1, so) -> instruction pp "Pmvn" [Ireg r1; Shift so] + | Pnop -> instruction pp "Pnop" [] | Porr(r1, r2, so) -> instruction pp "Porr" [Ireg r1; Ireg r2; Shift so] | Ppush(rl) -> instruction pp "Ppush" (List.map (fun r -> Ireg r) rl) | Prev(r1, r2) -> instruction pp "Prev" [Ireg r1; Ireg r2] diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index 5c7e5ad4..89aab5c7 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -409,6 +409,8 @@ let expand_builtin_inline name args res = (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a + | "__builtin_nop", [], _ -> + emit Pnop (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index c19f36b0..03e06a65 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -306,6 +306,8 @@ struct fprintf oc " vsqrt.f64 %a, %a\n" freg f1 freg f2 | Psbc (r1,r2,sa) -> fprintf oc " sbc %a, %a, %a\n" ireg r1 ireg r2 shift_op sa + | Pnop -> + fprintf oc " nop\n" | Pstr(r1, r2, sa) | Pstr_a(r1, r2, sa) -> fprintf oc " str %a, [%a, %a]\n" ireg r1 ireg r2 shift_op sa | Pstrb(r1, r2, sa) -> diff --git a/riscV/Asm.v b/riscV/Asm.v index 50caab12..dc410a3b 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -344,7 +344,8 @@ Inductive instruction : Type := | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) + -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Pnop : instruction. (**r nop instruction *) (** The pseudo-instructions are the following: @@ -985,6 +986,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmsubd _ _ _ _ | Pfnmaddd _ _ _ _ | Pfnmsubd _ _ _ _ + | Pnop => Stuck end. diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 3c1ef39f..3e734747 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -468,6 +468,8 @@ let expand_builtin_inline name args res = (fun rl -> emit (Pmulw (rl, X a, X b)); emit (Pmulhuw (rh, X a, X b))) + | "__builtin_nop", [], _ -> + emit Pnop (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 9cd8236c..64bcea4c 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -564,6 +564,8 @@ module Target : TARGET = fprintf oc " jr x5\n"; jumptables := (lbl, tbl) :: !jumptables; fprintf oc "%s end pseudoinstr btbl\n" comment + | Pnop -> + fprintf oc " nop\n" | Pbuiltin(ef, args, res) -> begin match ef with | EF_annot(kind,txt, targs) -> diff --git a/x86/Asm.v b/x86/Asm.v index bbed28cb..58e28c40 100644 --- a/x86/Asm.v +++ b/x86/Asm.v @@ -284,6 +284,7 @@ Inductive instruction: Type := | Pmovsb | Pmovsw | Pmovw_rm (rd: ireg) (ad: addrmode) + | Pnop | Prep_movsl | Psbbl_rr (rd: ireg) (r2: ireg) | Psqrtsd (rd: freg) (r1: freg) @@ -1002,6 +1003,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmovsb | Pmovsw | Pmovw_rm _ _ + | Pnop | Prep_movsl | Psbbl_rr _ _ | Psqrtsd _ _ diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index 5cf52b5e..16426ce3 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -473,6 +473,9 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () + (* no operation *) + | "__builtin_nop", [], _ -> + emit Pnop (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml index e7f714c7..f4f40a31 100644 --- a/x86/CBuiltins.ml +++ b/x86/CBuiltins.ml @@ -73,6 +73,9 @@ let builtins = { (TVoid [], [TPtr(TInt(IUShort, []), []); TInt(IUShort, [])], false); "__builtin_write32_reversed", (TVoid [], [TPtr(TInt(IUInt, []), []); TInt(IUInt, [])], false); + (* no operation *) + "__builtin_nop", + (TVoid [], [], false); ] } diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 30468fac..6159437e 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -797,6 +797,8 @@ module Target(System: SYSTEM):TARGET = fprintf oc " movsw\n"; | Pmovw_rm (rd, a) -> fprintf oc " movw %a, %a\n" addressing a ireg16 rd + | Pnop -> + fprintf oc " nop\n" | Prep_movsl -> fprintf oc " rep movsl\n" | Psbbl_rr (res,a1) -> -- cgit From 2696f9b4a626229879248d7c97de252619a4e3b2 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 2 Jan 2020 15:02:20 +0100 Subject: Remove __builtin_nop from list of x86 builtins. --- x86/CBuiltins.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml index f4f40a31..e7f714c7 100644 --- a/x86/CBuiltins.ml +++ b/x86/CBuiltins.ml @@ -73,9 +73,6 @@ let builtins = { (TVoid [], [TPtr(TInt(IUShort, []), []); TInt(IUShort, [])], false); "__builtin_write32_reversed", (TVoid [], [TPtr(TInt(IUInt, []), []); TInt(IUInt, [])], false); - (* no operation *) - "__builtin_nop", - (TVoid [], [], false); ] } -- cgit From 22c73e96f9dfb4120541ee5e11334d0ba2d38fe8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 07:04:13 +0100 Subject: begin lattice --- backend/ForwardMoves.v | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) create mode 100644 backend/ForwardMoves.v diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v new file mode 100644 index 00000000..420e71f9 --- /dev/null +++ b/backend/ForwardMoves.v @@ -0,0 +1,57 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Module RELATION. + +Definition t := (PTree.t reg). +Definition eq (r1 r2 : t) := + forall x, (PTree.get x r1) = (PTree.get x r2). + +Lemma eq_refl: forall x, eq x x. +Proof. + unfold eq. + intros; reflexivity. +Qed. + +Lemma eq_sym: forall x y, eq x y -> eq y x. +Proof. + unfold eq. + intros; eauto. +Qed. + +Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. +Proof. + unfold eq. + intros; congruence. +Qed. + +Definition reg_beq (x y : reg) := + if Pos.eq_dec x y then true else false. + +Definition beq (r1 r2 : t) := PTree.beq reg_beq r1 r2. + +Lemma beq_correct: forall r1 r2, beq r1 r2 = true -> eq r1 r2. +Proof. + unfold beq, eq. intros r1 r2 EQ x. + pose proof (PTree.beq_correct reg_beq r1 r2) as CORRECT. + destruct CORRECT as [CORRECTF CORRECTB]. + pose proof (CORRECTF EQ x) as EQx. + clear CORRECTF CORRECTB EQ. + unfold reg_beq in *. + destruct (r1 ! x) as [R1x | ] in *; + destruct (r2 ! x) as [R2x | ] in *; + trivial; try contradiction. + destruct (Pos.eq_dec R1x R2x) in *; congruence. +Qed. + +(* + 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. +*) \ No newline at end of file -- cgit From b24140ca3257e9d77df8dcea22172a4b06679243 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 08:50:46 +0100 Subject: continue implementing semilattice --- backend/ForwardMoves.v | 72 +++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 65 insertions(+), 7 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 420e71f9..2a135768 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -45,13 +45,71 @@ Proof. destruct (Pos.eq_dec R1x R2x) in *; congruence. Qed. +Definition ge (r1 r2 : t) := + forall x, + match PTree.get x r1 with + | None => True + | Some v => (PTree.get x r2) = Some v + end. + +Lemma ge_refl: forall r1 r2, eq r1 r2 -> ge r1 r2. +Proof. + unfold eq, ge. + intros r1 r2 EQ x. + pose proof (EQ x) as EQx. + clear EQ. + destruct (r1 ! x). + - congruence. + - trivial. +Qed. + +Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. +Proof. + unfold ge. + intros r1 r2 r3 GE12 GE23 x. + pose proof (GE12 x) as GE12x; clear GE12. + pose proof (GE23 x) as GE23x; clear GE23. + destruct (r1 ! x); trivial. + destruct (r2 ! x); congruence. +Qed. + +Definition lub (r1 r2 : t) := + PTree.combine + (fun ov1 ov2 => + match ov1, ov2 with + | (Some v1), (Some v2) => + if Pos.eq_dec v1 v2 + then ov1 + else None + | None, _ + | _, None => None + end) + r1 r2. + +Lemma ge_lub_left: forall x y, ge (lub x y) x. +Proof. + unfold ge, lub. + intros r1 r2 x. + rewrite PTree.gcombine by reflexivity. + destruct (_ ! _); trivial. + destruct (_ ! _); trivial. + destruct (Pos.eq_dec _ _); trivial. +Qed. + +Lemma ge_lub_right: forall x y, ge (lub x y) y. +Proof. + unfold ge, lub. + intros r1 r2 x. + rewrite PTree.gcombine by reflexivity. + destruct (_ ! _); trivial. + destruct (_ ! _); trivial. + destruct (Pos.eq_dec _ _); trivial. + congruence. +Qed. + +End RELATION. + (* - 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. -*) \ No newline at end of file + *) -- cgit From 963286169bf5fb31d70377f8dfccbf7470a32212 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 09:34:02 +0100 Subject: more on semilattices (ADD_BOTTOM) --- backend/ForwardMoves.v | 118 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 114 insertions(+), 4 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 2a135768..317ffd8c 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -109,7 +109,117 @@ Qed. End RELATION. -(* - Parameter bot: t. - Axiom ge_bot: forall x, ge x bot. - *) +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) : SEMILATTICE. + 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. + -- cgit From a5be6f574c3b001254c9b370762045f1675702c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 11:16:50 +0100 Subject: transfer function --- backend/ForwardMoves.v | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 317ffd8c..ae836c1a 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -8,6 +8,8 @@ Definition t := (PTree.t reg). Definition eq (r1 r2 : t) := forall x, (PTree.get x r1) = (PTree.get x r2). +Definition top : t := PTree.empty reg. + Lemma eq_refl: forall x, eq x x. Proof. unfold eq. @@ -127,7 +129,7 @@ Module Type SEMILATTICE_WITHOUT_BOTTOM. End SEMILATTICE_WITHOUT_BOTTOM. -Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM) : SEMILATTICE. +Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM). Definition t := option L.t. Definition eq (a b : t) := match a, b with @@ -223,3 +225,44 @@ Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM) : SEMILATTICE. Qed. End ADD_BOTTOM. +Module RB := ADD_BOTTOM(RELATION). +Module DS := Dataflow_Solver(RB)(NodeSetForward). + +Definition kill (dst : reg) (rel : RELATION.t) := + PTree.remove dst rel. + +Definition move (src dst : reg) (rel : RELATION.t) := + PTree.set dst src rel. + +Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) := + match res with + | BR z => kill z rel + | BR_none => rel + | BR_splitlong hi lo => kill_builtin_res hi (kill_builtin_res lo rel) + end. + +Definition apply_instr instr x := + match instr with + | Inop _ + | Istore _ _ _ _ _ => Some x + | Iop Omove (src :: nil) dst _ => Some (move src dst x) + | Iop _ _ dst _ + | Iload _ _ _ _ dst _ + | Icall _ _ _ dst _ => Some (kill dst x) + | Ibuiltin _ _ res _ => Some (kill_builtin_res res x) + | Icond _ _ _ _ | Itailcall _ _ _ | Ijumptable _ _ | 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 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). \ No newline at end of file -- cgit From 80395b0b52beac8edafb7c4d748a3d4d45bd3fa7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 11:41:31 +0100 Subject: I *think* the transformation is now done --- backend/ForwardMoves.v | 59 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 57 insertions(+), 2 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index ae836c1a..b812b22d 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -2,6 +2,8 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. +(* Static analysis *) + Module RELATION. Definition t := (PTree.t reg). @@ -232,7 +234,10 @@ Definition kill (dst : reg) (rel : RELATION.t) := PTree.remove dst rel. Definition move (src dst : reg) (rel : RELATION.t) := - PTree.set dst src rel. + PTree.set dst (match PTree.get src rel with + | Some src' => src' + | None => src + end) rel. Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) := match res with @@ -265,4 +270,54 @@ Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t := 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). \ No newline at end of file + (apply_instr' (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top). + +Definition subst_arg (rel : RELATION.t) (x : reg) : reg := + match PTree.get x rel with + | None => x + | Some src => src + end. + +Definition subst_args rel := List.map (subst_arg rel). + +(* Transform *) +Definition transf_instr (fmap : PMap.t RB.t) (pc: node) (instr: instruction) := + match fmap !! pc with + | None => instr + | Some rel => + match instr with + | Iop op args dst s => + Iop op (subst_args rel args) dst s + | Iload trap chunk addr args dst s => + Iload trap chunk addr (subst_args rel args) dst s + | Icall sig ros args dst s => + Icall sig ros (subst_args rel args) dst s + | Itailcall sig ros args => + Itailcall sig ros (subst_args rel args) + | Icond cond args s1 s2 => + Icond cond (subst_args rel args) s1 s2 + | Ijumptable arg tbl => + Ijumptable (subst_arg rel arg) tbl + | Ireturn (Some arg) => + Ireturn (Some (subst_arg rel arg)) + | _ => instr + end + end. + +Definition transf_function (f: function) : function := + match forward_map f with + | None => f (* can't analyze due to errors ?! *) + | Some fmap => + {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := PTree.map (transf_instr fmap) f.(fn_code); + fn_entrypoint := f.(fn_entrypoint) |} + end. + + +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 2347476653201f154ffaea84f520e41cc0f32090 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 12:46:10 +0100 Subject: connect forward-moves to compiler --- Makefile | 1 + driver/Clflags.ml | 3 ++- driver/Compiler.v | 19 ++++++++++++++----- driver/Compopts.v | 3 +++ driver/Driver.ml | 1 + extraction/extraction.v | 2 ++ 6 files changed, 23 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 6f2a786e..d2c81266 100644 --- a/Makefile +++ b/Makefile @@ -89,6 +89,7 @@ BACKEND=\ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \ Unusedglob.v Unusedglobproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \ + ForwardMoves.v ForwardMovesproof.v \ Allnontrap.v Allnontrapproof.v \ Allocation.v Allocproof.v \ Tunneling.v Tunnelingproof.v \ diff --git a/driver/Clflags.ml b/driver/Clflags.ml index fd8227c9..9aa4a2bf 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -74,5 +74,6 @@ let option_fglobaladdrtmp = ref false let option_fglobaladdroffset = ref false let option_fxsaddr = ref true let option_faddx = ref false -let option_fcoalesce_mem = ref true +let option_fcoalesce_mem = ref true +let option_fforward_moves = ref true let option_all_loads_nontrap = ref false diff --git a/driver/Compiler.v b/driver/Compiler.v index 72db86e9..24964237 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -41,6 +41,7 @@ Require Renumber. Require Duplicate. Require Constprop. Require CSE. +Require ForwardMoves. Require Deadcode. Require Unusedglob. Require Allnontrap. @@ -64,6 +65,7 @@ Require Renumberproof. Require Duplicateproof. Require Constpropproof. Require CSEproof. +Require ForwardMovesproof. Require Deadcodeproof. Require Unusedglobproof. Require Allnontrapproof. @@ -138,12 +140,14 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 6) @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) @@ print (print_RTL 7) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program @@ print (print_RTL 8) - @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 9) - @@@ time "Unused globals" Unusedglob.transform_program + @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program @@ print (print_RTL 10) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 11) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -250,6 +254,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_constprop Constpropproof.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_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 @@ -295,7 +300,8 @@ Proof. 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_redundancy Deadcode.transf_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. + set (p13bis := total_if optim_forward_moves ForwardMoves.transf_program p13) in *. + destruct (partial_if optim_redundancy Deadcode.transf_program p13bis) 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. @@ -318,6 +324,7 @@ Proof. 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 p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. + exists p13bis; 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. @@ -378,7 +385,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 p23)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p24)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -404,6 +411,8 @@ Ltac DestructM := 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 ForwardMovesproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. eapply compose_forward_simulations. diff --git a/driver/Compopts.v b/driver/Compopts.v index 6e3b0d62..fdd2b1d6 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -66,6 +66,9 @@ Parameter debug: unit -> bool. (** Flag -fall-loads-nontrap. Turn user loads into non trapping. *) Parameter all_loads_nontrap: unit -> bool. +(** Flag -fforward-moves. Forward moves after CSE. *) +Parameter optim_forward_moves: 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 59b7b222..eab66a2b 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -392,6 +392,7 @@ let cmdline_actions = @ f_opt "addx" option_faddx @ 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 *) @ f_opt "fpu" option_ffpu @ f_opt "sse" option_ffpu (* backward compatibility *) diff --git a/extraction/extraction.v b/extraction/extraction.v index 828d0dac..0c19ea70 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -127,6 +127,8 @@ Extract Constant Compopts.optim_addx => "fun _ -> !Clflags.option_faddx". Extract Constant Compopts.optim_coalesce_mem => "fun _ -> !Clflags.option_fcoalesce_mem". +Extract Constant Compopts.optim_forward_moves => + "fun _ -> !Clflags.option_fforward_moves". Extract Constant Compopts.va_strict => "fun _ -> false". Extract Constant Compopts.all_loads_nontrap => -- cgit From 65cdeb76c33ddb059632c9b227e5ab13c65c6b72 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 13:02:37 +0100 Subject: add an example --- test/monniaux/moves/array.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 test/monniaux/moves/array.c diff --git a/test/monniaux/moves/array.c b/test/monniaux/moves/array.c new file mode 100644 index 00000000..faa1d96b --- /dev/null +++ b/test/monniaux/moves/array.c @@ -0,0 +1,18 @@ +void incr_double_array(double *t) { + double x0 = 1.0; + double t0 = t[0]; + double x1 = 1.0; + double t1 = t[1]; + double x2 = 1.0; + double t2 = t[2]; + double x3 = 1.0; + double t3 = t[3]; + t0 = t0 + x0; + t1 = t1 + x1; + t2 = t2 + x2; + t3 = t3 + x3; + t[0] = t0; + t[1] = t1; + t[2] = t2; + t[3] = t3; +} -- cgit From 44e97d0614bf1d66147aa9a09c1b04278ce80e87 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 13:16:27 +0100 Subject: bogus proof --- backend/ForwardMovesproof.v | 141 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 backend/ForwardMovesproof.v diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v new file mode 100644 index 00000000..936e9e56 --- /dev/null +++ b/backend/ForwardMovesproof.v @@ -0,0 +1,141 @@ +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 ForwardMoves. + + +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; trivial. + simpl. + unfold transf_function. + destruct (forward_map _); 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 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'. +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. -- cgit From bc29d9b7abd397e30bd4a9cc5b1f43b9cec409bc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 19:37:04 +0100 Subject: progressing towards a proof --- backend/ForwardMoves.v | 71 +++++++++++++------------ backend/ForwardMovesproof.v | 126 +++++++++++++++++++++++++++++++++++++++----- 2 files changed, 150 insertions(+), 47 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index b812b22d..47fd2457 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -272,48 +272,51 @@ 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). -Definition subst_arg (rel : RELATION.t) (x : reg) : reg := - match PTree.get x rel with +Definition get_rb (rb : RB.t) (x : reg) := + match rb with | None => x - | Some src => src + | Some rel => + match PTree.get x rel with + | None => x + | Some src => src + end + end. + +Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg := + match fmap with + | None => x + | Some inv => get_rb (PMap.get pc inv) x end. -Definition subst_args rel := List.map (subst_arg rel). +Definition subst_args fmap pc := List.map (subst_arg fmap pc). (* Transform *) -Definition transf_instr (fmap : PMap.t RB.t) (pc: node) (instr: instruction) := - match fmap !! pc with - | None => instr - | Some rel => - match instr with - | Iop op args dst s => - Iop op (subst_args rel args) dst s - | Iload trap chunk addr args dst s => - Iload trap chunk addr (subst_args rel args) dst s - | Icall sig ros args dst s => - Icall sig ros (subst_args rel args) dst s - | Itailcall sig ros args => - Itailcall sig ros (subst_args rel args) - | Icond cond args s1 s2 => - Icond cond (subst_args rel args) s1 s2 - | Ijumptable arg tbl => - Ijumptable (subst_arg rel arg) tbl - | Ireturn (Some arg) => - Ireturn (Some (subst_arg rel arg)) - | _ => instr - end +Definition transf_instr (fmap : option (PMap.t RB.t)) + (pc: node) (instr: instruction) := + match instr with + | Iop op args dst s => + Iop op (subst_args fmap pc args) dst s + | Iload trap chunk addr args dst s => + Iload trap chunk addr (subst_args fmap pc args) dst 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. Definition transf_function (f: function) : function := - match forward_map f with - | None => f (* can't analyze due to errors ?! *) - | Some fmap => - {| fn_sig := f.(fn_sig); - fn_params := f.(fn_params); - fn_stacksize := f.(fn_stacksize); - fn_code := PTree.map (transf_instr fmap) f.(fn_code); - fn_entrypoint := f.(fn_entrypoint) |} - end. + {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := PTree.map (transf_instr (forward_map f)) f.(fn_code); + fn_entrypoint := f.(fn_entrypoint) |}. Definition transf_fundef (fd: fundef) : fundef := diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 936e9e56..c56ba042 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -47,9 +47,6 @@ Lemma sig_preserved: forall f, funsig (transf_fundef f) = funsig f. Proof. destruct f; trivial. - simpl. - unfold transf_function. - destruct (forward_map _); reflexivity. Qed. Lemma find_function_translated: @@ -63,35 +60,58 @@ Proof. 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 pc i). + (transf_function f).(fn_code)!pc = + Some(transf_instr (forward_map f) pc i). Proof. - intros until i. intro Hcode. + intros until i. intro CODE. unfold transf_function; simpl. rewrite PTree.gmap. unfold option_map. - rewrite Hcode. + rewrite CODE. + reflexivity. +Qed. + +Definition fmap_sem (fmap : option (PMap.t RB.t)) (pc : node) (rs : regset) := + forall x : reg, + (rs # (subst_arg fmap pc x)) = (rs # x). + +Lemma apply_instr'_bot : + forall code, + forall pc, + RB.eq (apply_instr' code pc RB.bot) RB.bot. +Proof. reflexivity. Qed. +(*Lemma fmap_sem_step : + forall f : function, + forall pc pc' : node, + forall instr, + (f.fn_code ! pc) = Some instr -> + In pc' (successors_instr instr) -> + (fmap_sem (forward_map f) pc rs) -> + (fmap_sem (forward_map f) pc' rs'). + *) + 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). +| match_frames_intro: forall res f sp pc rs, + (fmap_sem (forward_map f) 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'), + (STACKS: list_forall2 match_frames stk stk'), + (fmap_sem (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' @@ -106,8 +126,88 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := 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'. + exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'. Admitted. +(* + 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 *) +- 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 -> -- cgit From 2e8e84aea389d41332ebd5a569b474d3c1de23d6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 20:31:41 +0100 Subject: correct semantics for bottom --- backend/ForwardMoves.v | 12 +++++++----- backend/ForwardMovesproof.v | 47 ++++++++++++++++++++++++++++++++++++--------- 2 files changed, 45 insertions(+), 14 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 47fd2457..96a19ecd 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -272,14 +272,16 @@ 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). +Definition get_r (rel : RELATION.t) (x : reg) := + match PTree.get x rel with + | None => x + | Some src => src + end. + Definition get_rb (rb : RB.t) (x : reg) := match rb with | None => x - | Some rel => - match PTree.get x rel with - | None => x - | Some src => src - end + | Some rel => get_r rel x end. Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg := diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index c56ba042..4e24dab6 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -74,9 +74,11 @@ Proof. reflexivity. Qed. +(* Definition fmap_sem (fmap : option (PMap.t RB.t)) (pc : node) (rs : regset) := forall x : reg, (rs # (subst_arg fmap pc x)) = (rs # x). + *) Lemma apply_instr'_bot : forall code, @@ -86,15 +88,42 @@ Proof. reflexivity. Qed. -(*Lemma fmap_sem_step : - forall f : function, - forall pc pc' : node, - forall instr, - (f.fn_code ! pc) = Some instr -> - In pc' (successors_instr instr) -> - (fmap_sem (forward_map f) pc rs) -> - (fmap_sem (forward_map f) pc' rs'). - *) +Definition get_rb_sem (rb : RB.t) (rs : regset) := + match rb with + | None => False + | Some rel => + forall x : reg, + (rs # (get_r rel x)) = (rs # x) + end. + +Lemma get_rb_sem_ge: + forall rb1 rb2 : RB.t, + (RB.ge rb1 rb2) -> + forall rs : regset, + (get_rb_sem rb2 rs) -> (get_rb_sem rb1 rs). +Proof. + destruct rb1 as [r1 | ]; + destruct rb2 as [r2 | ]; + unfold get_rb_sem; + simpl; + intros GE rs RB2RS; + try contradiction. + unfold RELATION.ge in GE. + unfold get_r in *. + intro x. + pose proof (GE x) as GEx. + pose proof (RB2RS x) as RB2RSx. + destruct (r1 ! x) as [r1x | ] in *; + destruct (r2 ! x) as [r2x | ] in *; + congruence. +Qed. + +Definition fmap_sem (fmap : option (PMap.t RB.t)) + (pc : node) (rs : regset) := + match fmap with + | None => True + | Some m => get_rb_sem (PMap.get pc m) rs + end. Ltac TR_AT := match goal with -- cgit From 5be5afc63935c9dc534fe153026ff1ac4326e7c5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 22:00:23 +0100 Subject: moving forward in proofs --- backend/ForwardMovesproof.v | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 4e24dab6..34c3c688 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -156,12 +156,29 @@ 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'. -Admitted. -(* +Proof. induction 1; intros S1' MS; inv MS; try TR_AT. - (* nop *) econstructor; split. eapply exec_Inop; eauto. constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. +Admitted. +(* - (* op *) econstructor; split. eapply exec_Iop with (v := v); eauto. -- cgit From fd24564480c438da9456d781ec17bfa3ac6277c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Jan 2020 22:46:55 +0100 Subject: progressing in proofs --- backend/ForwardMoves.v | 2 + backend/ForwardMovesproof.v | 111 +++++++++++++++++++++++++++++++++++++++----- 2 files changed, 101 insertions(+), 12 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 96a19ecd..65d66b16 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -300,6 +300,8 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) Iop op (subst_args fmap pc args) dst s | Iload trap chunk addr args dst s => Iload trap chunk addr (subst_args fmap pc args) dst s + | 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 => diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 34c3c688..28befed3 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -125,6 +125,40 @@ Definition fmap_sem (fmap : option (PMap.t RB.t)) | Some m => get_rb_sem (PMap.get pc m) rs end. +Lemma subst_arg_ok: + forall f, + forall pc, + forall rs, + forall arg, + fmap_sem (forward_map f) pc rs -> + rs # (subst_arg (forward_map f) pc arg) = rs # arg. +Proof. + intros until arg. + intro SEM. + unfold fmap_sem in SEM. + destruct (forward_map f) as [map |]in *; trivial. + simpl. + unfold get_rb_sem in *. + destruct (map # pc). + 2: contradiction. + apply SEM. +Qed. + +Lemma subst_args_ok: + forall f, + forall pc, + forall rs, + fmap_sem (forward_map f) pc rs -> + forall args, + rs ## (subst_args (forward_map f) pc args) = rs ## args. +Proof. + induction args; trivial. + simpl. + f_equal. + apply subst_arg_ok; assumption. + assumption. +Qed. + Ltac TR_AT := match goal with | [ A: (fn_code _)!_ = Some _ |- _ ] => @@ -177,83 +211,136 @@ Proof. destruct (map # pc) in *; try contradiction. rewrite H. reflexivity. -Admitted. -(* - (* op *) econstructor; split. eapply exec_Iop with (v := v); eauto. - rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. + rewrite <- H0. + rewrite subst_args_ok by assumption. + apply eval_operation_preserved. exact symbols_preserved. constructor; auto. + + admit. + (* load *) - econstructor; split. assert (eval_addressing tge sp addr rs ## args = Some a). - rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + rewrite <- H0. + apply eval_addressing_preserved. exact symbols_preserved. eapply exec_Iload; eauto. + rewrite subst_args_ok; assumption. constructor; auto. + + admit. + - (* 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. + rewrite subst_args_ok; assumption. constructor; auto. + + admit. + - (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + admit. + - (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + admit. + (* call *) - econstructor; split. eapply exec_Icall with (fd := transf_fundef fd); eauto. eapply find_function_translated; eauto. apply sig_preserved. + rewrite subst_args_ok by assumption. constructor. constructor; auto. constructor. + + admit. + (* tailcall *) - econstructor; split. eapply exec_Itailcall with (fd := transf_fundef fd); eauto. eapply find_function_translated; eauto. apply sig_preserved. + rewrite subst_args_ok by assumption. 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. + + admit. + (* cond *) - econstructor; split. eapply exec_Icond; eauto. + rewrite subst_args_ok; eassumption. constructor; auto. + + admit. + (* jumptbl *) - econstructor; split. eapply exec_Ijumptable; eauto. + rewrite subst_arg_ok; eassumption. constructor; auto. + + admit. + (* return *) -- econstructor; split. - eapply exec_Ireturn; eauto. - constructor; auto. +- destruct or as [arg | ]. + { + econstructor; split. + eapply exec_Ireturn; eauto. + unfold regmap_optget. + rewrite subst_arg_ok by eassumption. + constructor; auto. + } + econstructor; split. + eapply exec_Ireturn; eauto. + constructor; auto. + + (* internal function *) - simpl. econstructor; split. eapply exec_function_internal; eauto. constructor; auto. + + admit. + (* external function *) - econstructor; split. eapply exec_function_external; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - constructor; auto. + constructor; auto. + (* return *) - inv STACKS. inv H1. econstructor; split. eapply exec_return; eauto. constructor; auto. -Qed. - *) + + admit. +Admitted. + Lemma transf_initial_states: forall S1, RTL.initial_state prog S1 -> -- cgit From 123074c38671e76dbf8678a5f116970ab2f5a799 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 06:41:49 +0100 Subject: fix bug in xfer function --- backend/ForwardMoves.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 65d66b16..0e71b6b5 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -231,7 +231,8 @@ Module RB := ADD_BOTTOM(RELATION). Module DS := Dataflow_Solver(RB)(NodeSetForward). Definition kill (dst : reg) (rel : RELATION.t) := - PTree.remove dst rel. + PTree.filter1 (fun x => if Pos.eq_dec dst x then false else true) + (PTree.remove dst rel). Definition move (src dst : reg) (rel : RELATION.t) := PTree.set dst (match PTree.get src rel with -- cgit From bea5025d84a4207011cbc8c5c435d399aa5bfdef Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 07:27:02 +0100 Subject: moving forward with proofs --- backend/ForwardMovesproof.v | 60 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 59 insertions(+), 1 deletion(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 28befed3..3db67ed6 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -159,6 +159,46 @@ Proof. assumption. Qed. +Lemma kill_ok: + forall dst, + forall mpc, + forall rs, + forall v, + get_rb_sem (Some mpc) rs -> + get_rb_sem (Some (kill dst mpc)) rs # dst <- v. +Proof. + unfold get_rb_sem. + intros until v. + intros SEM x. + destruct (Pos.eq_dec x dst) as [EQ | NEQ]. + { + subst dst. + rewrite Regmap.gss. + unfold kill, get_r. + rewrite PTree.gfilter1. + rewrite PTree.grs. + apply Regmap.gss. + } + rewrite (Regmap.gso v rs NEQ). + unfold kill, get_r in *. + rewrite PTree.gfilter1. + rewrite PTree.gro by assumption. + pose proof (SEM x) as SEMx. + destruct (mpc ! x). + { + destruct (Pos.eq_dec dst r). + { + subst dst. + rewrite Regmap.gso by assumption. + reflexivity. + } + rewrite Regmap.gso by congruence. + assumption. + } + rewrite Regmap.gso by assumption. + reflexivity. +Qed. + Ltac TR_AT := match goal with | [ A: (fn_code _)!_ = Some _ |- _ ] => @@ -230,7 +270,25 @@ Proof. rewrite subst_args_ok; assumption. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. - (* load notrap1 *) econstructor; split. -- cgit From 5787da9e4d024dc3a3190bff0fe29385abbcece9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 07:47:27 +0100 Subject: some more proof --- backend/ForwardMovesproof.v | 56 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 53 insertions(+), 3 deletions(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 3db67ed6..99b546c7 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -298,7 +298,25 @@ Proof. rewrite subst_args_ok; assumption. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. - (* load notrap2 *) econstructor; split. @@ -308,7 +326,25 @@ Proof. rewrite subst_args_ok; assumption. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. - (* store *) econstructor; split. @@ -318,7 +354,21 @@ Proof. rewrite subst_args_ok; assumption. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. (* call *) - econstructor; split. -- cgit From a36948c2af873559e5df4a2d96fdbc5bbfcfaca8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 08:02:36 +0100 Subject: fix bug and forward in proofs --- backend/ForwardMoves.v | 3 ++- backend/ForwardMovesproof.v | 17 ++++++++++++++++- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 0e71b6b5..660d0458 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -250,13 +250,14 @@ Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) := Definition apply_instr instr x := match instr with | Inop _ + | Icond _ _ _ _ | Istore _ _ _ _ _ => Some x | Iop Omove (src :: nil) dst _ => Some (move src dst x) | Iop _ _ dst _ | Iload _ _ _ _ dst _ | Icall _ _ _ dst _ => Some (kill dst x) | Ibuiltin _ _ res _ => Some (kill_builtin_res res x) - | Icond _ _ _ _ | Itailcall _ _ _ | Ijumptable _ _ | Ireturn _ => RB.bot + | Itailcall _ _ _ | Ijumptable _ _ | Ireturn _ => RB.bot end. Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t := diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 99b546c7..aa516df4 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -403,7 +403,22 @@ Proof. rewrite subst_args_ok; eassumption. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. + destruct b; tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. (* jumptbl *) - econstructor; split. -- cgit From 2e613cd29123583fb3378d5727217c359e818611 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 08:54:33 +0100 Subject: more proofs --- backend/ForwardMovesproof.v | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index aa516df4..6562fc7b 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -199,6 +199,16 @@ Proof. reflexivity. Qed. +Lemma top_ok : + forall rs, get_rb_sem (Some RELATION.top) rs. +Proof. + unfold get_rb_sem, RELATION.top. + intros. + unfold get_r. + rewrite PTree.gempty. + reflexivity. +Qed. + Ltac TR_AT := match goal with | [ A: (fn_code _)!_ = Some _ |- _ ] => @@ -447,7 +457,14 @@ Proof. eapply exec_function_internal; eauto. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := Some RELATION.top). + { + eapply DS.fixpoint_entry with (code := fn_code f) (successors := successors_instr); try eassumption. + } + apply top_ok. (* external function *) - econstructor; split. -- cgit From 36f336d8c57f053342ec794e5bc802ebb66fc82b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 08:59:28 +0100 Subject: proof for jumptable --- backend/ForwardMovesproof.v | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 6562fc7b..7727bc38 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -436,7 +436,23 @@ Proof. rewrite subst_arg_ok; eassumption. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. + apply list_nth_z_in with (n := Int.unsigned n). + assumption. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. (* return *) - destruct or as [arg | ]. -- cgit From 35a17f7c9a42e654a646114aeecfbba60fd71b06 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 09:08:15 +0100 Subject: moving forward with proofs --- backend/ForwardMoves.v | 9 +++++---- backend/ForwardMovesproof.v | 16 +++++++++++++++- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 660d0458..e820723c 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -251,13 +251,14 @@ Definition apply_instr instr x := match instr with | Inop _ | Icond _ _ _ _ - | Istore _ _ _ _ _ => Some x + | Ijumptable _ _ + | Istore _ _ _ _ _ + | Icall _ _ _ _ _ => Some x | Iop Omove (src :: nil) dst _ => Some (move src dst x) | Iop _ _ dst _ - | Iload _ _ _ _ dst _ - | Icall _ _ _ dst _ => Some (kill dst x) + | Iload _ _ _ _ dst _=> Some (kill dst x) | Ibuiltin _ _ res _ => Some (kill_builtin_res res x) - | Itailcall _ _ _ | Ijumptable _ _ | Ireturn _ => RB.bot + | Itailcall _ _ _ | Ireturn _ => RB.bot end. Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t := diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 7727bc38..c44d4084 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -388,7 +388,21 @@ Proof. rewrite subst_args_ok by assumption. constructor. constructor; auto. constructor. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. (* tailcall *) - econstructor; split. -- cgit From b4092913eceb102c52660b5e7dc9f0aefb9eb4f2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 09:28:36 +0100 Subject: we still have issues with call stacks --- backend/ForwardMoves.v | 6 ++--- backend/ForwardMovesproof.v | 60 ++++++++++++++++++++++++++++++++++++--------- 2 files changed, 51 insertions(+), 15 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index e820723c..4cc9d5bc 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -252,11 +252,11 @@ Definition apply_instr instr x := | Inop _ | Icond _ _ _ _ | Ijumptable _ _ - | Istore _ _ _ _ _ - | Icall _ _ _ _ _ => Some x + | Istore _ _ _ _ _ => Some x | Iop Omove (src :: nil) dst _ => Some (move src dst x) | Iop _ _ dst _ - | Iload _ _ _ _ dst _=> Some (kill dst x) + | Iload _ _ _ _ dst _ + | Icall _ _ _ dst _ => Some (kill dst x) | Ibuiltin _ _ res _ => Some (kill_builtin_res res x) | Itailcall _ _ _ | Ireturn _ => RB.bot end. diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index c44d4084..645030f8 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -199,6 +199,39 @@ Proof. reflexivity. Qed. +Lemma kill_weaken: + forall dst, + forall mpc, + forall rs, + get_rb_sem (Some mpc) rs -> + get_rb_sem (Some (kill dst mpc)) rs. +Proof. + unfold get_rb_sem. + intros until rs. + intros SEM x. + destruct (Pos.eq_dec x dst) as [EQ | NEQ]. + { + subst dst. + unfold kill, get_r. + rewrite PTree.gfilter1. + rewrite PTree.grs. + reflexivity. + } + unfold kill, get_r in *. + rewrite PTree.gfilter1. + rewrite PTree.gro by assumption. + pose proof (SEM x) as SEMx. + destruct (mpc ! x). + { + destruct (Pos.eq_dec dst r). + { + reflexivity. + } + assumption. + } + reflexivity. +Qed. + Lemma top_ok : forall rs, get_rb_sem (Some RELATION.top) rs. Proof. @@ -268,7 +301,7 @@ Proof. rewrite subst_args_ok by assumption. apply eval_operation_preserved. exact symbols_preserved. constructor; auto. - + admit. (* load *) @@ -391,18 +424,22 @@ Proof. simpl in *. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. - replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). { - eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. - 2: apply apply_instr'_bot. - simpl. tauto. + replace (Some (kill res 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. } - unfold apply_instr'. - unfold get_rb_sem in *. - destruct (map # pc) in *; try contradiction. - rewrite H. - reflexivity. + apply kill_weaken. + assumption. (* tailcall *) - econstructor; split. @@ -508,7 +545,6 @@ Proof. eapply exec_return; eauto. constructor; auto. - admit. Admitted. -- cgit From cb3f8a833882d1e24704530bc778b37a5b66f69c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 14:51:06 +0100 Subject: proof of return --- backend/ForwardMovesproof.v | 60 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 59 insertions(+), 1 deletion(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 645030f8..6fa70562 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -248,10 +248,48 @@ Ltac TR_AT := generalize (transf_function_at _ _ _ A); intros end. +Definition is_killed_in_map (map : PMap.t RB.t) pc res := + match PMap.get pc map with + | None => True + | Some rel => exists rel', rel = (kill res rel') + end. + +Definition is_killed_in_fmap fmap pc res := + match fmap with + | None => True + | Some map => is_killed_in_map map pc res + end. + +Definition killed_twice: + forall rel : RELATION.t, + forall res, + RELATION.eq (kill res rel) (kill res (kill res rel)). +Proof. + unfold kill, RELATION.eq. + intros. + rewrite PTree.gfilter1. + rewrite PTree.gfilter1. + destruct (Pos.eq_dec res x). + { + subst res. + rewrite PTree.grs. + rewrite PTree.grs. + reflexivity. + } + rewrite PTree.gro by congruence. + rewrite PTree.gro by congruence. + rewrite PTree.gfilter1. + rewrite PTree.gro by congruence. + destruct (rel ! x) as [relx | ]; trivial. + destruct (Pos.eq_dec res relx); trivial. + destruct (Pos.eq_dec res relx); congruence. +Qed. + Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := | match_frames_intro: forall res f sp pc rs, (fmap_sem (forward_map f) pc rs) -> - match_frames (Stackframe res f sp pc rs) + (is_killed_in_fmap (forward_map f) pc res) -> + match_frames (Stackframe res f sp pc rs) (Stackframe res (transf_function f) sp pc rs). Inductive match_states: RTL.state -> RTL.state -> Prop := @@ -421,6 +459,7 @@ Proof. rewrite subst_args_ok by assumption. constructor. constructor; auto. constructor. + { simpl in *. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. @@ -440,6 +479,8 @@ Proof. } apply kill_weaken. assumption. + } + admit. (* tailcall *) - econstructor; split. @@ -545,6 +586,23 @@ Proof. eapply exec_return; eauto. constructor; auto. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + unfold is_killed_in_fmap in H8. + unfold is_killed_in_map in H8. + destruct (map # pc) as [mpc |] in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + { + destruct H8 as [rel' REL]. + subst mpc. + apply RB.ge_refl. + simpl. + apply killed_twice. + } + apply kill_ok. + assumption. + Admitted. -- cgit From 27767971a256b97ee75deab19a01d575ee01a6e0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 9 Jan 2020 15:38:45 +0100 Subject: Fixing issue with "destruct ... in ..." tactics with Coq 8.8 --- mppa_k1c/Asmblockdeps.v | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2cdf9499..584f2339 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -257,13 +257,13 @@ Proof. unfold Mem.storev in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + destruct (Mem.store _ _ _ _ _) eqn:E0; try congruence. inv STORE0. - destruct (Mem.store _ _ _ _) eqn:E1 in STORE1; try congruence. + destruct (Mem.store (store_chunk n2) _ _ _ _) eqn:E1; try congruence. inv STORE1. - destruct (Mem.store _ _ _ _) eqn:E0' in STORE0'; try congruence. + destruct (Mem.store (store_chunk n2) m0 _ _ _) eqn:E0'; try congruence. inv STORE0'. - destruct (Mem.store _ _ _ _) eqn:E1' in STORE1'; try congruence. + destruct (Mem.store _ m1' _ _ _) eqn:E1'; try congruence. inv STORE1'. assert (Some m2 = Some m2'). 2: congruence. @@ -310,7 +310,7 @@ Proof. unfold eval_offset in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0; try congruence. inv STORE0. assert ( (Mem.load (load_chunk n2) m1 wblock -- cgit From 2e79fb4d9bb98f497d59cf52ca3df5cc90515d53 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 15:59:57 +0100 Subject: return is ok --- backend/ForwardMovesproof.v | 67 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 53 insertions(+), 14 deletions(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 6fa70562..f32fe430 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -251,7 +251,7 @@ Ltac TR_AT := Definition is_killed_in_map (map : PMap.t RB.t) pc res := match PMap.get pc map with | None => True - | Some rel => exists rel', rel = (kill res rel') + | Some rel => exists rel', RELATION.ge rel (kill res rel') end. Definition is_killed_in_fmap fmap pc res := @@ -285,6 +285,39 @@ Proof. destruct (Pos.eq_dec res relx); congruence. Qed. +Lemma get_rb_killed: + forall mpc, + forall rs, + forall rel, + forall res, + forall vres, + (get_rb_sem (Some mpc) rs) -> + (RELATION.ge mpc (kill res rel)) -> + (get_rb_sem (Some mpc) rs # res <- vres). +Proof. + simpl. + intros until vres. + intros SEM GE x. + pose proof (GE x) as GEx. + pose proof (SEM x) as SEMx. + unfold get_r in *. + destruct (mpc ! x) as [mpcx | ] in *; trivial. + unfold kill in GEx. + rewrite PTree.gfilter1 in GEx. + destruct (Pos.eq_dec res x) as [ | res_NE_x]. + { + subst res. + rewrite PTree.grs in GEx. + discriminate. + } + rewrite PTree.gro in GEx by congruence. + rewrite Regmap.gso with (i := x) by congruence. + destruct (rel ! x) as [relx | ]; try discriminate. + destruct (Pos.eq_dec res relx) as [ res_EQ_relx | res_NE_relx] in *; try discriminate. + rewrite Regmap.gso by congruence. + congruence. +Qed. + Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := | match_frames_intro: forall res f sp pc rs, (fmap_sem (forward_map f) pc rs) -> @@ -480,7 +513,22 @@ Proof. apply kill_weaken. assumption. } - admit. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. + { + eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. + 2: apply apply_instr'_bot. + simpl. tauto. + } + unfold apply_instr' in GE. + unfold fmap_sem in *. + destruct (map # pc) as [mpc |] in *; try contradiction. + rewrite H in GE. + simpl in GE. + unfold is_killed_in_fmap, is_killed_in_map. + unfold RB.ge in GE. + destruct (map # pc') as [mpc'|] eqn:MPC' in *; trivial. + eauto. (* tailcall *) - econstructor; split. @@ -590,19 +638,10 @@ Proof. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. unfold is_killed_in_fmap in H8. - unfold is_killed_in_map in H8. + unfold is_killed_in_map in H8. destruct (map # pc) as [mpc |] in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). - { - destruct H8 as [rel' REL]. - subst mpc. - apply RB.ge_refl. - simpl. - apply killed_twice. - } - apply kill_ok. - assumption. - + destruct H8 as [rel' RGE]. + eapply get_rb_killed; eauto. Admitted. -- cgit From 4074a67434fc1f1a9bed7a896242faae25cd7fc2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 9 Jan 2020 16:22:15 +0100 Subject: Fixing issue with and fabs --- runtime/include/math.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/runtime/include/math.h b/runtime/include/math.h index 060968c8..d6475df1 100644 --- a/runtime/include/math.h +++ b/runtime/include/math.h @@ -3,6 +3,8 @@ #define isfinite(__y) (fpclassify((__y)) >= FP_ZERO) +#include_next + #ifndef COMPCERT_NO_FP_MACROS #define fmin(x, y) __builtin_fmin((x),(y)) #define fmax(x, y) __builtin_fmax((x),(y)) @@ -14,5 +16,4 @@ #define fmaf(x, y, z) __builtin_fmaf((x),(y),(z)) #endif -#include_next #endif -- cgit From fb5029eb72a3a28b26f3d982c30badc8d027f405 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 17:40:52 +0100 Subject: fix move --- backend/ForwardMoves.v | 4 +- backend/ForwardMovesproof.v | 120 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 120 insertions(+), 4 deletions(-) diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 4cc9d5bc..c73b0213 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -238,7 +238,7 @@ Definition move (src dst : reg) (rel : RELATION.t) := PTree.set dst (match PTree.get src rel with | Some src' => src' | None => src - end) rel. + end) (kill dst rel). Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) := match res with @@ -257,7 +257,7 @@ Definition apply_instr instr x := | Iop _ _ dst _ | Iload _ _ _ _ dst _ | Icall _ _ _ dst _ => Some (kill dst x) - | Ibuiltin _ _ res _ => Some (kill_builtin_res res x) + | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) | Itailcall _ _ _ | Ireturn _ => RB.bot end. diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index f32fe430..8e2ba9af 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -242,6 +242,64 @@ Proof. reflexivity. Qed. +Lemma move_ok: + forall mpc : RELATION.t, + forall src res : reg, + forall rs : regset, + get_rb_sem (Some mpc) rs -> + get_rb_sem (Some (move src res mpc)) (rs # res <- (rs # src)). +Proof. + unfold get_rb_sem, move. + intros until rs. + intros SEM x. + unfold get_r in *. + destruct (Pos.eq_dec res x). + { + subst res. + rewrite PTree.gss. + rewrite Regmap.gss. + pose proof (SEM src) as SEMsrc. + destruct (mpc ! src) as [mpcsrc | ] in *. + { + destruct (Pos.eq_dec x mpcsrc). + { + subst mpcsrc. + rewrite Regmap.gss. + reflexivity. + } + rewrite Regmap.gso by congruence. + assumption. + } + destruct (Pos.eq_dec x src). + { + subst src. + rewrite Regmap.gss. + reflexivity. + } + rewrite Regmap.gso by congruence. + reflexivity. + } + rewrite PTree.gso by congruence. + rewrite Regmap.gso with (i := x) by congruence. + unfold kill. + rewrite PTree.gfilter1. + rewrite PTree.gro by congruence. + pose proof (SEM x) as SEMx. + destruct (mpc ! x) as [ r |]. + { + destruct (Pos.eq_dec res r). + { + subst r. + rewrite Regmap.gso by congruence. + trivial. + } + rewrite Regmap.gso by congruence. + assumption. + } + rewrite Regmap.gso by congruence. + reflexivity. +Qed. + Ltac TR_AT := match goal with | [ A: (fn_code _)!_ = Some _ |- _ ] => @@ -340,6 +398,24 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := match_states (Returnstate stk v m) (Returnstate stk' v m). +Lemma op_cases: + forall op, + forall args, + forall dst, + forall s, + forall x, + (exists src, op=Omove /\ args = src :: nil /\ + (apply_instr (Iop op args dst s) x) = Some (move src dst x)) + \/ + (apply_instr (Iop op args dst s) x) = Some (kill dst x). +Proof. + destruct op; try (right; simpl; reflexivity). + destruct args as [| arg0 args0t]; try (right; simpl; reflexivity). + destruct args0t as [| arg1 args1t]; try (right; simpl; reflexivity). + left. + eauto. +Qed. + Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> @@ -373,7 +449,29 @@ Proof. apply eval_operation_preserved. exact symbols_preserved. constructor; auto. - admit. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. + { + eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. + 2: apply apply_instr'_bot. + simpl. tauto. + } + unfold apply_instr' in GE. + rewrite MPC in GE. + rewrite H in GE. + + destruct (op_cases op args res pc' mpc) as [[src [OP [ARGS MOVE]]] | KILL]. + { + subst op. + subst args. + rewrite MOVE in GE. + simpl in H0. + destruct (map # pc') as [mpc' | ] in *; try discriminate. + simpl in GE. + unfold move in GE. + } (* load *) - econstructor; split. @@ -545,7 +643,25 @@ Proof. eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. - admit. + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + + apply get_rb_sem_ge with (rb2 := Some RELATION.top). + { + replace (Some RELATION.top) 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply top_ok. (* cond *) - econstructor; split. -- cgit From a8dd20cd96a1c8636add5b8b45b6ee5ff5982f9a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 17:43:52 +0100 Subject: fix move --- backend/ForwardMovesproof.v | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 8e2ba9af..b1425401 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -470,8 +470,10 @@ Proof. simpl in H0. destruct (map # pc') as [mpc' | ] in *; try discriminate. simpl in GE. - unfold move in GE. + admit. + admit. } + admit. (* load *) - econstructor; split. -- cgit From b8823bfa481e4322e809d600624c59634447ec4d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 17:50:12 +0100 Subject: nearly done --- backend/ForwardMovesproof.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index b1425401..8c036851 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -468,10 +468,12 @@ Proof. subst args. rewrite MOVE in GE. simpl in H0. - destruct (map # pc') as [mpc' | ] in *; try discriminate. simpl in GE. - admit. - admit. + apply get_rb_sem_ge with (rb2 := Some (move src res mpc)). + assumption. + replace v with (rs # src) by congruence. + apply move_ok. + assumption. } admit. -- cgit From 7d3ac44ff5b909a6d00a94e6d30748e15054daf5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Jan 2020 17:54:40 +0100 Subject: FINISHED the forward-moves pass --- backend/ForwardMovesproof.v | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 8c036851..826d4250 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -475,7 +475,11 @@ Proof. apply move_ok. assumption. } - admit. + rewrite KILL in GE. + apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + assumption. + apply kill_ok. + assumption. (* load *) - econstructor; split. @@ -762,7 +766,7 @@ Proof. destruct (map # pc) as [mpc |] in *; try contradiction. destruct H8 as [rel' RGE]. eapply get_rb_killed; eauto. -Admitted. +Qed. Lemma transf_initial_states: -- cgit From 05dca79f702bc46246d0314c33445cb11ef59223 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 13 Jan 2020 11:26:33 +0100 Subject: Typo in printf --- backend/Duplicateaux.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index a987d73f..1a41ed79 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -291,7 +291,7 @@ let rec to_ttl_code_rec directions = function let to_ttl_code code entrypoint = let directions = get_directions code entrypoint in begin - Printf.printf "Non-ifso directions: "; + Printf.printf "Ifso directions: "; ptree_printbool directions; Printf.printf "\n"; Random.init(0); (* using same seed to make it deterministic *) -- cgit From 34de8e54163be69ffb294112ab3ac2ab0a0f1999 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 Jan 2020 09:59:03 +0100 Subject: shrx1_shr --- lib/Integers.v | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/lib/Integers.v b/lib/Integers.v index 8990c78d..09053cab 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -2422,6 +2422,57 @@ Proof. bit_solve. destruct (zlt (i + unsigned (sub iwordsize y)) zwordsize); auto. Qed. +Theorem shrx1_shr: + forall x, + ltu one (repr (zwordsize - 1)) = true -> + shrx x (repr 1) = shr (add x (shru x (repr (zwordsize - 1)))) (repr 1). +Proof. + intros. + rewrite shrx_shr by assumption. + rewrite shl_mul_two_p. + rewrite mul_commut. rewrite mul_one. + change (repr 1) with one. + rewrite unsigned_one. + change (two_p 1) with 2. + unfold sub. + rewrite unsigned_one. + assert (0 <= 2 <= max_unsigned). + { + unfold max_unsigned, modulus. + unfold zwordsize in *. + unfold ltu in *. + rewrite unsigned_one in H. + rewrite unsigned_repr in H. + { + destruct (zlt 1 (Z.of_nat wordsize - 1)) as [ LT | NONE]. + 2: discriminate. + clear H. + rewrite two_power_nat_two_p. + split. + omega. + set (w := (Z.of_nat wordsize)) in *. + assert ((two_p 2) <= (two_p w)) as MONO. + { + apply two_p_monotone. + omega. + } + change (two_p 2) with 4 in MONO. + omega. + } + generalize wordsize_max_unsigned. + fold zwordsize. + generalize wordsize_pos. + omega. + } + rewrite unsigned_repr by assumption. + simpl. + rewrite shru_lt_zero. + destruct (lt x zero). + reflexivity. + rewrite add_zero. + reflexivity. +Qed. + Theorem shrx_carry: forall x y, ltu y (repr (zwordsize - 1)) = true -> -- cgit From 804e8174a944e3d8983c077502e57113ecdda6dd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 Jan 2020 10:13:57 +0100 Subject: shrx_shr_3 --- common/Values.v | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/common/Values.v b/common/Values.v index de317734..01724c99 100644 --- a/common/Values.v +++ b/common/Values.v @@ -1439,6 +1439,60 @@ Proof. assert (32 < Int.max_unsigned) by reflexivity. omega. Qed. +Theorem shrx1_shr: + forall x z, + shrx x (Vint (Int.repr 1)) = Some z -> + z = shr (add x (shru x (Vint (Int.repr 31)))) (Vint (Int.repr 1)). +Proof. + intros. destruct x; simpl in H; try discriminate. + change (Int.ltu (Int.repr 1) (Int.repr 31)) with true in H; simpl in H. + inversion_clear H. + simpl. + change (Int.ltu (Int.repr 31) Int.iwordsize) with true; simpl. + change (Int.ltu (Int.repr 1) Int.iwordsize) with true; simpl. + f_equal. + rewrite Int.shrx1_shr by reflexivity. + reflexivity. +Qed. + +Theorem shrx_shr_3: + forall n x z, + shrx x (Vint n) = Some z -> + z = (if Int.eq n Int.zero then x else + if Int.eq n Int.one + then shr (add x (shru x (Vint (Int.repr 31)))) (Vint Int.one) + else shr (add x (shru (shr x (Vint (Int.repr 31))) + (Vint (Int.sub (Int.repr 32) n)))) + (Vint n)). +Proof. + intros. destruct x; simpl in H; try discriminate. + destruct (Int.ltu n (Int.repr 31)) eqn:LT; inv H. + exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 31)) with 31; intros LT'. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. unfold Int.shrx. rewrite Int.shl_zero. unfold Int.divs. change (Int.signed Int.one) with 1. + rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. +- predSpec Int.eq Int.eq_spec n Int.one. + * subst n. simpl. + change (Int.ltu (Int.repr 31) Int.iwordsize) with true. simpl. + change (Int.ltu Int.one Int.iwordsize) with true. simpl. + f_equal. + apply Int.shrx1_shr. + reflexivity. + * clear H0. + simpl. change (Int.ltu (Int.repr 31) Int.iwordsize) with true. simpl. + replace (Int.ltu (Int.sub (Int.repr 32) n) Int.iwordsize) with true. simpl. + replace (Int.ltu n Int.iwordsize) with true. + f_equal; apply Int.shrx_shr_2; assumption. + symmetry; apply zlt_true. change (Int.unsigned n < 32); omega. + symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 32)) with 32. + assert (Int.unsigned n <> 0). + { red; intros; elim H. + rewrite <- (Int.repr_unsigned n), H0. auto. } + rewrite Int.unsigned_repr. + change (Int.unsigned Int.iwordsize) with 32; omega. + assert (32 < Int.max_unsigned) by reflexivity. omega. +Qed. + Theorem or_rolm: forall x n m1 m2, or (rolm x n m1) (rolm x n m2) = rolm x n (Int.or m1 m2). -- cgit From 9c6fac6cd52b824aaefac66089bf5c71e27845be Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 Jan 2020 11:05:36 +0100 Subject: rv32: 3-instruction signed divide-by-two sequence (as opposed to 4) --- riscV/Asmgen.v | 15 ++++++++++----- riscV/Asmgenproof.v | 2 +- riscV/Asmgenproof1.v | 22 ++++++++++++++-------- 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index a704ed74..5952aa82 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -503,11 +503,16 @@ Definition transl_op OK (Psrliw rd rs n :: k) | Oshrximm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs :: k else - Psraiw X31 rs (Int.repr 31) :: - Psrliw X31 X31 (Int.sub Int.iwordsize n) :: - Paddw X31 rs X31 :: - Psraiw rd X31 n :: k) + OK (if Int.eq n Int.zero + then Pmv rd rs :: k + else if Int.eq n Int.one + then Psrliw X31 rs (Int.repr 31) :: + Paddw X31 rs X31 :: + Psraiw rd X31 Int.one :: k + else Psraiw X31 rs (Int.repr 31) :: + Psrliw X31 X31 (Int.sub Int.iwordsize n) :: + Paddw X31 rs X31 :: + Psraiw rd X31 n :: k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 5ec57886..1f3f80d7 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -285,7 +285,7 @@ Opaque Int.eq. - apply opimm32_label; intros; exact I. - apply opimm32_label; intros; exact I. - apply opimm32_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. - apply opimm64_label; intros; exact I. - apply opimm64_label; intros; exact I. - apply opimm64_label; intros; exact I. diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index c20c4e49..3a1b6d13 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1035,17 +1035,23 @@ Opaque Int.eq. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. - (* shrximm *) - clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. + clear H. exploit Val.shrx_shr_3; eauto. intros E; subst v; clear EV. destruct (Int.eq n Int.zero). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. -+ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. ++ destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. - (* longofintu *) econstructor; split. eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. -- cgit From 93dc602bebb6293283981eac072852a5fcd3f51c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 Jan 2020 15:35:20 +0100 Subject: shrx'1_shr' --- lib/Integers.v | 128 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 127 insertions(+), 1 deletion(-) diff --git a/lib/Integers.v b/lib/Integers.v index 09053cab..277f78e3 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -4,7 +4,7 @@ (* *) (* Xavier Leroy, INRIA Paris-Rocquencourt *) (* *) -(* Copyright Institut National de Recherche en Informatique et en *) +(* Copyright Institut National de Recherstestche 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 *) @@ -1189,6 +1189,34 @@ Proof. rewrite <- half_modulus_modulus. apply unsigned_range. Qed. +Local Transparent repr. +Lemma sign_bit_of_signed: forall x, + (testbit x (zwordsize - 1)) = lt x zero. +Proof. + intro. + rewrite sign_bit_of_unsigned. + unfold lt. + unfold signed, unsigned. + simpl. + pose proof half_modulus_pos as HMOD. + destruct (zlt 0 half_modulus) as [HMOD' | HMOD']. + 2: omega. + clear HMOD'. + destruct (zlt (intval x) half_modulus) as [ LOW | HIGH]. + { + destruct x as [ix RANGE]. + simpl in *. + destruct (zlt ix 0). omega. + reflexivity. + } + destruct (zlt _ _) as [LOW' | HIGH']; trivial. + destruct x as [ix RANGE]. + simpl in *. + rewrite half_modulus_modulus in *. + omega. +Qed. +Local Opaque repr. + Lemma bits_signed: forall x i, 0 <= i -> Z.testbit (signed x) i = testbit x (if zlt i zwordsize then i else zwordsize - 1). @@ -3639,6 +3667,104 @@ Proof. unfold ltu. apply zlt_true. change (unsigned z < 63). rewrite A; omega. Qed. +Lemma shr'63: + forall x, (shr' x (Int.repr 63)) = if lt x zero then mone else zero. +Proof. + intro. + unfold shr', mone, zero. + rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; omega). + apply same_bits_eq. + intros i BIT. + rewrite testbit_repr by assumption. + rewrite Z.shiftr_spec by omega. + rewrite bits_signed by omega. + simpl. + change zwordsize with 64 in *. + destruct (zlt _ _) as [LT | GE]. + { + replace i with 0 in * by omega. + change (0 + 63) with (zwordsize - 1). + rewrite sign_bit_of_signed. + destruct (lt x _). + all: rewrite testbit_repr by (change zwordsize with 64 in *; omega). + all: simpl; reflexivity. + } + change (64 - 1) with (zwordsize - 1). + rewrite sign_bit_of_signed. + destruct (lt x _). + all: rewrite testbit_repr by (change zwordsize with 64 in *; omega). + { symmetry. + apply Ztestbit_m1. + tauto. + } + symmetry. + apply Ztestbit_0. +Qed. + +Lemma shru'63: + forall x, (shru' x (Int.repr 63)) = if lt x zero then one else zero. +Proof. + intro. + unfold shru'. + rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; omega). + apply same_bits_eq. + intros i BIT. + rewrite testbit_repr by assumption. + rewrite Z.shiftr_spec by omega. + unfold lt. + rewrite signed_zero. + unfold one, zero. + destruct (zlt _ 0) as [LT | GE]. + { + rewrite testbit_repr by assumption. + destruct (zeq i 0) as [IZERO | INONZERO]. + { subst i. + change (Z.testbit (unsigned x) (0 + 63)) with (testbit x (zwordsize - 1)). + rewrite sign_bit_of_signed. + unfold lt. + rewrite signed_zero. + destruct (zlt _ _); try omega. + reflexivity. + } + change (Z.testbit (unsigned x) (i + 63)) with (testbit x (i+63)). + rewrite bits_above by (change zwordsize with 64; omega). + rewrite Ztestbit_1. + destruct (zeq i 0); trivial. + subst i. + omega. + } + destruct (zeq i 0) as [IZERO | INONZERO]. + { subst i. + change (Z.testbit (unsigned x) (0 + 63)) with (testbit x (zwordsize - 1)). + rewrite sign_bit_of_signed. + unfold lt. + rewrite signed_zero. + rewrite bits_zero. + destruct (zlt _ _); try omega. + reflexivity. + } + change (Z.testbit (unsigned x) (i + 63)) with (testbit x (i + 63)). + rewrite bits_zero. + apply bits_above. + change zwordsize with 64. + omega. +Qed. + +Theorem shrx'1_shr': + forall x, + Int.ltu Int.one (Int.repr (zwordsize - 1)) = true -> + shrx' x (Int.repr 1) = shr' (add x (shru' x (Int.repr (Int64.zwordsize - 1)))) (Int.repr 1). +Proof. + intros. + rewrite shrx'_shr_2 by reflexivity. + change (Int.sub (Int.repr 64) (Int.repr 1)) with (Int.repr 63). + f_equal. f_equal. + rewrite shr'63. + rewrite shru'63. + rewrite shru'63. + destruct (lt x zero); reflexivity. +Qed. + Remark int_ltu_2_inv: forall y z, Int.ltu y iwordsize' = true -> -- cgit From d7c9c729ba52ae926238ab97650104117e488c05 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 Jan 2020 15:42:56 +0100 Subject: shrxl_shrl_3 --- common/Values.v | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/common/Values.v b/common/Values.v index 01724c99..84030123 100644 --- a/common/Values.v +++ b/common/Values.v @@ -1752,6 +1752,58 @@ Proof. assert (64 < Int.max_unsigned) by reflexivity. omega. Qed. +Theorem shrxl1_shrl: + forall x z, + shrxl x (Vint (Int.repr 1)) = Some z -> + z = shrl (addl x (shrlu x (Vint (Int.repr 63)))) (Vint (Int.repr 1)). +Proof. + intros. destruct x; simpl in H; try discriminate. + change (Int.ltu (Int.repr 1) (Int.repr 63)) with true in H; simpl in H. + inversion_clear H. + simpl. + change (Int.ltu (Int.repr 63) Int64.iwordsize') with true; simpl. + change (Int.ltu (Int.repr 1) Int64.iwordsize') with true; simpl. + f_equal. + rewrite Int64.shrx'1_shr' by reflexivity. + reflexivity. +Qed. + +Theorem shrxl_shrl_3: + forall n x z, + shrxl x (Vint n) = Some z -> + z = (if Int.eq n Int.zero then x else + if Int.eq n Int.one + then shrl (addl x (shrlu x (Vint (Int.repr 63)))) (Vint Int.one) + else shrl (addl x (shrlu (shrl x (Vint (Int.repr 63))) + (Vint (Int.sub (Int.repr 64) n)))) + (Vint n)). +Proof. + intros. destruct x; simpl in H; try discriminate. + destruct (Int.ltu n (Int.repr 63)) eqn:LT; inv H. + exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 63)) with 63; intros LT'. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. unfold Int64.shrx'. rewrite Int64.shl'_zero. unfold Int64.divs. change (Int64.signed Int64.one) with 1. + rewrite Z.quot_1_r. rewrite Int64.repr_signed; auto. +- predSpec Int.eq Int.eq_spec n Int.one. + * subst n. simpl. + change (Int.ltu (Int.repr 63) Int64.iwordsize') with true. simpl. + change (Int.ltu Int.one Int64.iwordsize') with true. simpl. + f_equal. + apply Int64.shrx'1_shr'. + reflexivity. + * clear H0. +simpl. change (Int.ltu (Int.repr 63) Int64.iwordsize') with true. simpl. + replace (Int.ltu (Int.sub (Int.repr 64) n) Int64.iwordsize') with true. simpl. + replace (Int.ltu n Int64.iwordsize') with true. + f_equal; apply Int64.shrx'_shr_2; assumption. + symmetry; apply zlt_true. change (Int.unsigned n < 64); omega. + symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 64)) with 64. + assert (Int.unsigned n <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned n), H0. auto. } + rewrite Int.unsigned_repr. + change (Int.unsigned Int64.iwordsize') with 64; omega. + assert (64 < Int.max_unsigned) by reflexivity. omega. +Qed. + Theorem negate_cmp_bool: forall c x y, cmp_bool (negate_comparison c) x y = option_map negb (cmp_bool c x y). Proof. -- cgit From b92d5a32c314eee0c68a70c33f1847545aabeb19 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 Jan 2020 23:07:49 +0100 Subject: 64-bit signed division by two code --- riscV/Asmgen.v | 15 ++++++++++----- riscV/Asmgenproof.v | 2 +- riscV/Asmgenproof1.v | 23 +++++++++++++++-------- 3 files changed, 26 insertions(+), 14 deletions(-) diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 5952aa82..ffc7992c 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -597,11 +597,16 @@ Definition transl_op OK (Psrlil rd rs n :: k) | Oshrxlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs :: k else - Psrail X31 rs (Int.repr 63) :: - Psrlil X31 X31 (Int.sub Int64.iwordsize' n) :: - Paddl X31 rs X31 :: - Psrail rd X31 n :: k) + OK (if Int.eq n Int.zero + then Pmv rd rs :: k + else if Int.eq n Int.one + then Psrlil X31 rs (Int.repr 63) :: + Paddl X31 rs X31 :: + Psrail rd X31 Int.one :: k + else Psrail X31 rs (Int.repr 63) :: + Psrlil X31 X31 (Int.sub Int64.iwordsize' n) :: + Paddl X31 rs X31 :: + Psrail rd X31 n :: k) | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 1f3f80d7..63287a50 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -290,7 +290,7 @@ Opaque Int.eq. - apply opimm64_label; intros; exact I. - apply opimm64_label; intros; exact I. - apply opimm64_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. - eapply transl_cond_op_label; eauto. Qed. diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 3a1b6d13..3eb503f2 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1076,17 +1076,24 @@ Opaque Int.eq. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. - (* shrxlimm *) - clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. + clear H. exploit Val.shrxl_shrl_3; eauto. intros E; subst v; clear EV. destruct (Int.eq n Int.zero). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. -+ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. ++ destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + + * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. - (* cond *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. -- cgit From 9475c5637c5d650f43955abe8f995797893affe1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 Jan 2020 23:37:20 +0100 Subject: ARM generation of 2-instruction signed division by 2 (as opposed to 3-instruction) --- arm/Asmgen.v | 3 +++ arm/Asmgenproof1.v | 24 +++++++++++++++++++++--- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/arm/Asmgen.v b/arm/Asmgen.v index 1a1e7f2f..0ec0a4d0 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -481,6 +481,9 @@ Definition transl_op do r <- ireg_of res; do r1 <- ireg_of a1; if Int.eq n Int.zero then OK (Pmov r (SOreg r1) :: k) + else if Int.eq n Int.one then + OK (Padd IR14 r1 (SOlsr r1 (Int.repr 31)) :: + Pmov r (SOasr IR14 n) :: k) else OK (Pmov IR14 (SOasr r1 (Int.repr 31)) :: Padd IR14 r1 (SOlsr IR14 (Int.sub Int.iwordsize n)) :: diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 807e069d..2b125cda 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -1264,15 +1264,32 @@ Local Transparent destroyed_by_op. destruct (rs x0) eqn: X0; simpl in H0; try discriminate. destruct (Int.ltu i (Int.repr 31)) eqn: LTU; inv H0. revert EQ2. predSpec Int.eq Int.eq_spec i Int.zero; intros EQ2. + { (* i = 0 *) inv EQ2. econstructor. split. apply exec_straight_one. simpl. reflexivity. auto. split. Simpl. unfold Int.shrx. rewrite Int.shl_zero. unfold Int.divs. change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed. auto. intros. Simpl. - (* i <> 0 *) - inv EQ2. - assert (LTU': Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize = true). + } + { (* i <> 0 *) + revert EQ2. predSpec Int.eq Int.eq_spec i Int.one; intros EQ2. + { + inv EQ2. + econstructor; split. + eapply exec_straight_two; simpl; reflexivity. + split. + { rewrite X0. + rewrite Int.shrx1_shr by reflexivity. + Simpl. + } + { intros. + Simpl. + } + } + clear H0. + inv EQ2. + assert (LTU': Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize = true). { generalize (Int.ltu_inv _ _ LTU). intros. unfold Int.sub, Int.ltu. rewrite Int.unsigned_repr_wordsize. @@ -1306,6 +1323,7 @@ Local Transparent destroyed_by_op. rewrite LTU'; simpl. rewrite LTU''; simpl. f_equal. symmetry. apply Int.shrx_shr_2. assumption. intros. unfold rs3; Simpl. unfold rs2; Simpl. unfold rs1; Simpl. + } (* intoffloat *) econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto. Transparent destroyed_by_op. -- cgit From 4393640af54ee3139e5c399e6fa1685faf483707 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 15 Jan 2020 07:46:34 +0100 Subject: 2-instruction signed division by two on Aarch64 --- aarch64/Asmgen.v | 22 +++++++++++++-------- aarch64/Asmgenproof.v | 4 ++-- aarch64/Asmgenproof1.v | 52 ++++++++++++++++++++++++++++++++++++-------------- 3 files changed, 54 insertions(+), 24 deletions(-) diff --git a/aarch64/Asmgen.v b/aarch64/Asmgen.v index 875f3fd1..daea7dd5 100644 --- a/aarch64/Asmgen.v +++ b/aarch64/Asmgen.v @@ -268,18 +268,24 @@ Definition arith_extended Definition shrx32 (rd r1: ireg) (n: int) (k: code) : code := if Int.eq n Int.zero then Pmov rd r1 :: k - else - Porr W X16 XZR r1 (SOasr (Int.repr 31)) :: - Padd W X16 r1 X16 (SOlsr (Int.sub Int.iwordsize n)) :: - Porr W rd XZR X16 (SOasr n) :: k. + else if Int.eq n Int.one then + Padd W X16 r1 r1 (SOlsr (Int.repr 31)) :: + Porr W rd XZR X16 (SOasr n) :: k + else + Porr W X16 XZR r1 (SOasr (Int.repr 31)) :: + Padd W X16 r1 X16 (SOlsr (Int.sub Int.iwordsize n)) :: + Porr W rd XZR X16 (SOasr n) :: k. Definition shrx64 (rd r1: ireg) (n: int) (k: code) : code := if Int.eq n Int.zero then Pmov rd r1 :: k - else - Porr X X16 XZR r1 (SOasr (Int.repr 63)) :: - Padd X X16 r1 X16 (SOlsr (Int.sub Int64.iwordsize' n)) :: - Porr X rd XZR X16 (SOasr n) :: k. + else if Int.eq n Int.one then + Padd X X16 r1 r1 (SOlsr (Int.repr 63)) :: + Porr X rd XZR X16 (SOasr n) :: k + else + Porr X X16 XZR r1 (SOasr (Int.repr 63)) :: + Padd X X16 r1 X16 (SOlsr (Int.sub Int64.iwordsize' n)) :: + Porr X rd XZR X16 (SOasr n) :: k. (** Load the address [id + ofs] in [rd] *) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index eeff1956..3f082b16 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -259,13 +259,13 @@ Proof. - apply logicalimm32_label; unfold nolabel; auto. - apply logicalimm32_label; unfold nolabel; auto. - apply logicalimm32_label; unfold nolabel; auto. -- unfold shrx32. destruct Int.eq; TailNoLabel. +- unfold shrx32. destruct (Int.eq _ _); try destruct (Int.eq _ _); TailNoLabel. - apply arith_extended_label; unfold nolabel; auto. - apply arith_extended_label; unfold nolabel; auto. - apply logicalimm64_label; unfold nolabel; auto. - apply logicalimm64_label; unfold nolabel; auto. - apply logicalimm64_label; unfold nolabel; auto. -- unfold shrx64. destruct Int.eq; TailNoLabel. +- unfold shrx64. destruct (Int.eq _ _); try destruct (Int.eq _ _); TailNoLabel. - eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel. - destruct (preg_of r); try discriminate; TailNoLabel; (eapply tail_nolabel_trans; [eapply transl_cond_label; eauto | TailNoLabel]). diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 6d44bcc8..d004b715 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -754,16 +754,28 @@ Lemma exec_shrx32: forall (rd r1: ireg) (n: int) k v (rs: regset) m, /\ rs'#rd = v /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. Proof. - unfold shrx32; intros. apply Val.shrx_shr_2 in H. + unfold shrx32; intros. apply Val.shrx_shr_3 in H. destruct (Int.eq n Int.zero) eqn:E. - econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. split. Simpl. subst v; auto. intros; Simpl. -- econstructor; split. eapply exec_straight_three. - unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. - simpl; eauto. - unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. - auto. auto. auto. - split. subst v; Simpl. intros; Simpl. +- generalize (Int.eq_spec n Int.one). + destruct (Int.eq n Int.one); intro ONE. + * subst n. + econstructor; split. eapply exec_straight_two. + all: simpl; auto. + split. + ** subst v; Simpl. + destruct (Val.add _ _); simpl; trivial. + change (Int.ltu Int.one Int.iwordsize) with true; simpl. + rewrite Int.or_zero_l. + reflexivity. + ** intros; Simpl. + * econstructor; split. eapply exec_straight_three. + unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. + simpl; eauto. + unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. + auto. auto. auto. + split. subst v; Simpl. intros; Simpl. Qed. Lemma exec_shrx64: forall (rd r1: ireg) (n: int) k v (rs: regset) m, @@ -774,16 +786,28 @@ Lemma exec_shrx64: forall (rd r1: ireg) (n: int) k v (rs: regset) m, /\ rs'#rd = v /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. Proof. - unfold shrx64; intros. apply Val.shrxl_shrl_2 in H. + unfold shrx64; intros. apply Val.shrxl_shrl_3 in H. destruct (Int.eq n Int.zero) eqn:E. - econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. split. Simpl. subst v; auto. intros; Simpl. -- econstructor; split. eapply exec_straight_three. - unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. - simpl; eauto. - unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. - auto. auto. auto. - split. subst v; Simpl. intros; Simpl. +- generalize (Int.eq_spec n Int.one). + destruct (Int.eq n Int.one); intro ONE. + * subst n. + econstructor; split. eapply exec_straight_two. + all: simpl; auto. + split. + ** subst v; Simpl. + destruct (Val.addl _ _); simpl; trivial. + change (Int.ltu Int.one Int64.iwordsize') with true; simpl. + rewrite Int64.or_zero_l. + reflexivity. + ** intros; Simpl. + * econstructor; split. eapply exec_straight_three. + unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. + simpl; eauto. + unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. + auto. auto. auto. + split. subst v; Simpl. intros; Simpl. Qed. (** Condition bits *) -- cgit From 675b6539607f387d43b8d7e04de31292b4246a1b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 15 Jan 2020 11:36:28 +0100 Subject: Adding more debug elements --- backend/Duplicateaux.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 1a41ed79..ec99027a 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -252,16 +252,24 @@ let get_directions code entrypoint = 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); let preferred = ref false in (try + Printf.printf " call.."; do_call_heuristic code ifso ifnot is_loop_header preferred; + Printf.printf " opcode.."; do_opcode_heuristic code cond ifso ifnot preferred; + Printf.printf " return.."; do_return_heuristic code ifso ifnot is_loop_header preferred; + Printf.printf " store.."; do_store_heuristic code ifso ifnot is_loop_header preferred; + Printf.printf " loop.."; do_loop_heuristic code ifso ifnot is_loop_header preferred; Printf.printf "Random choice for %d\n" (P.to_int n); preferred := Random.bool () - with HeuristicSucceeded | DuplicateOpcodeHeuristic.HeuristicSucceeded -> () + with HeuristicSucceeded | DuplicateOpcodeHeuristic.HeuristicSucceeded + -> Printf.printf " %s\n" (match !preferred with true -> "BRANCH" + | false -> "FALLTHROUGH") ); directions := PTree.set n !preferred !directions | _ -> () ) bfs_order; -- cgit From fd2181ce5f6a3a5ba27349d1642ee4c59a6d9b34 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 17 Jan 2020 11:08:11 +0100 Subject: Added description for forward moves --- driver/Driver.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/driver/Driver.ml b/driver/Driver.ml index eab66a2b..992cf8c4 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -199,6 +199,7 @@ Processing options: -fpostpass Perform postpass scheduling (only for K1 architecture) [on] -fpostpass= Perform postpass scheduling with the specified optimization [list] (=list: list scheduling, =ilp: ILP, =greedy: just packing bundles) + -fforward-moves Forward moves after CSE -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their single caller [on] -- cgit From e836ec02384a11e2aa87567e828d69776dd453ee Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 17 Jan 2020 15:46:37 +0100 Subject: Removed unnecessary .mli file (provoked compilation problems) --- backend/DuplicateOpcodeHeuristic.mli | 12 ------------ 1 file changed, 12 deletions(-) delete mode 100644 backend/DuplicateOpcodeHeuristic.mli diff --git a/backend/DuplicateOpcodeHeuristic.mli b/backend/DuplicateOpcodeHeuristic.mli deleted file mode 100644 index b4c9f1ef..00000000 --- a/backend/DuplicateOpcodeHeuristic.mli +++ /dev/null @@ -1,12 +0,0 @@ -(** Define opcode heuristics used for the instruction duplication oracle - * In particular, it is used to figure out which "branch" should be privileged - * when selecting a trace. - *) - -exception HeuristicSucceeded - -(* The bool reference should be updated to [true] if the condition is supposed - * to hold, [false] if it is supposed to not hold - * The function should raise HeuristicSucceeded if it succeeded to predict a branch, - * and do nothing otherwise *) -val opcode_heuristic : RTL.code -> Op.condition -> RTL.node -> RTL.node -> bool ref -> unit -- cgit From f34d5cca62ba2f7d6f7d01645092e52061812f84 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 17 Jan 2020 16:57:38 +0100 Subject: Set up the groundbase for doing the duplication --- backend/Duplicateaux.ml | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index ec99027a..54929251 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -440,12 +440,22 @@ let rec make_identity_ptree_rec = function let make_identity_ptree f = make_identity_ptree_rec (PTree.elements f.fn_code) +(* FIXME - For now, identity *) +let tail_duplicate code ptree trace = (code, ptree) + +let rec superblockify_traces code ptree = function + | [] -> (code, ptree) + | trace :: traces -> + let new_code, new_ptree = tail_duplicate code ptree trace + in superblockify_traces new_code new_ptree traces + (* For now, identity function *) let duplicate_aux f = - let pTreeId = make_identity_ptree f in let entrypoint = fn_entrypoint f in - let traces = select_traces (to_ttl_code (fn_code f) entrypoint) entrypoint - in begin + let traces = select_traces (to_ttl_code (fn_code f) entrypoint) entrypoint in + let pTreeId = make_identity_ptree f in + let (new_code, pTreeId) = superblockify_traces (fn_code f) pTreeId traces in + begin print_traces traces; - (((fn_code f), (fn_entrypoint f)), pTreeId) + ((new_code, (fn_entrypoint f)), pTreeId) end -- cgit From d3cd82c2c82727e7fb76e95e5dcce6cfa9055015 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 22 Jan 2020 16:07:28 +0100 Subject: Branch duplication implementation --- backend/Duplicateaux.ml | 106 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 94 insertions(+), 12 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 54929251..3dfc7969 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -438,23 +438,105 @@ let rec make_identity_ptree_rec = function | [] -> PTree.empty | m::lm -> let (n, _) = m in PTree.set n n (make_identity_ptree_rec lm) -let make_identity_ptree f = make_identity_ptree_rec (PTree.elements f.fn_code) - -(* FIXME - For now, identity *) -let tail_duplicate code ptree trace = (code, ptree) +let make_identity_ptree code = make_identity_ptree_rec (PTree.elements code) + +let optbool o = match o with Some _ -> true | None -> false + +(* Change the pointers of preds nodes to point to n' instead of n *) +let rec change_pointers code n n' = function + | [] -> code + | pred :: preds -> + let new_pred_inst = match ptree_get_some pred code with + | Icall(a, b, c, d, n0) -> assert (n0 == n); Icall(a, b, c, d, n') + | Ibuiltin(a, b, c, n0) -> assert (n0 == n); Ibuiltin(a, b, c, n') + | Ijumptable(a, ln) -> assert (optbool @@ List.find_opt (fun e -> e == n) ln); + Ijumptable(a, List.map (fun e -> if (e == n) then n' else e) ln) + | Icond(a, b, n1, n2) -> assert (n1 == n || n2 == n); + let n1' = if (n1 == n) then n' else n1 + in let n2' = if (n2 == n) then n' else n2 + in Icond(a, b, n1', n2') + | Inop n0 -> assert (n0 == n); Inop n' + | Iop (a, b, c, n0) -> assert (n0 == n); Iop (a, b, c, n') + | Iload (a, b, c, d, e, n0) -> assert (n0 == n); Iload (a, b, c, d, e, n') + | Istore (a, b, c, d, n0) -> assert (n0 == n); Istore (a, b, c, d, n') + | Itailcall _ | Ireturn _ -> failwith "That instruction cannot be a predecessor" + in let new_code = PTree.set pred new_pred_inst code + in change_pointers new_code n n' preds + +(* parent: parent of n to keep as parent + * preds: all the other parents of n + * n': the integer which should contain the duplicate of n + * returns: new code, new ptree *) +let duplicate code ptree parent n preds n' = + match PTree.get n' code with + | Some _ -> failwith "The PTree already has a node n'" + | None -> + let c' = change_pointers code n n' preds + in let new_code = PTree.set n' (ptree_get_some n code) c' + and new_ptree = PTree.set n' n ptree + in (new_code, new_ptree) + +let rec maxint = function + | [] -> 0 + | i :: l -> assert (i >= 0); let m = maxint l in if i > m then i else m + +let is_empty = function + | [] -> false + | _ -> true + +(* code: RTL code + * preds: mapping node -> predecessors + * ptree: the revmap + * trace: the trace to follow tail duplication on *) +let tail_duplicate code preds ptree trace = + (* next_int: unused integer that can be used for the next duplication *) + let next_int = ref (maxint (List.map (fun e -> let (n, _) = e in P.to_int n) (PTree.elements code)) + 1) + (* last_node and last_duplicate store resp. the last processed node of the trace, and its duplication *) + in let last_node = ref None + in let last_duplicate = ref None + (* recursive function on a trace *) + in let rec f code ptree is_first = function + | [] -> (code, ptree) + | n :: t -> + let (new_code, new_ptree) = + if is_first then (code, ptree) (* first node is never duplicated regardless of its inputs *) + else + let node_preds = ptree_get_some n preds + in let node_preds_nolast = List.filter (fun e -> e != get_some !last_node) node_preds + in let final_node_preds = match !last_duplicate with + | None -> node_preds_nolast + | Some n' -> n' :: node_preds_nolast + in if is_empty final_node_preds then + let n' = !next_int + in let (newc, newp) = duplicate code ptree !last_node n final_node_preds (P.of_int n') + in begin + next_int := !next_int + 1; + last_duplicate := Some (P.of_int n'); + (newc, newp) + end + else (code, ptree) + in begin + last_node := Some n; + f new_code new_ptree false t + end + in f code ptree true trace -let rec superblockify_traces code ptree = function - | [] -> (code, ptree) - | trace :: traces -> - let new_code, new_ptree = tail_duplicate code ptree trace - in superblockify_traces new_code new_ptree traces +let superblockify_traces code preds traces = + let ptree = make_identity_ptree code + in let rec f code ptree = function + | [] -> (code, ptree) + | trace :: traces -> + let new_code, new_ptree = tail_duplicate code preds ptree trace + in f new_code new_ptree traces + in f code ptree traces (* For now, identity function *) let duplicate_aux f = let entrypoint = fn_entrypoint f in - let traces = select_traces (to_ttl_code (fn_code f) entrypoint) entrypoint in - let pTreeId = make_identity_ptree f in - let (new_code, pTreeId) = superblockify_traces (fn_code f) pTreeId traces in + let code = fn_code f in + let traces = select_traces (to_ttl_code code entrypoint) entrypoint in + let preds = get_predecessors_rtl code in + let (new_code, pTreeId) = superblockify_traces code preds traces in begin print_traces traces; ((new_code, (fn_entrypoint f)), pTreeId) -- cgit From 60c15c9d1105dc2e53c17b3fb28ee9cc4716cbc6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 22 Jan 2020 16:22:44 +0100 Subject: Fixing is_empty function --- backend/Duplicateaux.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 3dfc7969..66c57cda 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -481,8 +481,8 @@ let rec maxint = function | i :: l -> assert (i >= 0); let m = maxint l in if i > m then i else m let is_empty = function - | [] -> false - | _ -> true + | [] -> true + | _ -> false (* code: RTL code * preds: mapping node -> predecessors @@ -506,7 +506,7 @@ let tail_duplicate code preds ptree trace = in let final_node_preds = match !last_duplicate with | None -> node_preds_nolast | Some n' -> n' :: node_preds_nolast - in if is_empty final_node_preds then + in if not (is_empty final_node_preds) then let n' = !next_int in let (newc, newp) = duplicate code ptree !last_node n final_node_preds (P.of_int n') in begin -- cgit From 5ce9d33ddf09747ce6cf6e3bea70097556b454f4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 22 Jan 2020 17:29:56 +0100 Subject: Fixing bug (used physical instead of structural inequality) --- backend/Duplicateaux.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 66c57cda..67fbf3ad 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -468,6 +468,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'); match PTree.get n' code with | Some _ -> failwith "The PTree already has a node n'" | None -> @@ -502,7 +503,7 @@ let tail_duplicate code preds ptree trace = if is_first then (code, ptree) (* first node is never duplicated regardless of its inputs *) else let node_preds = ptree_get_some n preds - in let node_preds_nolast = List.filter (fun e -> e != get_some !last_node) node_preds + in let node_preds_nolast = List.filter (fun e -> e <> get_some !last_node) node_preds in let final_node_preds = match !last_duplicate with | None -> node_preds_nolast | Some n' -> n' :: node_preds_nolast -- cgit From 2e0ac9f60d15de2bfd887cf823ec23d77868b297 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 23 Jan 2020 15:09:36 +0100 Subject: Printing traces right before duplicating --- backend/Duplicateaux.ml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 67fbf3ad..167a28eb 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -537,8 +537,5 @@ let duplicate_aux f = let code = fn_code f in let traces = select_traces (to_ttl_code code entrypoint) entrypoint in let preds = get_predecessors_rtl code in - let (new_code, pTreeId) = superblockify_traces code preds traces in - begin - print_traces traces; - ((new_code, (fn_entrypoint f)), pTreeId) - end + let (new_code, pTreeId) = (print_traces traces; superblockify_traces code preds traces) in + ((new_code, (fn_entrypoint f)), pTreeId) -- cgit From 361977d47b586dc2f8dec71f597e7f802de8dffa Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 23 Jan 2020 15:09:49 +0100 Subject: Fixing bug caused by get_predecessors returning duplicates --- backend/Duplicateaux.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 167a28eb..f86cf39b 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -46,6 +46,10 @@ let bfs code entrypoint = !bfs_list end +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 = let preds = ref (PTree.map (fun n i -> []) code) in let process_inst (node, i) = @@ -55,7 +59,10 @@ let get_predecessors_rtl code = | Icond (_,_,n1,n2) -> [n1;n2] | Ijumptable (_,ln) -> ln | Itailcall _ | Ireturn _ -> [] - in List.iter (fun s -> preds := PTree.set s (node::(get_some @@ PTree.get s !preds)) !preds) succ + 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 () + else preds := PTree.set s (node::previous_preds) !preds) succ in begin List.iter process_inst (PTree.elements code); !preds @@ -341,8 +348,6 @@ let dfs code entrypoint = in node_dfs @ (dfs_list code ln) in dfs_list code [entrypoint] -let ptree_get_some n ptree = get_some @@ PTree.get n ptree - let get_predecessors_ttl code = let preds = ref (PTree.map (fun n i -> []) code) in let process_inst (node, ti) = match ti with @@ -440,8 +445,6 @@ let rec make_identity_ptree_rec = function let make_identity_ptree code = make_identity_ptree_rec (PTree.elements code) -let optbool o = match o with Some _ -> true | None -> false - (* Change the pointers of preds nodes to point to n' instead of n *) let rec change_pointers code n n' = function | [] -> code -- cgit From 04a46f516487557df00f43453c8decbc8567c458 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 23 Jan 2020 16:30:44 +0100 Subject: Modified the hook for the oracle --- backend/Duplicate.v | 13 ++++++++----- backend/Duplicateaux.ml | 2 +- backend/Duplicateproof.v | 5 +++-- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 46f0855d..c53ff425 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -1,5 +1,6 @@ (** RTL node duplication using external oracle. Used to form superblock - structures *) + structures. Also swaps the ifso and ifnot of the Icond based on the + traces identified by the oracle *) Require Import AST RTL Maps Globalenvs. Require Import Coqlib Errors Op. @@ -7,9 +8,10 @@ Require Import Coqlib Errors Op. Local Open Scope error_monad_scope. Local Open Scope positive_scope. -(** External oracle returning the new RTL code (entry point unchanged), - along with the new entrypoint, and a mapping of new nodes to old nodes *) -Axiom duplicate_aux: function -> code * node * (PTree.t node). +(** External oracle returning the new RTL code, + along with the new entrypoint, a mapping of new nodes to old nodes, + and a list of nodes to invert the condition on *) +Axiom duplicate_aux: function -> code * node * (PTree.t node) * (list node). Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux". @@ -187,7 +189,8 @@ Definition verify_mapping dupmap (f f': function) : res unit := (** * Entry points *) Definition transf_function (f: function) : res function := - let (tcte, dupmap) := duplicate_aux f in + let (tctedupmap, invertlist) := duplicate_aux f in + let (tcte, dupmap) := tctedupmap in let (tc, te) := tcte in let f' := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in do u <- verify_mapping dupmap f f'; diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index f86cf39b..38b3ee23 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -541,4 +541,4 @@ let duplicate_aux f = let traces = select_traces (to_ttl_code code entrypoint) entrypoint in let preds = get_predecessors_rtl code in let (new_code, pTreeId) = (print_traces traces; superblockify_traces code preds traces) in - ((new_code, (fn_entrypoint f)), pTreeId) + (((new_code, (fn_entrypoint f)), pTreeId), []) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index ebb17774..67d16580 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -76,7 +76,8 @@ Theorem transf_function_preserves: transf_function f = OK f' -> fn_sig f = fn_sig f' /\ fn_params f = fn_params f' /\ fn_stacksize f = fn_stacksize f'. Proof. - intros. unfold transf_function in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. + intros. unfold transf_function in H. destruct (duplicate_aux _) as (tctemp & invl). destruct tctemp as (tcte & mp). destruct tcte as (tc & te). + monadInv H. repeat (split; try reflexivity). Qed. @@ -227,7 +228,7 @@ Theorem transf_function_correct f f': Proof. unfold transf_function. intros TRANSF. - destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). + destruct (duplicate_aux _) as (tctemp & invl). destruct tctemp as (tcte & mp). destruct tcte as (tc & te). monadInv TRANSF. unfold verify_mapping in EQ. monadInv EQ. exists mp; constructor 1; simpl; auto. -- cgit From 6bb5ae7ee76bee8b8be0c99363975bafa5753c0b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 23 Jan 2020 16:51:04 +0100 Subject: Added clause in match_inst to allow Icond reversal --- backend/Duplicateproof.v | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 67d16580..b99fadac 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -26,6 +26,9 @@ Inductive match_inst (dupmap: PTree.t node): instruction -> instruction -> Prop | match_inst_cond: forall ifso ifso' ifnot ifnot' c lr, dupmap!ifso' = (Some ifso) -> dupmap!ifnot' = (Some ifnot) -> match_inst dupmap (Icond c lr ifso ifnot) (Icond c lr ifso' ifnot') + | match_inst_revcond: forall ifso ifso' ifnot ifnot' c lr, + dupmap!ifso' = (Some ifso) -> dupmap!ifnot' = (Some ifnot) -> + match_inst dupmap (Icond c lr ifso ifnot) (Icond (negate_condition c) lr ifnot' ifso') | match_inst_jumptable: forall ln ln' r, list_forall2 (fun n n' => (dupmap!n' = (Some n))) ln ln' -> match_inst dupmap (Ijumptable r ln) (Ijumptable r ln') @@ -464,10 +467,16 @@ Proof. (* Icond *) - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. - pose symbols_preserved as SYMPRES. - eexists. split. - + eapply exec_Icond; eauto. - + econstructor; eauto. destruct b; auto. + * (* match_inst_cond *) + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Icond; eauto. + + econstructor; eauto. destruct b; auto. + * (* match_inst_revcond *) + pose symbols_preserved as SYMPRES. + eexists. split. + + eapply exec_Icond; eauto. rewrite eval_negate_condition. rewrite H0. simpl. eauto. + + econstructor; eauto. destruct b; auto. (* Ijumptable *) - eapply dupmap_correct in DUPLIC; eauto. destruct DUPLIC as (i' & H2 & H3). inv H3. -- cgit From 1acafe8f7f61a8908f47de4c98f3d873f8f9afbd Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 23 Jan 2020 17:12:27 +0100 Subject: Verificator finished for handling reversed Icond --- backend/Duplicate.v | 15 +++++++++------ backend/Duplicateproof.v | 14 +++++++++----- 2 files changed, 18 insertions(+), 11 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index c53ff425..18869f39 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -138,12 +138,15 @@ Definition verify_match_inst dupmap inst tinst := | Icond cond lr n1 n2 => match tinst with | Icond cond' lr' n1' n2' => - do u1 <- verify_is_copy dupmap n1 n1'; - do u2 <- verify_is_copy dupmap n2 n2'; - if (eq_condition cond cond') then - if (list_eq_dec Pos.eq_dec lr lr') then OK tt - else Error (msg "Different lr in Icond") - else Error (msg "Different cond in Icond") + if (list_eq_dec Pos.eq_dec lr lr') then + if (eq_condition cond cond') then + do u1 <- verify_is_copy dupmap n1 n1'; + do u2 <- verify_is_copy dupmap n2 n2'; OK tt + else if (eq_condition (negate_condition cond) cond') then + do u1 <- verify_is_copy dupmap n1 n2'; + do u2 <- verify_is_copy dupmap n2 n1'; OK tt + else Error (msg "Incompatible conditions in Icond") + else Error (msg "Different lr in Icond") | _ => Error (msg "verify_match_inst Icond") end | Ijumptable r ln => match tinst with diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index b99fadac..c285e4b3 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -177,12 +177,16 @@ Proof. destruct (builtin_res_eq_pos _ _); try discriminate. subst. constructor. assumption. (* Icond *) - - destruct i'; try (inversion H; fail). monadInv H. - destruct x. eapply verify_is_copy_correct in EQ. - destruct x0. eapply verify_is_copy_correct in EQ1. - destruct (eq_condition _ _); try discriminate. + - destruct i'; try (inversion H; fail). destruct (list_eq_dec _ _ _); try discriminate. subst. - constructor; assumption. + destruct (eq_condition _ _); try discriminate. + + monadInv H. destruct x. eapply verify_is_copy_correct in EQ. + destruct x0. eapply verify_is_copy_correct in EQ1. + constructor; assumption. + + destruct (eq_condition _ _); try discriminate. + monadInv H. destruct x. eapply verify_is_copy_correct in EQ. + destruct x0. eapply verify_is_copy_correct in EQ1. + constructor; assumption. (* Ijumptable *) - destruct i'; try (inversion H; fail). monadInv H. destruct x. eapply verify_is_copy_list_correct in EQ. -- cgit From 903ed0cfa5cb91d99ee373fc8cf408c0a80f968a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 23 Jan 2020 17:12:48 +0100 Subject: Revert "Modified the hook for the oracle" This reverts commit 04a46f516487557df00f43453c8decbc8567c458. It was actually not needed --- backend/Duplicate.v | 13 +++++-------- backend/Duplicateaux.ml | 2 +- backend/Duplicateproof.v | 5 ++--- 3 files changed, 8 insertions(+), 12 deletions(-) diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 18869f39..82c17367 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -1,6 +1,5 @@ (** RTL node duplication using external oracle. Used to form superblock - structures. Also swaps the ifso and ifnot of the Icond based on the - traces identified by the oracle *) + structures *) Require Import AST RTL Maps Globalenvs. Require Import Coqlib Errors Op. @@ -8,10 +7,9 @@ Require Import Coqlib Errors Op. Local Open Scope error_monad_scope. Local Open Scope positive_scope. -(** External oracle returning the new RTL code, - along with the new entrypoint, a mapping of new nodes to old nodes, - and a list of nodes to invert the condition on *) -Axiom duplicate_aux: function -> code * node * (PTree.t node) * (list node). +(** External oracle returning the new RTL code (entry point unchanged), + along with the new entrypoint, and a mapping of new nodes to old nodes *) +Axiom duplicate_aux: function -> code * node * (PTree.t node). Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux". @@ -192,8 +190,7 @@ Definition verify_mapping dupmap (f f': function) : res unit := (** * Entry points *) Definition transf_function (f: function) : res function := - let (tctedupmap, invertlist) := duplicate_aux f in - let (tcte, dupmap) := tctedupmap in + let (tcte, dupmap) := duplicate_aux f in let (tc, te) := tcte in let f' := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in do u <- verify_mapping dupmap f f'; diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 38b3ee23..f86cf39b 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -541,4 +541,4 @@ let duplicate_aux f = let traces = select_traces (to_ttl_code code entrypoint) entrypoint in let preds = get_predecessors_rtl code in let (new_code, pTreeId) = (print_traces traces; superblockify_traces code preds traces) in - (((new_code, (fn_entrypoint f)), pTreeId), []) + ((new_code, (fn_entrypoint f)), pTreeId) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index c285e4b3..a8e9b16b 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -79,8 +79,7 @@ Theorem transf_function_preserves: transf_function f = OK f' -> fn_sig f = fn_sig f' /\ fn_params f = fn_params f' /\ fn_stacksize f = fn_stacksize f'. Proof. - intros. unfold transf_function in H. destruct (duplicate_aux _) as (tctemp & invl). destruct tctemp as (tcte & mp). destruct tcte as (tc & te). - monadInv H. + intros. unfold transf_function in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H. repeat (split; try reflexivity). Qed. @@ -235,7 +234,7 @@ Theorem transf_function_correct f f': Proof. unfold transf_function. intros TRANSF. - destruct (duplicate_aux _) as (tctemp & invl). destruct tctemp as (tcte & mp). destruct tcte as (tc & te). + destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv TRANSF. unfold verify_mapping in EQ. monadInv EQ. exists mp; constructor 1; simpl; auto. -- cgit From d69de4bcef55cb9c35acba1cc01b0b198a15008e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 24 Jan 2020 13:32:28 +0100 Subject: Oracle inverting branches when trace does not go in fallthru --- backend/Duplicateaux.ml | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index f86cf39b..a974133e 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -534,11 +534,30 @@ let superblockify_traces code preds traces = in f new_code new_ptree traces in f code ptree traces +let rec invert_iconds_trace code = function + | [] -> code + | n::[] -> code + | n :: n' :: t -> + let code' = match ptree_get_some n code with + | Icond (c, lr, ifso, ifnot) -> + assert (n' == ifso || n' == ifnot); + if (n' == ifso) then PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso)) code + else code + | _ -> code + in invert_iconds_trace code' (n'::t) + +let rec invert_iconds code = function + | [] -> code + | t :: ts -> + let code' = invert_iconds_trace code t + in invert_iconds code' ts + (* For now, identity function *) let duplicate_aux f = let entrypoint = fn_entrypoint f in let code = fn_code f in let traces = select_traces (to_ttl_code code entrypoint) entrypoint in - let preds = get_predecessors_rtl code in - let (new_code, pTreeId) = (print_traces traces; superblockify_traces code preds traces) in + let icond_code = invert_iconds code traces in + let preds = get_predecessors_rtl icond_code in + let (new_code, pTreeId) = (print_traces traces; superblockify_traces icond_code preds traces) in ((new_code, (fn_entrypoint f)), pTreeId) -- cgit From 8aa9cb8c221ad4f2d27a7c54eca256bc70425aff Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 24 Jan 2020 13:48:45 +0100 Subject: Added debug message when inverting ifso ifnot --- backend/Duplicateaux.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index a974133e..a553a370 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -541,7 +541,9 @@ let rec invert_iconds_trace code = function let code' = match ptree_get_some n code with | Icond (c, lr, ifso, ifnot) -> assert (n' == ifso || n' == ifnot); - if (n' == ifso) then PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso)) code + if (n' == ifso) then ( + Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); + PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso)) code ) else code | _ -> code in invert_iconds_trace code' (n'::t) -- cgit From 893827f54addca2facc19a8f342b380d63114130 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 27 Jan 2020 11:43:00 +0100 Subject: Added a flag to desactivate tail duplication --- driver/Clflags.ml | 1 + driver/Compiler.v | 11 ++++++----- driver/Compopts.v | 4 ++++ driver/Driver.ml | 5 ++++- extraction/extraction.v | 2 ++ 5 files changed, 17 insertions(+), 6 deletions(-) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 9aa4a2bf..67ec9702 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -24,6 +24,7 @@ let option_fpacked_structs = ref false let option_ffpu = ref true let option_ffloatconstprop = ref 2 let option_ftailcalls = ref true +let option_fduplicate = ref true let option_fconstprop = ref true let option_fcse = ref true let option_fredundancy = ref true diff --git a/driver/Compiler.v b/driver/Compiler.v index 24964237..9f53a4fc 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -132,7 +132,7 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 2) @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 3) - @@@ time "Duplicating" Duplicate.transf_program + @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) @@ print (print_RTL 4) @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 5) @@ -250,7 +250,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog ::: mkpass Renumberproof.match_prog - ::: mkpass Duplicateproof.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_constprop Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) @@ -296,7 +296,7 @@ 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 (p9 := Renumber.transf_program p8) in *. - destruct (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; 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. @@ -320,7 +320,7 @@ Proof. 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 p10; split. apply Duplicateproof.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. 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. @@ -404,7 +404,8 @@ Ltac DestructM := eapply compose_forward_simulations. eapply Inliningproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. eapply Duplicateproof.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 compose_forward_simulations. diff --git a/driver/Compopts.v b/driver/Compopts.v index fdd2b1d6..a979c69b 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -27,6 +27,10 @@ Parameter generate_float_constants: unit -> bool. (** For value analysis. Currently always false. *) Parameter va_strict: unit -> bool. +(** Flag -fduplicate. For tail duplication optimization. Necessary to have + * bigger superblocks *) +Parameter optim_duplicate: unit -> bool. + (** Flag -ftailcalls. For tail call optimization. *) Parameter optim_tailcalls: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index 992cf8c4..5d08dc6b 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -199,6 +199,7 @@ Processing options: -fpostpass Perform postpass scheduling (only for K1 architecture) [on] -fpostpass= Perform postpass scheduling with the specified optimization [list] (=list: list scheduling, =ilp: ILP, =greedy: just packing bundles) + -fduplicate Perform tail duplication to form superblocks on predicted traces -fforward-moves Forward moves after CSE -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their @@ -260,6 +261,7 @@ let dump_mnemonics destfile = let optimization_options = [ option_ftailcalls; option_fifconversion; option_fconstprop; option_fcse; option_fpostpass; option_fredundancy; option_finline_functions_called_once; + option_fduplicate ] let set_all opts () = List.iter (fun r -> r := true) opts @@ -310,7 +312,7 @@ let cmdline_actions = [ Exact "-O0", Unit (unset_all optimization_options); Exact "-O", Unit (set_all optimization_options); - _Regexp "-O1", Self (fun _ -> set_all optimization_options (); option_fpostpass := false); + _Regexp "-O1", Self (fun _ -> set_all optimization_options (); option_fpostpass := false; option_fduplicate := false); _Regexp "-O[123]$", Unit (set_all optimization_options); Exact "-Os", Set option_Osize; Exact "-Obranchless", Set option_Obranchless; @@ -384,6 +386,7 @@ let cmdline_actions = @ f_opt "cse" option_fcse @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass + @ f_opt "duplicate" option_fduplicate @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched @ f_opt "inline" option_finline @ f_opt "inline-functions-called-once" option_finline_functions_called_once diff --git a/extraction/extraction.v b/extraction/extraction.v index 0c19ea70..c2f97778 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -105,6 +105,8 @@ Extract Constant Compopts.generate_float_constants => "fun _ -> !Clflags.option_ffloatconstprop >= 2". Extract Constant Compopts.optim_tailcalls => "fun _ -> !Clflags.option_ftailcalls". +Extract Constant Compopts.optim_duplicate => + "fun _ -> !Clflags.option_fduplicate". Extract Constant Compopts.optim_constprop => "fun _ -> !Clflags.option_fconstprop". Extract Constant Compopts.optim_CSE => -- cgit From cc61b0e400fcb7dea8e32a60995c2060e2afded6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 12:21:59 +0100 Subject: begin proving stuff --- backend/CSE2.v | 436 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 436 insertions(+) create mode 100644 backend/CSE2.v diff --git a/backend/CSE2.v b/backend/CSE2.v new file mode 100644 index 00000000..cca9fa0f --- /dev/null +++ b/backend/CSE2.v @@ -0,0 +1,436 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Require Import Globalenvs Values. + +(* Static analysis *) + +Inductive sym_val : Type := +| SMove (src : reg) +| SOp (op : operation) (args : list reg). + +Definition eq_args (x y : list reg) : { x = y } + { x <> y } := + list_eq_dec peq x y. + +Definition eq_sym_val : forall x y : sym_val, + {x = y} + { x <> y }. +Proof. + generalize eq_operation. + generalize eq_args. + generalize peq. + decide equality. +Defined. + +Module RELATION. + +Definition t := (PTree.t sym_val). +Definition eq (r1 r2 : t) := + forall x, (PTree.get x r1) = (PTree.get x r2). + +Definition top : t := PTree.empty sym_val. + +Lemma eq_refl: forall x, eq x x. +Proof. + unfold eq. + intros; reflexivity. +Qed. + +Lemma eq_sym: forall x y, eq x y -> eq y x. +Proof. + unfold eq. + intros; eauto. +Qed. + +Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. +Proof. + unfold eq. + intros; congruence. +Qed. + +Definition sym_val_beq (x y : sym_val) := + if eq_sym_val x y then true else false. + +Definition beq (r1 r2 : t) := PTree.beq sym_val_beq r1 r2. + +Lemma beq_correct: forall r1 r2, beq r1 r2 = true -> eq r1 r2. +Proof. + unfold beq, eq. intros r1 r2 EQ x. + pose proof (PTree.beq_correct sym_val_beq r1 r2) as CORRECT. + destruct CORRECT as [CORRECTF CORRECTB]. + pose proof (CORRECTF EQ x) as EQx. + clear CORRECTF CORRECTB EQ. + unfold sym_val_beq in *. + destruct (r1 ! x) as [R1x | ] in *; + destruct (r2 ! x) as [R2x | ] in *; + trivial; try contradiction. + destruct (eq_sym_val R1x R2x) in *; congruence. +Qed. + +Definition ge (r1 r2 : t) := + forall x, + match PTree.get x r1 with + | None => True + | Some v => (PTree.get x r2) = Some v + end. + +Lemma ge_refl: forall r1 r2, eq r1 r2 -> ge r1 r2. +Proof. + unfold eq, ge. + intros r1 r2 EQ x. + pose proof (EQ x) as EQx. + clear EQ. + destruct (r1 ! x). + - congruence. + - trivial. +Qed. + +Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. +Proof. + unfold ge. + intros r1 r2 r3 GE12 GE23 x. + pose proof (GE12 x) as GE12x; clear GE12. + pose proof (GE23 x) as GE23x; clear GE23. + destruct (r1 ! x); trivial. + destruct (r2 ! x); congruence. +Qed. + +Definition lub (r1 r2 : t) := + PTree.combine + (fun ov1 ov2 => + match ov1, ov2 with + | (Some v1), (Some v2) => + if eq_sym_val v1 v2 + then ov1 + else None + | None, _ + | _, None => None + end) + r1 r2. + +Lemma ge_lub_left: forall x y, ge (lub x y) x. +Proof. + unfold ge, lub. + intros r1 r2 x. + rewrite PTree.gcombine by reflexivity. + destruct (_ ! _); trivial. + destruct (_ ! _); trivial. + destruct (eq_sym_val _ _); trivial. +Qed. + +Lemma ge_lub_right: forall x y, ge (lub x y) y. +Proof. + unfold ge, lub. + intros r1 r2 x. + rewrite PTree.gcombine by reflexivity. + destruct (_ ! _); trivial. + destruct (_ ! _); trivial. + destruct (eq_sym_val _ _); trivial. + congruence. +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). + +Definition kill_sym_val (dst : reg) (sv : sym_val) := + match sv with + | SMove src => if peq dst src then true else false + | SOp op args => List.existsb (peq dst) args + end. + +Definition kill (dst : reg) (rel : RELATION.t) := + PTree.filter1 (fun x => negb (kill_sym_val dst x)) + (PTree.remove dst rel). + +Lemma args_unaffected: + forall rs : regset, + forall dst : reg, + forall v, + forall args : list reg, + existsb (fun y : reg => peq dst y) args = false -> + (rs # dst <- v ## args) = (rs ## args). +Proof. + induction args; simpl; trivial. + destruct (peq dst a) as [EQ | NEQ]; simpl. + { discriminate. + } + intro EXIST. + f_equal. + { + apply Regmap.gso. + congruence. + } + apply IHargs. + assumption. +Qed. + +Section SOUNDNESS. + Parameter F V : Type. + Parameter genv: Genv.t F V. + Parameter sp : val. + Parameter m : mem. + +Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := + match PTree.get x rel with + | None => Some (rs # x) + | Some (SMove src) => Some (rs # src) + | Some (SOp op args) => + eval_operation genv sp op (rs ## args) m + end. + +Definition sem_rel (rel : RELATION.t) (rs : regset) := + forall x : reg, (sem_reg rel x rs) = Some (rs # x). + +Lemma kill_sound : + forall rel : RELATION.t, + forall dst : reg, + forall rs, + forall v, + sem_rel rel rs -> + sem_rel (kill dst rel) (rs # dst <- v). +Proof. + unfold sem_rel, kill, sem_reg. + intros until v. + intros REL x. + rewrite PTree.gfilter1. + destruct (Pos.eq_dec dst x). + { + subst x. + rewrite PTree.grs. + rewrite Regmap.gss. + reflexivity. + } + rewrite PTree.gro by congruence. + rewrite Regmap.gso by congruence. + destruct (rel ! x) as [relx | ] eqn:RELx. + 2: reflexivity. + unfold kill_sym_val. + pose proof (REL x) as RELinstx. + rewrite RELx in RELinstx. + destruct relx eqn:SYMVAL. + { + destruct (peq dst src); simpl. + { reflexivity. } + rewrite Regmap.gso by congruence. + assumption. + } + { destruct existsb eqn:EXISTS; simpl. + { reflexivity. } + rewrite args_unaffected by exact EXISTS. + assumption. + } +Qed. + +Definition move (src dst : reg) (rel : RELATION.t) := + PTree.set dst (match PTree.get src rel with + | Some (SMove src') => SMove src' + | _ => SMove src + end) (kill dst rel). + +Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) := + match res with + | BR z => kill z rel + | BR_none => rel + | BR_splitlong hi lo => kill_builtin_res hi (kill_builtin_res lo rel) + end. + +Definition apply_instr instr x := + match instr with + | Inop _ + | Icond _ _ _ _ + | Ijumptable _ _ + | Istore _ _ _ _ _ => Some x + | Iop Omove (src :: nil) dst _ => Some (move src dst x) + | Iop _ _ dst _ + | Iload _ _ _ _ dst _ + | Icall _ _ _ dst _ => Some (kill dst x) + | 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 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). + +Definition get_r (rel : RELATION.t) (x : reg) := + match PTree.get x rel with + | None => x + | Some src => src + end. + +Definition get_rb (rb : RB.t) (x : reg) := + match rb with + | None => x + | Some rel => get_r rel x + end. + +Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg := + match fmap with + | None => x + | Some inv => get_rb (PMap.get pc inv) x + end. + +Definition subst_args fmap pc := List.map (subst_arg fmap pc). + +(* Transform *) +Definition transf_instr (fmap : option (PMap.t RB.t)) + (pc: node) (instr: instruction) := + match instr with + | Iop op args dst s => + Iop op (subst_args fmap pc args) dst s + | Iload trap chunk addr args dst s => + Iload trap chunk addr (subst_args fmap pc args) dst s + | 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. + +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 (forward_map 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. -- cgit From b54d18e2e26b3f7745870894d8087162eb33c545 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 27 Jan 2020 13:25:56 +0100 Subject: Tail duplication optimization defaulting to off --- driver/Clflags.ml | 2 +- driver/Driver.ml | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 67ec9702..088845fe 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -24,10 +24,10 @@ let option_fpacked_structs = ref false let option_ffpu = ref true let option_ffloatconstprop = ref 2 let option_ftailcalls = ref true -let option_fduplicate = ref true let option_fconstprop = ref true let option_fcse = ref true let option_fredundancy = ref true +let option_fduplicate = ref false let option_fpostpass = ref true let option_fpostpass_sched = ref "list" let option_fifconversion = ref true diff --git a/driver/Driver.ml b/driver/Driver.ml index 5d08dc6b..129248dc 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -261,7 +261,6 @@ let dump_mnemonics destfile = let optimization_options = [ option_ftailcalls; option_fifconversion; option_fconstprop; option_fcse; option_fpostpass; option_fredundancy; option_finline_functions_called_once; - option_fduplicate ] let set_all opts () = List.iter (fun r -> r := true) opts -- cgit From f5dbc0f7555b511c4200c0ce738f44800088e5d9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 15:17:03 +0100 Subject: move sound --- backend/CSE2.v | 104 ++++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 85 insertions(+), 19 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index cca9fa0f..a244d3bb 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -279,19 +279,41 @@ Proof. apply IHargs. assumption. Qed. - + +Inductive sym_cases : option sym_val -> Type := +| Move_case : forall src, (sym_cases (Some (SMove src))) +| Other_case : forall osv, (sym_cases osv). + +Definition move_cases (osv : option sym_val) : (sym_cases osv). +Proof. + destruct osv as [sv |]. + { destruct sv; try apply Move_case; apply Other_case. } + apply Other_case. +Defined. + +Definition move (src dst : reg) (rel : RELATION.t) := + PTree.set dst (match move_cases (PTree.get src rel) with + | Move_case src' => SMove src' + | Other_case _ => SMove src + end) (kill dst rel). + Section SOUNDNESS. Parameter F V : Type. Parameter genv: Genv.t F V. Parameter sp : val. Parameter m : mem. - + +Definition sem_sym_val sym rs := + match sym with + | SMove src => Some (rs # src) + | SOp op args => + eval_operation genv sp op (rs ## args) m + end. + Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := - match PTree.get x rel with + match rel ! x with | None => Some (rs # x) - | Some (SMove src) => Some (rs # src) - | Some (SOp op args) => - eval_operation genv sp op (rs ## args) m + | Some sym => sem_sym_val sym rs end. Definition sem_rel (rel : RELATION.t) (rs : regset) := @@ -305,7 +327,7 @@ Lemma kill_sound : sem_rel rel rs -> sem_rel (kill dst rel) (rs # dst <- v). Proof. - unfold sem_rel, kill, sem_reg. + unfold sem_rel, kill, sem_reg, sem_sym_val. intros until v. intros REL x. rewrite PTree.gfilter1. @@ -336,20 +358,63 @@ Proof. assumption. } Qed. - -Definition move (src dst : reg) (rel : RELATION.t) := - PTree.set dst (match PTree.get src rel with - | Some (SMove src') => SMove src' - | _ => SMove src - end) (kill dst rel). -Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) := - match res with - | BR z => kill z rel - | BR_none => rel - | BR_splitlong hi lo => kill_builtin_res hi (kill_builtin_res lo rel) - end. +Lemma write_same: + forall rs : regset, + forall src dst : reg, + (rs # dst <- (rs # src)) # src = rs # src. +Proof. + intros. + destruct (peq src dst). + { + subst dst. + apply Regmap.gss. + } + rewrite Regmap.gso by congruence. + reflexivity. +Qed. +Lemma move_sound : + forall rel : RELATION.t, + forall src dst : reg, + forall rs, + sem_rel rel rs -> + sem_rel (move src dst rel) (rs # dst <- (rs # src)). +Proof. + intros until rs. intros REL x. + pose proof (kill_sound rel dst rs (rs # src) REL x) as KILL. + pose proof (REL src) as RELsrc. + unfold move. + destruct (peq x dst). + { + subst x. + unfold sem_reg. + rewrite PTree.gss. + rewrite Regmap.gss. + unfold sem_reg in RELsrc. + destruct move_cases; simpl. + { + simpl in RELsrc. + destruct (peq dst src0). + { + subst src0. + rewrite Regmap.gss. + reflexivity. + } + rewrite Regmap.gso by congruence. + assumption. + } + rewrite write_same. + reflexivity. + } + rewrite Regmap.gso by congruence. + unfold sem_reg. + rewrite PTree.gso by congruence. + rewrite Regmap.gso in KILL by congruence. + exact KILL. +Qed. + +(* Definition apply_instr instr x := match instr with | Inop _ @@ -434,3 +499,4 @@ Definition transf_fundef (fd: fundef) : fundef := Definition transf_program (p: program) : program := transform_program transf_fundef p. +*) \ No newline at end of file -- cgit From 305b3a354a4ba61ebb80677ee73379fed4200dad Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 27 Jan 2020 16:23:13 +0100 Subject: New directive hardtest and hardcheck to run on hardware test/mppa/instr --- test/mppa/instr/Makefile | 66 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 55 insertions(+), 11 deletions(-) diff --git a/test/mppa/instr/Makefile b/test/mppa/instr/Makefile index 69446796..37f7d0ab 100644 --- a/test/mppa/instr/Makefile +++ b/test/mppa/instr/Makefile @@ -5,10 +5,11 @@ CC ?= gcc CCOMP ?= ccomp OPTIM ?= -O2 CFLAGS ?= $(OPTIM) -CCOMPFLAGS ?= $(CFLAGS) -faddx +CCOMPFLAGS ?= $(CFLAGS) SIMU ?= k1-mppa TIMEOUT ?= --signal=SIGTERM 120s DIFF ?= python2.7 floatcmp.py -reltol .00001 +HARDRUN ?= k1-jtag-runner DIR=./ SRCDIR=$(DIR) @@ -30,10 +31,11 @@ SIMUPATH=$(shell which $(SIMU)) TESTNAMES?=$(notdir $(subst .c,,$(wildcard $(DIR)/*.c))) 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))) +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))) -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))) @@ -49,12 +51,18 @@ RED=\033[0;31m YELLOW=\033[0;33m NC=\033[0m +.PHONY: +test: simutest + +.PHONY: +check: simucheck + .PHONY: -test: $(X86_GCC_OUT) $(GCC_OUT) +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.out;\ + gccout=$(OUTDIR)/$$test.gcc.simu.out;\ if grep "__K1C__" -q $$test.c; then\ printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __K1C__\`\n";\ elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ @@ -65,11 +73,39 @@ test: $(X86_GCC_OUT) $(GCC_OUT) done .PHONY: -check: $(GCC_OUT) $(CCOMP_OUT) +simucheck: $(GCC_SIMUOUT) $(CCOMP_SIMUOUT) @echo "Comparing k1 gcc output to ccomp.." @for test in $(TESTNAMES); do\ - gccout=$(OUTDIR)/$$test.gcc.out;\ - ccompout=$(OUTDIR)/$$test.ccomp.out;\ + 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 "__K1C__" -q $$test.c; then\ + printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __K1C__\`\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\ @@ -95,14 +131,22 @@ $(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) +$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) @mkdir -p $(@D) ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ -$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) +$(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) -- cgit From 576cf0553e7a54eb384e9d0b3ec7d08ff264cb1c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 27 Jan 2020 16:37:34 +0100 Subject: Hardware runs for test/mppa/interop --- test/mppa/interop/Makefile | 137 +++++++++++++++++++++++++++++++++++++-------- 1 file changed, 113 insertions(+), 24 deletions(-) diff --git a/test/mppa/interop/Makefile b/test/mppa/interop/Makefile index e615e89a..3a83d51c 100644 --- a/test/mppa/interop/Makefile +++ b/test/mppa/interop/Makefile @@ -6,6 +6,7 @@ CCOMP ?= ccomp CFLAGS ?= -O2 -Wno-varargs SIMU ?= k1-mppa TIMEOUT ?= --signal=SIGTERM 120s +HARDRUN ?= k1-jtag-runner DIR=./ SRCDIR=$(DIR) @@ -33,17 +34,23 @@ 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_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.out,$(TESTNAMES))) -GCC_REV_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.out,$(TESTNAMES))) -CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.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_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.out,$(TESTNAMES))) -VAARG_GCC_REV_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.out,$(TESTNAMES))) -VAARG_CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.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))) -OUT=$(X86_GCC_OUT) $(GCC_OUT) $(CCOMP_OUT) $(GCC_REV_OUT)\ - $(VAARG_GCC_OUT) $(VAARG_GCC_OUT) $(VAARG_CCOMP_OUT) $(VAARG_GCC_REV_OUT) BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES)))\ @@ -63,14 +70,72 @@ 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: -test: $(X86_GCC_OUT) $(GCC_OUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_OUT) +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.out;\ + gccout=$(OUTDIR)/$$test.gcc.hard.out;\ vaarg_x86out=$(OUTDIR)/$$test.x86-gcc.vaarg.out;\ - vaarg_gccout=$(OUTDIR)/$$test.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\ @@ -84,15 +149,15 @@ test: $(X86_GCC_OUT) $(GCC_OUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_OUT) done .PHONY: -check: $(GCC_OUT) $(CCOMP_OUT) $(GCC_REV_OUT) $(VAARG_GCC_OUT) $(VAARG_CCOMP_OUT) $(VAARG_GCC_REV_OUT) +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.out;\ - ccompout=$(OUTDIR)/$$test.ccomp.out;\ - gccrevout=$(OUTDIR)/$$test.gcc.rev.out;\ - vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.out;\ - vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.out;\ - vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.out;\ + 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\ @@ -144,36 +209,60 @@ $(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) +$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) @mkdir -p $(@D) ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ -$(OUTDIR)/%.gcc.rev.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH) +$(OUTDIR)/%.gcc.rev.simu.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH) @mkdir -p $(@D) ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ -$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) +$(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.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH) +$(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.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH) +$(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.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH) +$(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 ## -- cgit From 338bcf7825a889de6af322f82d4c8ae1c475dd9c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 27 Jan 2020 16:42:19 +0100 Subject: Updated scripts to run the tests on test/mppa --- test/mppa/check.sh | 6 ------ test/mppa/hardcheck.sh | 6 ++++++ test/mppa/hardtest.sh | 6 ++++++ test/mppa/simucheck.sh | 6 ++++++ test/mppa/simutest.sh | 6 ++++++ test/mppa/test.sh | 6 ------ 6 files changed, 24 insertions(+), 12 deletions(-) delete mode 100755 test/mppa/check.sh create mode 100755 test/mppa/hardcheck.sh create mode 100755 test/mppa/hardtest.sh create mode 100755 test/mppa/simucheck.sh create mode 100755 test/mppa/simutest.sh delete mode 100755 test/mppa/test.sh diff --git a/test/mppa/check.sh b/test/mppa/check.sh deleted file mode 100755 index f25c3e31..00000000 --- a/test/mppa/check.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash -# Tests the execution of the binaries produced by CompCert - -source do_test.sh - -do_test check $1 diff --git a/test/mppa/hardcheck.sh b/test/mppa/hardcheck.sh new file mode 100755 index 00000000..82b63182 --- /dev/null +++ b/test/mppa/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 diff --git a/test/mppa/hardtest.sh b/test/mppa/hardtest.sh new file mode 100755 index 00000000..09511da6 --- /dev/null +++ b/test/mppa/hardtest.sh @@ -0,0 +1,6 @@ +#!/bin/bash +# Tests the validity of the tests, in hardware + +source do_test.sh + +do_test hardtest diff --git a/test/mppa/simucheck.sh b/test/mppa/simucheck.sh new file mode 100755 index 00000000..25fb9947 --- /dev/null +++ b/test/mppa/simucheck.sh @@ -0,0 +1,6 @@ +#!/bin/bash +# Tests the execution of the binaries produced by CompCert, by simulation + +source do_test.sh + +do_test check $1 diff --git a/test/mppa/simutest.sh b/test/mppa/simutest.sh new file mode 100755 index 00000000..3b1021e6 --- /dev/null +++ b/test/mppa/simutest.sh @@ -0,0 +1,6 @@ +#!/bin/bash +# Tests the validity of the tests, in simulator + +source do_test.sh + +do_test test $1 diff --git a/test/mppa/test.sh b/test/mppa/test.sh deleted file mode 100755 index 30806a6b..00000000 --- a/test/mppa/test.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash -# Tests the validity of the tests - -source do_test.sh - -do_test test $1 -- cgit From d28f8d67bf025ff0beb478672813860793f2b2a8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 17:51:29 +0100 Subject: arg replace --- backend/CSE2.v | 88 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 87 insertions(+), 1 deletion(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index a244d3bb..61abbcdf 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -297,6 +297,14 @@ Definition move (src dst : reg) (rel : RELATION.t) := | Other_case _ => SMove src end) (kill dst rel). +Definition oper1 (op: operation) (dst : reg) (args : list reg) + (rel : RELATION.t) := + let rel' := kill dst rel in + PTree.set dst (SOp op (List.map (fun arg => + match move_cases (rel' ! arg) with + | Move_case arg' => arg' + | Other_case _ => arg + end) args)) rel'. Section SOUNDNESS. Parameter F V : Type. Parameter genv: Genv.t F V. @@ -413,7 +421,85 @@ Proof. rewrite Regmap.gso in KILL by congruence. exact KILL. Qed. - + +Lemma move_cases_neq: + forall dst rel a, + a <> dst -> + (match move_cases (kill dst rel) ! a with + | Move_case a' => a' + | Other_case _ => a + end) <> dst. +Proof. + intros until a. intro NEQ. + unfold kill. + rewrite PTree.gfilter1. + rewrite PTree.gro by congruence. + destruct (rel ! a); simpl. + 2: congruence. + destruct s. + { simpl. + destruct peq; simpl; congruence. + } + { simpl. + destruct negb; simpl; congruence. + } +Qed. + +Lemma args_replace_dst : + forall rel, + forall args : list reg, + forall dst : reg, + forall rs : regset, + forall v, + (sem_rel rel rs) -> + not (In dst args) -> + (rs # dst <- v) + ## (map + (fun arg : positive => + match move_cases (kill dst rel) ! arg with + | Move_case arg' => arg' + | Other_case _ => arg + end) args) = rs ## args. +Proof. + induction args; simpl; trivial. + intros until v. + intros REL NOT_IN. + rewrite IHargs by auto. + f_equal. + pose proof (REL a) as RELa. + rewrite Regmap.gso by (apply move_cases_neq; auto). + unfold kill. + unfold sem_reg in RELa. + rewrite PTree.gfilter1. + rewrite PTree.gro by auto. + destruct (rel ! a); simpl; trivial. + destruct s; simpl in *; destruct negb; simpl; congruence. +Qed. + +Lemma oper1_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + not (In dst args) -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (oper1 op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL NOT_IN EVAL x. + pose proof (kill_sound rel dst rs v REL x) as KILL. + unfold oper1. + destruct (peq x dst). + { + subst x. + unfold sem_reg. + rewrite PTree.gss. + rewrite Regmap.gss. + simpl. + replace ( (* Definition apply_instr instr x := match instr with -- cgit From 569a32b730608002dbb01088660ecf5bfa19dc02 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 17:55:14 +0100 Subject: oper1_sound --- backend/CSE2.v | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 61abbcdf..87460f90 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -499,7 +499,16 @@ Proof. rewrite PTree.gss. rewrite Regmap.gss. simpl. - replace ( + rewrite args_replace_dst by auto. + assumption. + } + rewrite Regmap.gso by congruence. + unfold sem_reg. + rewrite PTree.gso by congruence. + rewrite Regmap.gso in KILL by congruence. + exact KILL. +Qed. + (* Definition apply_instr instr x := match instr with -- cgit From 9ec01ece75310b28c79b57697238b57517eb4392 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 18:01:36 +0100 Subject: oper_sound --- backend/CSE2.v | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/backend/CSE2.v b/backend/CSE2.v index 87460f90..a70c3d9f 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -305,6 +305,12 @@ Definition oper1 (op: operation) (dst : reg) (args : list reg) | Move_case arg' => arg' | Other_case _ => arg end) args)) rel'. +Definition oper (op: operation) (dst : reg) (args : list reg) + (rel : RELATION.t) := + if List.in_dec peq dst args + then kill dst rel + else oper1 op dst args rel. + Section SOUNDNESS. Parameter F V : Type. Parameter genv: Genv.t F V. @@ -509,6 +515,27 @@ Proof. exact KILL. Qed. +Lemma oper_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (oper op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL EVAL. + unfold oper. + destruct in_dec. + { + apply kill_sound; auto. + } + apply oper1_sound; auto. +Qed. + (* Definition apply_instr instr x := match instr with -- cgit From fe7d4a81d4999c71f856372716a4a198c46ded8e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 18:14:47 +0100 Subject: gen_oper_sound --- backend/CSE2.v | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index a70c3d9f..1278d729 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -305,12 +305,20 @@ Definition oper1 (op: operation) (dst : reg) (args : list reg) | Move_case arg' => arg' | Other_case _ => arg end) args)) rel'. + Definition oper (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := if List.in_dec peq dst args then kill dst rel else oper1 op dst args rel. +Definition gen_oper (op: operation) (dst : reg) (args : list reg) + (rel : RELATION.t) := + match op, args with + | Omove, src::nil => move src dst rel + | _, _ => oper op dst args rel + end. + Section SOUNDNESS. Parameter F V : Type. Parameter genv: Genv.t F V. @@ -536,7 +544,35 @@ Proof. apply oper1_sound; auto. Qed. -(* + +Lemma gen_oper_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (gen_oper op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL EVAL. + unfold gen_oper. + destruct op. + { destruct args as [ | h0 t0]. + apply oper_sound; auto. + destruct t0. + { + simpl in *. + replace v with (rs # h0) by congruence. + apply move_sound; auto. + } + apply oper_sound; auto. + } + all: apply oper_sound; auto. +Qed. + (* Definition apply_instr instr x := match instr with | Inop _ -- cgit From e4e8c2d83a03090761c23752831499c0547fa037 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 18:23:13 +0100 Subject: renamed kill_reg into kill_mem --- backend/CSE2.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 1278d729..53fc92bf 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -254,7 +254,7 @@ Definition kill_sym_val (dst : reg) (sv : sym_val) := | SOp op args => List.existsb (peq dst) args end. -Definition kill (dst : reg) (rel : RELATION.t) := +Definition kill_reg (dst : reg) (rel : RELATION.t) := PTree.filter1 (fun x => negb (kill_sym_val dst x)) (PTree.remove dst rel). @@ -295,11 +295,11 @@ Definition move (src dst : reg) (rel : RELATION.t) := PTree.set dst (match move_cases (PTree.get src rel) with | Move_case src' => SMove src' | Other_case _ => SMove src - end) (kill dst rel). + end) (kill_reg dst rel). Definition oper1 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := - let rel' := kill dst rel in + let rel' := kill_reg dst rel in PTree.set dst (SOp op (List.map (fun arg => match move_cases (rel' ! arg) with | Move_case arg' => arg' @@ -309,7 +309,7 @@ Definition oper1 (op: operation) (dst : reg) (args : list reg) Definition oper (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := if List.in_dec peq dst args - then kill dst rel + then kill_reg dst rel else oper1 op dst args rel. Definition gen_oper (op: operation) (dst : reg) (args : list reg) @@ -347,9 +347,9 @@ Lemma kill_sound : forall rs, forall v, sem_rel rel rs -> - sem_rel (kill dst rel) (rs # dst <- v). + sem_rel (kill_reg dst rel) (rs # dst <- v). Proof. - unfold sem_rel, kill, sem_reg, sem_sym_val. + unfold sem_rel, kill_reg, sem_reg, sem_sym_val. intros until v. intros REL x. rewrite PTree.gfilter1. @@ -439,13 +439,13 @@ Qed. Lemma move_cases_neq: forall dst rel a, a <> dst -> - (match move_cases (kill dst rel) ! a with + (match move_cases (kill_reg dst rel) ! a with | Move_case a' => a' | Other_case _ => a end) <> dst. Proof. intros until a. intro NEQ. - unfold kill. + unfold kill_reg. rewrite PTree.gfilter1. rewrite PTree.gro by congruence. destruct (rel ! a); simpl. @@ -470,7 +470,7 @@ Lemma args_replace_dst : (rs # dst <- v) ## (map (fun arg : positive => - match move_cases (kill dst rel) ! arg with + match move_cases (kill_reg dst rel) ! arg with | Move_case arg' => arg' | Other_case _ => arg end) args) = rs ## args. @@ -482,7 +482,7 @@ Proof. f_equal. pose proof (REL a) as RELa. rewrite Regmap.gso by (apply move_cases_neq; auto). - unfold kill. + unfold kill_reg. unfold sem_reg in RELa. rewrite PTree.gfilter1. rewrite PTree.gro by auto. @@ -582,7 +582,7 @@ Definition apply_instr instr x := | Iop Omove (src :: nil) dst _ => Some (move src dst x) | Iop _ _ dst _ | Iload _ _ _ _ dst _ - | Icall _ _ _ dst _ => Some (kill dst x) + | Icall _ _ _ dst _ => Some (kill_reg dst x) | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) | Itailcall _ _ _ | Ireturn _ => RB.bot end. -- cgit From 3c5122f71e1b3c2348b653b03bc7bcd6cc75ecbf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 19:27:59 +0100 Subject: kill_mem_sound --- backend/CSE2.v | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 59 insertions(+), 8 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 53fc92bf..b26d6820 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -258,6 +258,15 @@ Definition kill_reg (dst : reg) (rel : RELATION.t) := PTree.filter1 (fun x => negb (kill_sym_val dst x)) (PTree.remove dst rel). +Definition kill_sym_val_mem (sv: sym_val) := + match sv with + | SMove _ => false + | SOp op _ => op_depends_on_memory op + end. + +Definition kill_mem (rel : RELATION.t) := + PTree.filter1 (fun x => negb (kill_sym_val_mem x)) rel. + Lemma args_unaffected: forall rs : regset, forall dst : reg, @@ -320,10 +329,12 @@ Definition gen_oper (op: operation) (dst : reg) (args : list reg) end. Section SOUNDNESS. - Parameter F V : Type. - Parameter genv: Genv.t F V. - Parameter sp : val. - Parameter m : mem. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Section SAME_MEMORY. + Variable m : mem. Definition sem_sym_val sym rs := match sym with @@ -341,7 +352,7 @@ Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := Definition sem_rel (rel : RELATION.t) (rs : regset) := forall x : reg, (sem_reg rel x rs) = Some (rs # x). -Lemma kill_sound : +Lemma kill_reg_sound : forall rel : RELATION.t, forall dst : reg, forall rs, @@ -404,7 +415,7 @@ Lemma move_sound : sem_rel (move src dst rel) (rs # dst <- (rs # src)). Proof. intros until rs. intros REL x. - pose proof (kill_sound rel dst rs (rs # src) REL x) as KILL. + pose proof (kill_reg_sound rel dst rs (rs # src) REL x) as KILL. pose proof (REL src) as RELsrc. unfold move. destruct (peq x dst). @@ -504,7 +515,7 @@ Lemma oper1_sound : Proof. intros until v. intros REL NOT_IN EVAL x. - pose proof (kill_sound rel dst rs v REL x) as KILL. + pose proof (kill_reg_sound rel dst rs v REL x) as KILL. unfold oper1. destruct (peq x dst). { @@ -539,7 +550,7 @@ Proof. unfold oper. destruct in_dec. { - apply kill_sound; auto. + apply kill_reg_sound; auto. } apply oper1_sound; auto. Qed. @@ -572,6 +583,46 @@ Proof. } all: apply oper_sound; auto. Qed. + +End SAME_MEMORY. + +Lemma kill_mem_sound : + forall m m' : mem, + forall rel : RELATION.t, + forall rs, + sem_rel m rel rs -> sem_rel m' (kill_mem rel) rs. +Proof. + unfold sem_rel, sem_reg. + intros until rs. + intros SEM x. + pose proof (SEM x) as SEMx. + unfold kill_mem. + rewrite PTree.gfilter1. + unfold kill_sym_val_mem. + destruct (rel ! x) as [ sv | ]. + 2: reflexivity. + destruct sv; simpl in *; trivial. + { + destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial. + rewrite <- SEMx. + apply op_depends_on_memory_correct; auto. + } +Qed. + +End SOUNDNESS. + +Lemma gen_oper_sound : + forall m m' : mem, + forall sp, + forall rel : RELATION.t, + sem_rel rel rs -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (gen_oper op dst args rel) (rs # dst <- v). + + +Lemma kill_mem_sound: + forall m' : mem, + (* Definition apply_instr instr x := match instr with -- cgit From c6755b93351943a86f36904c158a81f6f433862d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 19:34:06 +0100 Subject: static analysis done --- backend/CSE2.v | 27 +++++++-------------------- 1 file changed, 7 insertions(+), 20 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index b26d6820..60f2f8a1 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -610,30 +610,16 @@ Proof. Qed. End SOUNDNESS. - -Lemma gen_oper_sound : - forall m m' : mem, - forall sp, - forall rel : RELATION.t, - sem_rel rel rs -> - eval_operation genv sp op (rs ## args) m = Some v -> - sem_rel (gen_oper op dst args rel) (rs # dst <- v). - - -Lemma kill_mem_sound: - forall m' : mem, - (* -Definition apply_instr instr x := +Definition apply_instr instr (rel : RELATION.t) : RB.t := match instr with | Inop _ | Icond _ _ _ _ - | Ijumptable _ _ - | Istore _ _ _ _ _ => Some x - | Iop Omove (src :: nil) dst _ => Some (move src dst x) - | Iop _ _ dst _ - | Iload _ _ _ _ dst _ - | Icall _ _ _ dst _ => Some (kill_reg dst x) + | Ijumptable _ _ => Some rel + | Istore _ _ _ _ _ => Some (kill_mem rel) + | Iop op args dst _ => Some (gen_oper op dst args rel) + | Iload _ _ _ dst _ + | Icall _ _ _ dst _ => Some (kill_reg dst rel) | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) | Itailcall _ _ _ | Ireturn _ => RB.bot end. @@ -652,6 +638,7 @@ 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). +(* Definition get_r (rel : RELATION.t) (x : reg) := match PTree.get x rel with | None => x -- cgit From bec3d3e29881590541130ef3f1116bd41df71a25 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 20:21:17 +0100 Subject: simpler definitions --- backend/CSE2.v | 65 ++++++++++++++++++++++------------------------------------ 1 file changed, 24 insertions(+), 41 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 60f2f8a1..36558033 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -289,31 +289,19 @@ Proof. assumption. Qed. -Inductive sym_cases : option sym_val -> Type := -| Move_case : forall src, (sym_cases (Some (SMove src))) -| Other_case : forall osv, (sym_cases osv). - -Definition move_cases (osv : option sym_val) : (sym_cases osv). -Proof. - destruct osv as [sv |]. - { destruct sv; try apply Move_case; apply Other_case. } - apply Other_case. -Defined. +Definition forward_move (rel : RELATION.t) (x : reg) : reg := + match rel ! x with + | Some (SMove org) => org + | _ => x + end. Definition move (src dst : reg) (rel : RELATION.t) := - PTree.set dst (match move_cases (PTree.get src rel) with - | Move_case src' => SMove src' - | Other_case _ => SMove src - end) (kill_reg dst rel). + PTree.set dst (SMove (forward_move rel src)) (kill_reg dst rel). Definition oper1 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := let rel' := kill_reg dst rel in - PTree.set dst (SOp op (List.map (fun arg => - match move_cases (rel' ! arg) with - | Move_case arg' => arg' - | Other_case _ => arg - end) args)) rel'. + PTree.set dst (SOp op (List.map (forward_move rel') args)) rel'. Definition oper (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := @@ -425,9 +413,11 @@ Proof. rewrite PTree.gss. rewrite Regmap.gss. unfold sem_reg in RELsrc. - destruct move_cases; simpl. + simpl. + unfold forward_move. + destruct (rel ! src) as [ sv |]; simpl. + destruct sv; simpl in *. { - simpl in RELsrc. destruct (peq dst src0). { subst src0. @@ -437,8 +427,7 @@ Proof. rewrite Regmap.gso by congruence. assumption. } - rewrite write_same. - reflexivity. + all: f_equal; apply write_same. } rewrite Regmap.gso by congruence. unfold sem_reg. @@ -450,24 +439,21 @@ Qed. Lemma move_cases_neq: forall dst rel a, a <> dst -> - (match move_cases (kill_reg dst rel) ! a with - | Move_case a' => a' - | Other_case _ => a - end) <> dst. + (forward_move (kill_reg dst rel) a) <> dst. Proof. intros until a. intro NEQ. - unfold kill_reg. + unfold kill_reg, forward_move. rewrite PTree.gfilter1. rewrite PTree.gro by congruence. destruct (rel ! a); simpl. 2: congruence. destruct s. - { simpl. + { + unfold kill_sym_val. destruct peq; simpl; congruence. } - { simpl. + all: simpl; destruct negb; simpl; congruence. - } Qed. Lemma args_replace_dst : @@ -480,13 +466,10 @@ Lemma args_replace_dst : not (In dst args) -> (rs # dst <- v) ## (map - (fun arg : positive => - match move_cases (kill_reg dst rel) ! arg with - | Move_case arg' => arg' - | Other_case _ => arg - end) args) = rs ## args. + (forward_move (kill_reg dst rel)) args) = rs ## args. Proof. - induction args; simpl; trivial. + induction args; simpl. + 1: reflexivity. intros until v. intros REL NOT_IN. rewrite IHargs by auto. @@ -495,6 +478,7 @@ Proof. rewrite Regmap.gso by (apply move_cases_neq; auto). unfold kill_reg. unfold sem_reg in RELa. + unfold forward_move. rewrite PTree.gfilter1. rewrite PTree.gro by auto. destruct (rel ! a); simpl; trivial. @@ -555,7 +539,6 @@ Proof. apply oper1_sound; auto. Qed. - Lemma gen_oper_sound : forall rel : RELATION.t, forall op : operation, @@ -640,9 +623,9 @@ Definition forward_map (f : RTL.function) := DS.fixpoint (* Definition get_r (rel : RELATION.t) (x : reg) := - match PTree.get x rel with - | None => x - | Some src => src + match move_cases (PTree.get x rel) with + | Move_case x' => x' + | Other_case _ => x end. Definition get_rb (rb : RB.t) (x : reg) := -- cgit From 7dd2fce8926e3d9fa30ad2619dd38c5e2d535a5e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 20:27:20 +0100 Subject: goes to the end but does not find available ops --- backend/CSE2.v | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 36558033..d5412d73 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -621,23 +621,16 @@ 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). -(* -Definition get_r (rel : RELATION.t) (x : reg) := - match move_cases (PTree.get x rel) with - | Move_case x' => x' - | Other_case _ => x - end. - -Definition get_rb (rb : RB.t) (x : reg) := +Definition forward_move_b (rb : RB.t) (x : reg) := match rb with | None => x - | Some rel => get_r rel x + | Some rel => forward_move rel x end. Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg := match fmap with | None => x - | Some inv => get_rb (PMap.get pc inv) x + | Some inv => forward_move_b (PMap.get pc inv) x end. Definition subst_args fmap pc := List.map (subst_arg fmap pc). @@ -648,8 +641,8 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) match instr with | Iop op args dst s => Iop op (subst_args fmap pc args) dst s - | Iload trap chunk addr args dst s => - Iload trap chunk addr (subst_args fmap pc args) dst s + | Iload chunk addr args dst s => + Iload chunk addr (subst_args fmap pc args) dst s | Istore chunk addr args src s => Istore chunk addr (subst_args fmap pc args) src s | Icall sig ros args dst s => @@ -678,4 +671,3 @@ Definition transf_fundef (fd: fundef) : fundef := Definition transf_program (p: program) : program := transform_program transf_fundef p. -*) \ No newline at end of file -- cgit From d6f23a4835a644a4f554fcf75485d5da786b7758 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 22:10:11 +0100 Subject: find_op_sound --- backend/CSE2.v | 111 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 110 insertions(+), 1 deletion(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index d5412d73..a042b0a9 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -567,6 +567,115 @@ Proof. all: apply oper_sound; auto. Qed. + +Definition find_op_fold op args (already : option reg) x sv := + match already with + | Some found => already + | None => + match sv with + | (SOp op' args') => + if (eq_operation op op') && (eq_args args args') + then Some x + else None + | _ => None + end + end. + +Definition find_op (rel : RELATION.t) (op : operation) (args : list reg) := + PTree.fold (find_op_fold op args) rel None. + +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 + 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. + +Lemma find_op_sound : + forall rel : RELATION.t, + forall op : operation, + forall src dst : reg, + forall args: list reg, + forall rs : regset, + sem_rel rel rs -> + find_op rel op args = Some src -> + (eval_operation genv sp op (rs ## args) m) = Some (rs # src). +Proof. + intros until rs. + unfold find_op. + rewrite PTree.fold_spec. + intro REL. + assert ( + forall start, + match start with + | None => True + | Some src => eval_operation genv sp op rs ## args m = Some rs # src + end -> fold_left + (fun (a : option reg) (p : positive * sym_val) => + find_op_fold op args a (fst p) (snd p)) (PTree.elements rel) start = + Some src -> + eval_operation genv sp op rs ## args m = Some rs # src) as REC. + { + unfold sem_rel, sem_reg in REL. + generalize (PTree.elements_complete rel). + generalize (PTree.elements rel). + induction l; simpl. + { + intros. + subst start. + assumption. + } + destruct a as [r sv]; simpl. + intros COMPLETE start GEN. + apply IHl. + { + intros. + apply COMPLETE. + right. + assumption. + } + unfold find_op_fold. + destruct start. + assumption. + destruct sv. + { trivial. } + destruct eq_operation; trivial. + subst op0. + destruct eq_args; trivial. + subst args0. + simpl. + assert ((rel ! r) = Some (SOp op args)) as RELatr. + { + apply COMPLETE. + left. + reflexivity. + } + pose proof (REL r) as RELr. + rewrite RELatr in RELr. + simpl in RELr. + assumption. + } + apply REC; auto. +Qed. + End SAME_MEMORY. Lemma kill_mem_sound : @@ -634,7 +743,7 @@ Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg : end. Definition subst_args fmap pc := List.map (subst_arg fmap pc). - + (* Transform *) Definition transf_instr (fmap : option (PMap.t RB.t)) (pc: node) (instr: instruction) := -- cgit From 441524f4b63d8e9fa7161d640fb7be00a7235f3a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 22:18:08 +0100 Subject: use in transformation --- backend/CSE2.v | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index a042b0a9..79c52973 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -709,7 +709,7 @@ Definition apply_instr instr (rel : RELATION.t) : RB.t := | Icond _ _ _ _ | Ijumptable _ _ => Some rel | Istore _ _ _ _ _ => Some (kill_mem rel) - | Iop op args dst _ => Some (gen_oper op dst args rel) + | Iop op args dst _ => Some (gen_oper op dst args rel) | Iload _ _ _ dst _ | Icall _ _ _ dst _ => Some (kill_reg dst rel) | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) @@ -743,13 +743,31 @@ Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg : end. Definition subst_args fmap pc := List.map (subst_arg fmap pc). - + +Definition gen_move src dst s := + if peq src dst + then Inop s + else Iop Omove (src::nil) dst s. + (* Transform *) +Definition find_op_in_fmap fmap pc op args := + match fmap with + | None => None + | Some map => + match PMap.get pc map with + | Some rel => find_op rel op args + | None => None + end + end. + Definition transf_instr (fmap : option (PMap.t RB.t)) (pc: node) (instr: instruction) := match instr with | Iop op args dst s => - Iop op (subst_args fmap pc args) dst s + match find_op_in_fmap fmap pc op args with + | None => Iop op (subst_args fmap pc args) dst s + | Some src => gen_move src dst s + end | Iload chunk addr args dst s => Iload chunk addr (subst_args fmap pc args) dst s | Istore chunk addr args src s => -- cgit From 528935a59259b006ed56c83457b3a018494fc9ec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 27 Jan 2020 22:36:33 +0100 Subject: progress --- backend/CSE2.v | 467 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 467 insertions(+) diff --git a/backend/CSE2.v b/backend/CSE2.v index 79c52973..011806cc 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -3,6 +3,8 @@ 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. (* Static analysis *) @@ -798,3 +800,468 @@ Definition transf_fundef (fd: fundef) : fundef := 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. + +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; 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. + +Lemma transf_function_at: + forall (f : function) (pc : node) (i : instruction), + (fn_code f)!pc = Some i -> + (fn_code (transf_function f))!pc = + Some(transf_instr (forward_map f) pc i). +Proof. + intros until i. intro CODE. + unfold transf_function; simpl. + rewrite PTree.gmap. + unfold option_map. + rewrite CODE. + reflexivity. +Qed. + +Definition sem_rel_b (relb : RB.t) sp m (rs : regset) := + match relb with + | Some rel => sem_rel fundef unit ge sp m rel rs + | None => True + end. + +Definition fmap_sem (fmap : option (PMap.t RB.t)) + sp m (pc : node) (rs : regset) := + match fmap with + | None => True + | Some map => sem_rel_b (PMap.get pc map) sp m rs + end. + +(* +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. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. +- (* op *) + econstructor; split. + eapply exec_Iop with (v := v); eauto. + rewrite <- H0. + rewrite subst_args_ok by assumption. + apply eval_operation_preserved. exact symbols_preserved. + constructor; auto. + + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. + { + eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. + 2: apply apply_instr'_bot. + simpl. tauto. + } + unfold apply_instr' in GE. + rewrite MPC in GE. + rewrite H in GE. + + destruct (op_cases op args res pc' mpc) as [[src [OP [ARGS MOVE]]] | KILL]. + { + subst op. + subst args. + rewrite MOVE in GE. + simpl in H0. + simpl in GE. + apply get_rb_sem_ge with (rb2 := Some (move src res mpc)). + assumption. + replace v with (rs # src) by congruence. + apply move_ok. + assumption. + } + rewrite KILL in GE. + apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + assumption. + apply kill_ok. + assumption. + +(* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. + +- (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. + +- (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. + +- (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. + +(* call *) +- econstructor; split. + eapply exec_Icall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + rewrite subst_args_ok by assumption. + constructor. constructor; auto. constructor. + + { + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + { + replace (Some (kill res 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_weaken. + assumption. + } + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. + { + eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. + 2: apply apply_instr'_bot. + simpl. tauto. + } + unfold apply_instr' in GE. + unfold fmap_sem in *. + destruct (map # pc) as [mpc |] in *; try contradiction. + rewrite H in GE. + simpl in GE. + unfold is_killed_in_fmap, is_killed_in_map. + unfold RB.ge in GE. + destruct (map # pc') as [mpc'|] eqn:MPC' in *; trivial. + eauto. + +(* tailcall *) +- econstructor; split. + eapply exec_Itailcall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + rewrite subst_args_ok by assumption. + 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. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + + apply get_rb_sem_ge with (rb2 := Some RELATION.top). + { + replace (Some RELATION.top) 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply top_ok. + +(* cond *) +- econstructor; split. + eapply exec_Icond; eauto. + rewrite subst_args_ok; eassumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. + destruct b; tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. + +(* jumptbl *) +- econstructor; split. + eapply exec_Ijumptable; eauto. + rewrite subst_arg_ok; eassumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. + apply list_nth_z_in with (n := Int.unsigned n). + assumption. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. + +(* return *) +- destruct or as [arg | ]. + { + econstructor; split. + eapply exec_Ireturn; eauto. + unfold regmap_optget. + rewrite subst_arg_ok by eassumption. + constructor; auto. + } + econstructor; split. + eapply exec_Ireturn; eauto. + constructor; auto. + + +(* internal function *) +- simpl. econstructor; split. + eapply exec_function_internal; eauto. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := Some RELATION.top). + { + eapply DS.fixpoint_entry with (code := fn_code f) (successors := successors_instr); try eassumption. + } + apply top_ok. + +(* 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. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + unfold is_killed_in_fmap in H8. + unfold is_killed_in_map in H8. + destruct (map # pc) as [mpc |] in *; try contradiction. + destruct H8 as [rel' RGE]. + eapply get_rb_killed; eauto. +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. +*) \ No newline at end of file -- cgit From 93b1e0034733dcc19dc42c04725439e8bdf3d10d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 06:53:30 +0100 Subject: CSE2 split in two files --- Makefile | 1 + backend/CSE2.v | 829 +-------------------------------------------------- backend/CSE2proof.v | 835 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 838 insertions(+), 827 deletions(-) create mode 100644 backend/CSE2proof.v diff --git a/Makefile b/Makefile index 80eca80d..b8bde940 100644 --- a/Makefile +++ b/Makefile @@ -83,6 +83,7 @@ BACKEND=\ ValueDomain.v ValueAOp.v ValueAnalysis.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ + CSE2.v CSE2proof.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/CSE2.v b/backend/CSE2.v index 011806cc..0bd5bf81 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -2,10 +2,6 @@ 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. - (* Static analysis *) Inductive sym_val : Type := @@ -269,27 +265,6 @@ Definition kill_sym_val_mem (sv: sym_val) := Definition kill_mem (rel : RELATION.t) := PTree.filter1 (fun x => negb (kill_sym_val_mem x)) rel. -Lemma args_unaffected: - forall rs : regset, - forall dst : reg, - forall v, - forall args : list reg, - existsb (fun y : reg => peq dst y) args = false -> - (rs # dst <- v ## args) = (rs ## args). -Proof. - induction args; simpl; trivial. - destruct (peq dst a) as [EQ | NEQ]; simpl. - { discriminate. - } - intro EXIST. - f_equal. - { - apply Regmap.gso. - congruence. - } - apply IHargs. - assumption. -Qed. Definition forward_move (rel : RELATION.t) (x : reg) : reg := match rel ! x with @@ -318,258 +293,6 @@ Definition gen_oper (op: operation) (dst : reg) (args : list reg) | _, _ => oper op dst args rel end. -Section SOUNDNESS. - Variable F V : Type. - Variable genv: Genv.t F V. - Variable sp : val. - -Section SAME_MEMORY. - Variable m : mem. - -Definition sem_sym_val sym rs := - match sym with - | SMove src => Some (rs # src) - | SOp op args => - eval_operation genv sp op (rs ## args) m - end. - -Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := - match rel ! x with - | None => Some (rs # x) - | Some sym => sem_sym_val sym rs - end. - -Definition sem_rel (rel : RELATION.t) (rs : regset) := - forall x : reg, (sem_reg rel x rs) = Some (rs # x). - -Lemma kill_reg_sound : - forall rel : RELATION.t, - forall dst : reg, - forall rs, - forall v, - sem_rel rel rs -> - sem_rel (kill_reg dst rel) (rs # dst <- v). -Proof. - unfold sem_rel, kill_reg, sem_reg, sem_sym_val. - intros until v. - intros REL x. - rewrite PTree.gfilter1. - destruct (Pos.eq_dec dst x). - { - subst x. - rewrite PTree.grs. - rewrite Regmap.gss. - reflexivity. - } - rewrite PTree.gro by congruence. - rewrite Regmap.gso by congruence. - destruct (rel ! x) as [relx | ] eqn:RELx. - 2: reflexivity. - unfold kill_sym_val. - pose proof (REL x) as RELinstx. - rewrite RELx in RELinstx. - destruct relx eqn:SYMVAL. - { - destruct (peq dst src); simpl. - { reflexivity. } - rewrite Regmap.gso by congruence. - assumption. - } - { destruct existsb eqn:EXISTS; simpl. - { reflexivity. } - rewrite args_unaffected by exact EXISTS. - assumption. - } -Qed. - -Lemma write_same: - forall rs : regset, - forall src dst : reg, - (rs # dst <- (rs # src)) # src = rs # src. -Proof. - intros. - destruct (peq src dst). - { - subst dst. - apply Regmap.gss. - } - rewrite Regmap.gso by congruence. - reflexivity. -Qed. - -Lemma move_sound : - forall rel : RELATION.t, - forall src dst : reg, - forall rs, - sem_rel rel rs -> - sem_rel (move src dst rel) (rs # dst <- (rs # src)). -Proof. - intros until rs. intros REL x. - pose proof (kill_reg_sound rel dst rs (rs # src) REL x) as KILL. - pose proof (REL src) as RELsrc. - unfold move. - destruct (peq x dst). - { - subst x. - unfold sem_reg. - rewrite PTree.gss. - rewrite Regmap.gss. - unfold sem_reg in RELsrc. - simpl. - unfold forward_move. - destruct (rel ! src) as [ sv |]; simpl. - destruct sv; simpl in *. - { - destruct (peq dst src0). - { - subst src0. - rewrite Regmap.gss. - reflexivity. - } - rewrite Regmap.gso by congruence. - assumption. - } - all: f_equal; apply write_same. - } - rewrite Regmap.gso by congruence. - unfold sem_reg. - rewrite PTree.gso by congruence. - rewrite Regmap.gso in KILL by congruence. - exact KILL. -Qed. - -Lemma move_cases_neq: - forall dst rel a, - a <> dst -> - (forward_move (kill_reg dst rel) a) <> dst. -Proof. - intros until a. intro NEQ. - unfold kill_reg, forward_move. - rewrite PTree.gfilter1. - rewrite PTree.gro by congruence. - destruct (rel ! a); simpl. - 2: congruence. - destruct s. - { - unfold kill_sym_val. - destruct peq; simpl; congruence. - } - all: simpl; - destruct negb; simpl; congruence. -Qed. - -Lemma args_replace_dst : - forall rel, - forall args : list reg, - forall dst : reg, - forall rs : regset, - forall v, - (sem_rel rel rs) -> - not (In dst args) -> - (rs # dst <- v) - ## (map - (forward_move (kill_reg dst rel)) args) = rs ## args. -Proof. - induction args; simpl. - 1: reflexivity. - intros until v. - intros REL NOT_IN. - rewrite IHargs by auto. - f_equal. - pose proof (REL a) as RELa. - rewrite Regmap.gso by (apply move_cases_neq; auto). - unfold kill_reg. - unfold sem_reg in RELa. - unfold forward_move. - rewrite PTree.gfilter1. - rewrite PTree.gro by auto. - destruct (rel ! a); simpl; trivial. - destruct s; simpl in *; destruct negb; simpl; congruence. -Qed. - -Lemma oper1_sound : - forall rel : RELATION.t, - forall op : operation, - forall dst : reg, - forall args: list reg, - forall rs : regset, - forall v, - sem_rel rel rs -> - not (In dst args) -> - eval_operation genv sp op (rs ## args) m = Some v -> - sem_rel (oper1 op dst args rel) (rs # dst <- v). -Proof. - intros until v. - intros REL NOT_IN EVAL x. - pose proof (kill_reg_sound rel dst rs v REL x) as KILL. - unfold oper1. - destruct (peq x dst). - { - subst x. - unfold sem_reg. - rewrite PTree.gss. - rewrite Regmap.gss. - simpl. - rewrite args_replace_dst by auto. - assumption. - } - rewrite Regmap.gso by congruence. - unfold sem_reg. - rewrite PTree.gso by congruence. - rewrite Regmap.gso in KILL by congruence. - exact KILL. -Qed. - -Lemma oper_sound : - forall rel : RELATION.t, - forall op : operation, - forall dst : reg, - forall args: list reg, - forall rs : regset, - forall v, - sem_rel rel rs -> - eval_operation genv sp op (rs ## args) m = Some v -> - sem_rel (oper op dst args rel) (rs # dst <- v). -Proof. - intros until v. - intros REL EVAL. - unfold oper. - destruct in_dec. - { - apply kill_reg_sound; auto. - } - apply oper1_sound; auto. -Qed. - -Lemma gen_oper_sound : - forall rel : RELATION.t, - forall op : operation, - forall dst : reg, - forall args: list reg, - forall rs : regset, - forall v, - sem_rel rel rs -> - eval_operation genv sp op (rs ## args) m = Some v -> - sem_rel (gen_oper op dst args rel) (rs # dst <- v). -Proof. - intros until v. - intros REL EVAL. - unfold gen_oper. - destruct op. - { destruct args as [ | h0 t0]. - apply oper_sound; auto. - destruct t0. - { - simpl in *. - replace v with (rs # h0) by congruence. - apply move_sound; auto. - } - apply oper_sound; auto. - } - all: apply oper_sound; auto. -Qed. - - Definition find_op_fold op args (already : option reg) x sv := match already with | Some found => already @@ -586,6 +309,7 @@ Definition find_op_fold op args (already : option reg) x sv := Definition find_op (rel : RELATION.t) (op : operation) (args : list reg) := PTree.fold (find_op_fold op args) rel None. +(* NO LONGER NEEDED Fixpoint list_represents { X : Type } (l : list (positive*X)) (tr : PTree.t X) : Prop := match l with | nil => True @@ -610,100 +334,7 @@ Proof. } apply IHl; auto. Qed. - -Lemma find_op_sound : - forall rel : RELATION.t, - forall op : operation, - forall src dst : reg, - forall args: list reg, - forall rs : regset, - sem_rel rel rs -> - find_op rel op args = Some src -> - (eval_operation genv sp op (rs ## args) m) = Some (rs # src). -Proof. - intros until rs. - unfold find_op. - rewrite PTree.fold_spec. - intro REL. - assert ( - forall start, - match start with - | None => True - | Some src => eval_operation genv sp op rs ## args m = Some rs # src - end -> fold_left - (fun (a : option reg) (p : positive * sym_val) => - find_op_fold op args a (fst p) (snd p)) (PTree.elements rel) start = - Some src -> - eval_operation genv sp op rs ## args m = Some rs # src) as REC. - { - unfold sem_rel, sem_reg in REL. - generalize (PTree.elements_complete rel). - generalize (PTree.elements rel). - induction l; simpl. - { - intros. - subst start. - assumption. - } - destruct a as [r sv]; simpl. - intros COMPLETE start GEN. - apply IHl. - { - intros. - apply COMPLETE. - right. - assumption. - } - unfold find_op_fold. - destruct start. - assumption. - destruct sv. - { trivial. } - destruct eq_operation; trivial. - subst op0. - destruct eq_args; trivial. - subst args0. - simpl. - assert ((rel ! r) = Some (SOp op args)) as RELatr. - { - apply COMPLETE. - left. - reflexivity. - } - pose proof (REL r) as RELr. - rewrite RELatr in RELr. - simpl in RELr. - assumption. - } - apply REC; auto. -Qed. - -End SAME_MEMORY. - -Lemma kill_mem_sound : - forall m m' : mem, - forall rel : RELATION.t, - forall rs, - sem_rel m rel rs -> sem_rel m' (kill_mem rel) rs. -Proof. - unfold sem_rel, sem_reg. - intros until rs. - intros SEM x. - pose proof (SEM x) as SEMx. - unfold kill_mem. - rewrite PTree.gfilter1. - unfold kill_sym_val_mem. - destruct (rel ! x) as [ sv | ]. - 2: reflexivity. - destruct sv; simpl in *; trivial. - { - destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial. - rewrite <- SEMx. - apply op_depends_on_memory_correct; auto. - } -Qed. - -End SOUNDNESS. +*) Definition apply_instr instr (rel : RELATION.t) : RB.t := match instr with @@ -809,459 +440,3 @@ Lemma transf_program_match: 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; 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. - -Lemma transf_function_at: - forall (f : function) (pc : node) (i : instruction), - (fn_code f)!pc = Some i -> - (fn_code (transf_function f))!pc = - Some(transf_instr (forward_map f) pc i). -Proof. - intros until i. intro CODE. - unfold transf_function; simpl. - rewrite PTree.gmap. - unfold option_map. - rewrite CODE. - reflexivity. -Qed. - -Definition sem_rel_b (relb : RB.t) sp m (rs : regset) := - match relb with - | Some rel => sem_rel fundef unit ge sp m rel rs - | None => True - end. - -Definition fmap_sem (fmap : option (PMap.t RB.t)) - sp m (pc : node) (rs : regset) := - match fmap with - | None => True - | Some map => sem_rel_b (PMap.get pc map) sp m rs - end. - -(* -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. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. - replace (map # pc) 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. - simpl. tauto. - } - unfold apply_instr'. - unfold get_rb_sem in *. - destruct (map # pc) in *; try contradiction. - rewrite H. - reflexivity. -- (* op *) - econstructor; split. - eapply exec_Iop with (v := v); eauto. - rewrite <- H0. - rewrite subst_args_ok by assumption. - apply eval_operation_preserved. exact symbols_preserved. - constructor; auto. - - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. - { - eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. - 2: apply apply_instr'_bot. - simpl. tauto. - } - unfold apply_instr' in GE. - rewrite MPC in GE. - rewrite H in GE. - - destruct (op_cases op args res pc' mpc) as [[src [OP [ARGS MOVE]]] | KILL]. - { - subst op. - subst args. - rewrite MOVE in GE. - simpl in H0. - simpl in GE. - apply get_rb_sem_ge with (rb2 := Some (move src res mpc)). - assumption. - replace v with (rs # src) by congruence. - apply move_ok. - assumption. - } - rewrite KILL in GE. - apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). - assumption. - apply kill_ok. - assumption. - -(* 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. - rewrite subst_args_ok; assumption. - constructor; auto. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). - { - replace (Some (kill dst 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. - simpl. tauto. - } - unfold apply_instr'. - rewrite H. - rewrite MPC. - reflexivity. - } - apply kill_ok. - assumption. - -- (* 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. - rewrite subst_args_ok; assumption. - constructor; auto. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). - { - replace (Some (kill dst 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. - simpl. tauto. - } - unfold apply_instr'. - rewrite H. - rewrite MPC. - reflexivity. - } - apply kill_ok. - assumption. - -- (* 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. - rewrite subst_args_ok; assumption. - constructor; auto. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). - { - replace (Some (kill dst 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. - simpl. tauto. - } - unfold apply_instr'. - rewrite H. - rewrite MPC. - reflexivity. - } - apply kill_ok. - assumption. - -- (* 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. - rewrite subst_args_ok; assumption. - constructor; auto. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. - replace (map # pc) 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. - simpl. tauto. - } - unfold apply_instr'. - unfold get_rb_sem in *. - destruct (map # pc) in *; try contradiction. - rewrite H. - reflexivity. - -(* call *) -- econstructor; split. - eapply exec_Icall with (fd := transf_fundef fd); eauto. - eapply find_function_translated; eauto. - apply sig_preserved. - rewrite subst_args_ok by assumption. - constructor. constructor; auto. constructor. - - { - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). - { - replace (Some (kill res 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. - simpl. tauto. - } - unfold apply_instr'. - rewrite H. - rewrite MPC. - reflexivity. - } - apply kill_weaken. - assumption. - } - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. - { - eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. - 2: apply apply_instr'_bot. - simpl. tauto. - } - unfold apply_instr' in GE. - unfold fmap_sem in *. - destruct (map # pc) as [mpc |] in *; try contradiction. - rewrite H in GE. - simpl in GE. - unfold is_killed_in_fmap, is_killed_in_map. - unfold RB.ge in GE. - destruct (map # pc') as [mpc'|] eqn:MPC' in *; trivial. - eauto. - -(* tailcall *) -- econstructor; split. - eapply exec_Itailcall with (fd := transf_fundef fd); eauto. - eapply find_function_translated; eauto. - apply sig_preserved. - rewrite subst_args_ok by assumption. - 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. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - - apply get_rb_sem_ge with (rb2 := Some RELATION.top). - { - replace (Some RELATION.top) 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. - simpl. tauto. - } - unfold apply_instr'. - rewrite H. - rewrite MPC. - reflexivity. - } - apply top_ok. - -(* cond *) -- econstructor; split. - eapply exec_Icond; eauto. - rewrite subst_args_ok; eassumption. - constructor; auto. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. - replace (map # pc) 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. - simpl. - destruct b; tauto. - } - unfold apply_instr'. - unfold get_rb_sem in *. - destruct (map # pc) in *; try contradiction. - rewrite H. - reflexivity. - -(* jumptbl *) -- econstructor; split. - eapply exec_Ijumptable; eauto. - rewrite subst_arg_ok; eassumption. - constructor; auto. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. - replace (map # pc) 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. - simpl. - apply list_nth_z_in with (n := Int.unsigned n). - assumption. - } - unfold apply_instr'. - unfold get_rb_sem in *. - destruct (map # pc) in *; try contradiction. - rewrite H. - reflexivity. - -(* return *) -- destruct or as [arg | ]. - { - econstructor; split. - eapply exec_Ireturn; eauto. - unfold regmap_optget. - rewrite subst_arg_ok by eassumption. - constructor; auto. - } - econstructor; split. - eapply exec_Ireturn; eauto. - constructor; auto. - - -(* internal function *) -- simpl. econstructor; split. - eapply exec_function_internal; eauto. - constructor; auto. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := Some RELATION.top). - { - eapply DS.fixpoint_entry with (code := fn_code f) (successors := successors_instr); try eassumption. - } - apply top_ok. - -(* 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. - - simpl in *. - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - unfold is_killed_in_fmap in H8. - unfold is_killed_in_map in H8. - destruct (map # pc) as [mpc |] in *; try contradiction. - destruct H8 as [rel' RGE]. - eapply get_rb_killed; eauto. -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. -*) \ No newline at end of file diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v new file mode 100644 index 00000000..a14988a0 --- /dev/null +++ b/backend/CSE2proof.v @@ -0,0 +1,835 @@ +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. + +Lemma args_unaffected: + forall rs : regset, + forall dst : reg, + forall v, + forall args : list reg, + existsb (fun y : reg => peq dst y) args = false -> + (rs # dst <- v ## args) = (rs ## args). +Proof. + induction args; simpl; trivial. + destruct (peq dst a) as [EQ | NEQ]; simpl. + { discriminate. + } + intro EXIST. + f_equal. + { + apply Regmap.gso. + congruence. + } + apply IHargs. + assumption. +Qed. + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Section SAME_MEMORY. + Variable m : mem. + +Definition sem_sym_val sym rs := + match sym with + | SMove src => Some (rs # src) + | SOp op args => + eval_operation genv sp op (rs ## args) m + end. + +Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := + match rel ! x with + | None => Some (rs # x) + | Some sym => sem_sym_val sym rs + end. + +Definition sem_rel (rel : RELATION.t) (rs : regset) := + forall x : reg, (sem_reg rel x rs) = Some (rs # x). + +Lemma kill_reg_sound : + forall rel : RELATION.t, + forall dst : reg, + forall rs, + forall v, + sem_rel rel rs -> + sem_rel (kill_reg dst rel) (rs # dst <- v). +Proof. + unfold sem_rel, kill_reg, sem_reg, sem_sym_val. + intros until v. + intros REL x. + rewrite PTree.gfilter1. + destruct (Pos.eq_dec dst x). + { + subst x. + rewrite PTree.grs. + rewrite Regmap.gss. + reflexivity. + } + rewrite PTree.gro by congruence. + rewrite Regmap.gso by congruence. + destruct (rel ! x) as [relx | ] eqn:RELx. + 2: reflexivity. + unfold kill_sym_val. + pose proof (REL x) as RELinstx. + rewrite RELx in RELinstx. + destruct relx eqn:SYMVAL. + { + destruct (peq dst src); simpl. + { reflexivity. } + rewrite Regmap.gso by congruence. + assumption. + } + { destruct existsb eqn:EXISTS; simpl. + { reflexivity. } + rewrite args_unaffected by exact EXISTS. + assumption. + } +Qed. + +Lemma write_same: + forall rs : regset, + forall src dst : reg, + (rs # dst <- (rs # src)) # src = rs # src. +Proof. + intros. + destruct (peq src dst). + { + subst dst. + apply Regmap.gss. + } + rewrite Regmap.gso by congruence. + reflexivity. +Qed. + +Lemma move_sound : + forall rel : RELATION.t, + forall src dst : reg, + forall rs, + sem_rel rel rs -> + sem_rel (move src dst rel) (rs # dst <- (rs # src)). +Proof. + intros until rs. intros REL x. + pose proof (kill_reg_sound rel dst rs (rs # src) REL x) as KILL. + pose proof (REL src) as RELsrc. + unfold move. + destruct (peq x dst). + { + subst x. + unfold sem_reg. + rewrite PTree.gss. + rewrite Regmap.gss. + unfold sem_reg in RELsrc. + simpl. + unfold forward_move. + destruct (rel ! src) as [ sv |]; simpl. + destruct sv; simpl in *. + { + destruct (peq dst src0). + { + subst src0. + rewrite Regmap.gss. + reflexivity. + } + rewrite Regmap.gso by congruence. + assumption. + } + all: f_equal; apply write_same. + } + rewrite Regmap.gso by congruence. + unfold sem_reg. + rewrite PTree.gso by congruence. + rewrite Regmap.gso in KILL by congruence. + exact KILL. +Qed. + +Lemma move_cases_neq: + forall dst rel a, + a <> dst -> + (forward_move (kill_reg dst rel) a) <> dst. +Proof. + intros until a. intro NEQ. + unfold kill_reg, forward_move. + rewrite PTree.gfilter1. + rewrite PTree.gro by congruence. + destruct (rel ! a); simpl. + 2: congruence. + destruct s. + { + unfold kill_sym_val. + destruct peq; simpl; congruence. + } + all: simpl; + destruct negb; simpl; congruence. +Qed. + +Lemma args_replace_dst : + forall rel, + forall args : list reg, + forall dst : reg, + forall rs : regset, + forall v, + (sem_rel rel rs) -> + not (In dst args) -> + (rs # dst <- v) + ## (map + (forward_move (kill_reg dst rel)) args) = rs ## args. +Proof. + induction args; simpl. + 1: reflexivity. + intros until v. + intros REL NOT_IN. + rewrite IHargs by auto. + f_equal. + pose proof (REL a) as RELa. + rewrite Regmap.gso by (apply move_cases_neq; auto). + unfold kill_reg. + unfold sem_reg in RELa. + unfold forward_move. + rewrite PTree.gfilter1. + rewrite PTree.gro by auto. + destruct (rel ! a); simpl; trivial. + destruct s; simpl in *; destruct negb; simpl; congruence. +Qed. + +Lemma oper1_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + not (In dst args) -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (oper1 op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL NOT_IN EVAL x. + pose proof (kill_reg_sound rel dst rs v REL x) as KILL. + unfold oper1. + destruct (peq x dst). + { + subst x. + unfold sem_reg. + rewrite PTree.gss. + rewrite Regmap.gss. + simpl. + rewrite args_replace_dst by auto. + assumption. + } + rewrite Regmap.gso by congruence. + unfold sem_reg. + rewrite PTree.gso by congruence. + rewrite Regmap.gso in KILL by congruence. + exact KILL. +Qed. + +Lemma oper_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (oper op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL EVAL. + unfold oper. + destruct in_dec. + { + apply kill_reg_sound; auto. + } + apply oper1_sound; auto. +Qed. + +Lemma gen_oper_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (gen_oper op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL EVAL. + unfold gen_oper. + destruct op. + { destruct args as [ | h0 t0]. + apply oper_sound; auto. + destruct t0. + { + simpl in *. + replace v with (rs # h0) by congruence. + apply move_sound; auto. + } + apply oper_sound; auto. + } + all: apply oper_sound; auto. +Qed. + + +Lemma find_op_sound : + forall rel : RELATION.t, + forall op : operation, + forall src dst : reg, + forall args: list reg, + forall rs : regset, + sem_rel rel rs -> + find_op rel op args = Some src -> + (eval_operation genv sp op (rs ## args) m) = Some (rs # src). +Proof. + intros until rs. + unfold find_op. + rewrite PTree.fold_spec. + intro REL. + assert ( + forall start, + match start with + | None => True + | Some src => eval_operation genv sp op rs ## args m = Some rs # src + end -> fold_left + (fun (a : option reg) (p : positive * sym_val) => + find_op_fold op args a (fst p) (snd p)) (PTree.elements rel) start = + Some src -> + eval_operation genv sp op rs ## args m = Some rs # src) as REC. + { + unfold sem_rel, sem_reg in REL. + generalize (PTree.elements_complete rel). + generalize (PTree.elements rel). + induction l; simpl. + { + intros. + subst start. + assumption. + } + destruct a as [r sv]; simpl. + intros COMPLETE start GEN. + apply IHl. + { + intros. + apply COMPLETE. + right. + assumption. + } + unfold find_op_fold. + destruct start. + assumption. + destruct sv. + { trivial. } + destruct eq_operation; trivial. + subst op0. + destruct eq_args; trivial. + subst args0. + simpl. + assert ((rel ! r) = Some (SOp op args)) as RELatr. + { + apply COMPLETE. + left. + reflexivity. + } + pose proof (REL r) as RELr. + rewrite RELatr in RELr. + simpl in RELr. + assumption. + } + apply REC; auto. +Qed. + +End SAME_MEMORY. + +Lemma kill_mem_sound : + forall m m' : mem, + forall rel : RELATION.t, + forall rs, + sem_rel m rel rs -> sem_rel m' (kill_mem rel) rs. +Proof. + unfold sem_rel, sem_reg. + intros until rs. + intros SEM x. + pose proof (SEM x) as SEMx. + unfold kill_mem. + rewrite PTree.gfilter1. + unfold kill_sym_val_mem. + destruct (rel ! x) as [ sv | ]. + 2: reflexivity. + destruct sv; simpl in *; trivial. + { + destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial. + rewrite <- SEMx. + apply op_depends_on_memory_correct; auto. + } +Qed. + +End SOUNDNESS. + + +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. + +Lemma transf_function_at: + forall (f : function) (pc : node) (i : instruction), + (fn_code f)!pc = Some i -> + (fn_code (transf_function f))!pc = + Some(transf_instr (forward_map f) pc i). +Proof. + intros until i. intro CODE. + unfold transf_function; simpl. + rewrite PTree.gmap. + unfold option_map. + rewrite CODE. + reflexivity. +Qed. + +Definition sem_rel_b (relb : RB.t) sp m (rs : regset) := + match relb with + | Some rel => sem_rel fundef unit ge sp m rel rs + | None => True + end. + +Definition fmap_sem (fmap : option (PMap.t RB.t)) + sp m (pc : node) (rs : regset) := + match fmap with + | None => True + | Some map => sem_rel_b (PMap.get pc map) sp m rs + end. + +(* +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. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. +- (* op *) + econstructor; split. + eapply exec_Iop with (v := v); eauto. + rewrite <- H0. + rewrite subst_args_ok by assumption. + apply eval_operation_preserved. exact symbols_preserved. + constructor; auto. + + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. + { + eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. + 2: apply apply_instr'_bot. + simpl. tauto. + } + unfold apply_instr' in GE. + rewrite MPC in GE. + rewrite H in GE. + + destruct (op_cases op args res pc' mpc) as [[src [OP [ARGS MOVE]]] | KILL]. + { + subst op. + subst args. + rewrite MOVE in GE. + simpl in H0. + simpl in GE. + apply get_rb_sem_ge with (rb2 := Some (move src res mpc)). + assumption. + replace v with (rs # src) by congruence. + apply move_ok. + assumption. + } + rewrite KILL in GE. + apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + assumption. + apply kill_ok. + assumption. + +(* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. + +- (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. + +- (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + { + replace (Some (kill dst 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_ok. + assumption. + +- (* 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. + rewrite subst_args_ok; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. + +(* call *) +- econstructor; split. + eapply exec_Icall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + rewrite subst_args_ok by assumption. + constructor. constructor; auto. constructor. + + { + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + { + replace (Some (kill res 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply kill_weaken. + assumption. + } + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. + { + eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. + 2: apply apply_instr'_bot. + simpl. tauto. + } + unfold apply_instr' in GE. + unfold fmap_sem in *. + destruct (map # pc) as [mpc |] in *; try contradiction. + rewrite H in GE. + simpl in GE. + unfold is_killed_in_fmap, is_killed_in_map. + unfold RB.ge in GE. + destruct (map # pc') as [mpc'|] eqn:MPC' in *; trivial. + eauto. + +(* tailcall *) +- econstructor; split. + eapply exec_Itailcall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + rewrite subst_args_ok by assumption. + 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. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + + apply get_rb_sem_ge with (rb2 := Some RELATION.top). + { + replace (Some RELATION.top) 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + apply top_ok. + +(* cond *) +- econstructor; split. + eapply exec_Icond; eauto. + rewrite subst_args_ok; eassumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. + destruct b; tauto. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. + +(* jumptbl *) +- econstructor; split. + eapply exec_Ijumptable; eauto. + rewrite subst_arg_ok; eassumption. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := map # pc); trivial. + replace (map # pc) 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. + simpl. + apply list_nth_z_in with (n := Int.unsigned n). + assumption. + } + unfold apply_instr'. + unfold get_rb_sem in *. + destruct (map # pc) in *; try contradiction. + rewrite H. + reflexivity. + +(* return *) +- destruct or as [arg | ]. + { + econstructor; split. + eapply exec_Ireturn; eauto. + unfold regmap_optget. + rewrite subst_arg_ok by eassumption. + constructor; auto. + } + econstructor; split. + eapply exec_Ireturn; eauto. + constructor; auto. + + +(* internal function *) +- simpl. econstructor; split. + eapply exec_function_internal; eauto. + constructor; auto. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + apply get_rb_sem_ge with (rb2 := Some RELATION.top). + { + eapply DS.fixpoint_entry with (code := fn_code f) (successors := successors_instr); try eassumption. + } + apply top_ok. + +(* 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. + + simpl in *. + unfold fmap_sem in *. + destruct (forward_map _) as [map |] eqn:MAP in *; trivial. + unfold is_killed_in_fmap in H8. + unfold is_killed_in_map in H8. + destruct (map # pc) as [mpc |] in *; try contradiction. + destruct H8 as [rel' RGE]. + eapply get_rb_killed; eauto. +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. \ No newline at end of file -- cgit From a200d33d3751fad37620a22a9e4d33e0b88176c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 09:39:08 +0100 Subject: sem_rel_b_ge --- backend/CSE2proof.v | 95 +++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 77 insertions(+), 18 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index a14988a0..d9150658 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -438,7 +438,7 @@ Qed. Definition sem_rel_b (relb : RB.t) sp m (rs : regset) := match relb with | Some rel => sem_rel fundef unit ge sp m rel rs - | None => True + | None => False end. Definition fmap_sem (fmap : option (PMap.t RB.t)) @@ -448,7 +448,66 @@ Definition fmap_sem (fmap : option (PMap.t RB.t)) | Some map => sem_rel_b (PMap.get pc map) sp m rs end. -(* +Definition is_killed_in_map (map : PMap.t RB.t) pc res := + match PMap.get pc map with + | None => True + | Some rel => exists rel', RELATION.ge rel (kill_reg res rel') + end. + +Definition is_killed_in_fmap fmap pc res := + match fmap with + | None => True + | Some map => is_killed_in_map map pc res + end. + + +Lemma sem_rel_b_ge: + forall rb1 rb2 : RB.t, + (RB.ge rb1 rb2) -> + forall sp m, + forall rs : regset, + (sem_rel_b rb2 sp m rs) -> (sem_rel_b rb1 sp m rs). +Proof. + unfold sem_rel_b, sem_rel, sem_reg. + destruct rb1 as [r1 | ]; + destruct rb2 as [r2 | ]; simpl; + intros GE sp m rs RE; try contradiction. + intro x. + pose proof (RE x) as REx. + pose proof (GE x) as GEx. + destruct (r1 ! x) as [r1x | ] in *; + destruct (r2 ! x) as [r2x | ] in *; + congruence. +Qed. + +Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := +| match_frames_intro: forall res f sp pc rs, + (forall m : mem, (fmap_sem (forward_map f) sp m pc rs)) -> + (is_killed_in_fmap (forward_map f) pc res) -> + 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 (forward_map f) sp m 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). + +Ltac TR_AT := + match goal with + | [ A: (fn_code _)!_ = Some _ |- _ ] => + generalize (transf_function_at _ _ _ A); intros + end. + Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> @@ -462,7 +521,7 @@ Proof. simpl in *. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. + apply sem_rel_b_ge with (rb2 := map # pc); trivial. replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). { eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. @@ -470,7 +529,7 @@ Proof. simpl. tauto. } unfold apply_instr'. - unfold get_rb_sem in *. + unfold sem_rel_b in *. destruct (map # pc) in *; try contradiction. rewrite H. reflexivity. @@ -502,14 +561,14 @@ Proof. rewrite MOVE in GE. simpl in H0. simpl in GE. - apply get_rb_sem_ge with (rb2 := Some (move src res mpc)). + apply sem_rel_b_ge with (rb2 := Some (move src res mpc)). assumption. replace v with (rs # src) by congruence. apply move_ok. assumption. } rewrite KILL in GE. - apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + apply sem_rel_b_ge with (rb2 := Some (kill res mpc)). assumption. apply kill_ok. assumption. @@ -527,7 +586,7 @@ Proof. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (kill dst mpc)). { replace (Some (kill dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). { @@ -555,7 +614,7 @@ Proof. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (kill dst mpc)). { replace (Some (kill dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). { @@ -583,7 +642,7 @@ Proof. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (kill dst mpc)). { replace (Some (kill dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). { @@ -610,7 +669,7 @@ Proof. simpl in *. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. + apply sem_rel_b_ge with (rb2 := map # pc); trivial. replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). { eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. @@ -618,7 +677,7 @@ Proof. simpl. tauto. } unfold apply_instr'. - unfold get_rb_sem in *. + unfold sem_rel_b in *. destruct (map # pc) in *; try contradiction. rewrite H. reflexivity. @@ -636,7 +695,7 @@ Proof. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some (kill res mpc)). + apply sem_rel_b_ge with (rb2 := Some (kill res mpc)). { replace (Some (kill res mpc)) with (apply_instr' (fn_code f) pc (map # pc)). { @@ -689,7 +748,7 @@ Proof. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply get_rb_sem_ge with (rb2 := Some RELATION.top). + apply sem_rel_b_ge with (rb2 := Some RELATION.top). { replace (Some RELATION.top) with (apply_instr' (fn_code f) pc (map # pc)). { @@ -713,7 +772,7 @@ Proof. simpl in *. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. + apply sem_rel_b_ge with (rb2 := map # pc); trivial. replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). { eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. @@ -722,7 +781,7 @@ Proof. destruct b; tauto. } unfold apply_instr'. - unfold get_rb_sem in *. + unfold sem_rel_b in *. destruct (map # pc) in *; try contradiction. rewrite H. reflexivity. @@ -736,7 +795,7 @@ Proof. simpl in *. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := map # pc); trivial. + apply sem_rel_b_ge with (rb2 := map # pc); trivial. replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). { eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. @@ -746,7 +805,7 @@ Proof. assumption. } unfold apply_instr'. - unfold get_rb_sem in *. + unfold sem_rel_b in *. destruct (map # pc) in *; try contradiction. rewrite H. reflexivity. @@ -773,7 +832,7 @@ Proof. simpl in *. unfold fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply get_rb_sem_ge with (rb2 := Some RELATION.top). + apply sem_rel_b_ge with (rb2 := Some RELATION.top). { eapply DS.fixpoint_entry with (code := fn_code f) (successors := successors_instr); try eassumption. } -- cgit From 427fc1fb431b4200ac5e60981a4d570863e2539f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 11:16:38 +0100 Subject: sem_rel_b_ge progress --- backend/CSE2proof.v | 213 +++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 152 insertions(+), 61 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index d9150658..f2306d21 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -53,6 +53,57 @@ Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := Definition sem_rel (rel : RELATION.t) (rs : regset) := forall x : reg, (sem_reg rel x rs) = Some (rs # x). +Definition sem_rel_b (relb : RB.t) (rs : regset) := + match relb with + | Some rel => sem_rel rel rs + | None => False + end. + +Definition fmap_sem (fmap : option (PMap.t RB.t)) + (pc : node) (rs : regset) := + match fmap with + | None => True + | Some m => sem_rel_b (PMap.get pc m) rs + end. + +Lemma subst_arg_ok: + forall f, + forall pc, + forall rs, + forall arg, + fmap_sem (forward_map f) pc rs -> + rs # (subst_arg (forward_map f) pc arg) = rs # arg. +Proof. + intros until arg. + intro SEM. + unfold fmap_sem in SEM. + destruct (forward_map f) as [map |]in *; trivial. + simpl. + unfold sem_rel_b, sem_rel, sem_reg in *. + destruct (map # pc). + 2: contradiction. + pose proof (SEM arg) as SEMarg. + simpl. unfold forward_move. + unfold sem_sym_val in *. + destruct (t ! arg); trivial. + destruct s; congruence. +Qed. + +Lemma subst_args_ok: + forall f, + forall pc, + forall rs, + fmap_sem (forward_map f) pc rs -> + forall args, + rs ## (subst_args (forward_map f) pc args) = rs ## args. +Proof. + induction args; trivial. + simpl. + f_equal. + apply subst_arg_ok; assumption. + assumption. +Qed. + Lemma kill_reg_sound : forall rel : RELATION.t, forall dst : reg, @@ -348,6 +399,27 @@ Proof. apply REC; auto. Qed. + +Lemma kill_reg_weaken: + forall res mpc rs, + sem_rel mpc rs -> + sem_rel (kill_reg res mpc) rs. +Proof. + Check kill_reg_sound. + intros until rs. + intros REL x. + pose proof (REL x) as RELx. + unfold kill_reg, sem_reg in *. + rewrite PTree.gfilter1. + destruct (peq res x). + { subst x. + rewrite PTree.grs. + reflexivity. + } + rewrite PTree.gro by congruence. + destruct (mpc ! x) as [sv | ]; trivial. + destruct negb; trivial. +Qed. End SAME_MEMORY. Lemma kill_mem_sound : @@ -435,19 +507,6 @@ Proof. reflexivity. Qed. -Definition sem_rel_b (relb : RB.t) sp m (rs : regset) := - match relb with - | Some rel => sem_rel fundef unit ge sp m rel rs - | None => False - end. - -Definition fmap_sem (fmap : option (PMap.t RB.t)) - sp m (pc : node) (rs : regset) := - match fmap with - | None => True - | Some map => sem_rel_b (PMap.get pc map) sp m rs - end. - Definition is_killed_in_map (map : PMap.t RB.t) pc res := match PMap.get pc map with | None => True @@ -460,15 +519,19 @@ Definition is_killed_in_fmap fmap pc res := | Some map => is_killed_in_map map pc res end. +Definition sem_rel_b' := sem_rel_b fundef unit ge. +Definition fmap_sem' := fmap_sem fundef unit ge. +Definition subst_args_ok' := subst_args_ok fundef unit ge. +Definition kill_mem_sound' := kill_mem_sound fundef unit ge. Lemma sem_rel_b_ge: forall rb1 rb2 : RB.t, (RB.ge rb1 rb2) -> forall sp m, forall rs : regset, - (sem_rel_b rb2 sp m rs) -> (sem_rel_b rb1 sp m rs). + (sem_rel_b' sp m rb2 rs) -> (sem_rel_b' sp m rb1 rs). Proof. - unfold sem_rel_b, sem_rel, sem_reg. + unfold sem_rel_b', sem_rel_b, sem_rel, sem_reg. destruct rb1 as [r1 | ]; destruct rb2 as [r2 | ]; simpl; intros GE sp m rs RE; try contradiction. @@ -480,9 +543,17 @@ Proof. congruence. Qed. +Lemma apply_instr'_bot : + forall code, + forall pc, + RB.eq (apply_instr' code pc RB.bot) RB.bot. +Proof. + reflexivity. +Qed. + Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := | match_frames_intro: forall res f sp pc rs, - (forall m : mem, (fmap_sem (forward_map f) sp m pc rs)) -> + (forall m : mem, (fmap_sem' sp m (forward_map f) pc rs)) -> (is_killed_in_fmap (forward_map f) pc res) -> match_frames (Stackframe res f sp pc rs) (Stackframe res (transf_function f) sp pc rs). @@ -490,7 +561,7 @@ Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := 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 (forward_map f) sp m pc rs) -> + (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' @@ -519,7 +590,7 @@ Proof. constructor; auto. simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. apply sem_rel_b_ge with (rb2 := map # pc); trivial. replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). @@ -534,6 +605,7 @@ Proof. rewrite H. reflexivity. - (* op *) + (* econstructor; split. eapply exec_Iop with (v := v); eauto. rewrite <- H0. @@ -572,23 +644,24 @@ Proof. assumption. apply kill_ok. assumption. - + *) + admit. (* 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. - rewrite subst_args_ok; assumption. + rewrite (subst_args_ok' sp m); assumption. constructor; auto. simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. 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 dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (kill_reg dst mpc)). { - replace (Some (kill dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (kill_reg dst 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. @@ -599,9 +672,10 @@ Proof. rewrite MPC. reflexivity. } - apply kill_ok. + apply kill_reg_sound. assumption. - + + (* NOT IN THIS VERSION - (* load notrap1 *) econstructor; split. assert (eval_addressing tge sp addr rs ## args = None). @@ -657,20 +731,25 @@ Proof. } apply kill_ok. assumption. + *) - (* 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. - rewrite subst_args_ok; assumption. + 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. + rewrite (subst_args_ok' sp m); assumption. + } + constructor; auto. - simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - apply sem_rel_b_ge with (rb2 := map # pc); trivial. - replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. + apply sem_rel_b_ge with (rb2 := Some (kill_mem mpc)); trivial. + { + replace (Some (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. @@ -678,39 +757,47 @@ Proof. } unfold apply_instr'. unfold sem_rel_b in *. - destruct (map # pc) in *; try contradiction. + rewrite MPC. rewrite H. reflexivity. + } + apply (kill_mem_sound' sp m). + assumption. (* call *) - econstructor; split. eapply exec_Icall with (fd := transf_fundef fd); eauto. eapply find_function_translated; eauto. apply sig_preserved. - rewrite subst_args_ok by assumption. - constructor. constructor; auto. constructor. + rewrite (subst_args_ok' sp m) by assumption. + constructor. constructor; auto. + constructor. { - simpl in *. - unfold fmap_sem in *. - 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 res mpc)). - { - replace (Some (kill res mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + intro m'. + unfold fmap_sem', fmap_sem in *. + 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_reg res (kill_mem mpc))). { - eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. - 2: apply apply_instr'_bot. - simpl. tauto. + replace (Some (kill_reg 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. } - unfold apply_instr'. - rewrite H. - rewrite MPC. - reflexivity. - } - apply kill_weaken. - assumption. + apply kill_reg_weaken. + apply (kill_mem_sound' sp m). + assumption. } + { + simpl in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. { @@ -719,23 +806,27 @@ Proof. simpl. tauto. } unfold apply_instr' in GE. - unfold fmap_sem in *. - destruct (map # pc) as [mpc |] in *; try contradiction. rewrite H in GE. simpl in GE. + destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. unfold is_killed_in_fmap, is_killed_in_map. - unfold RB.ge in GE. - destruct (map # pc') as [mpc'|] eqn:MPC' in *; trivial. - eauto. + destruct (map # pc') as [mpc' |] eqn:MPC' ; try contradiction. + + exists (kill_mem mpc). + assumption. + } (* tailcall *) - econstructor; split. eapply exec_Itailcall with (fd := transf_fundef fd); eauto. eapply find_function_translated; eauto. apply sig_preserved. - rewrite subst_args_ok by assumption. + Check subst_args_ok. + rewrite (subst_args_ok' (Vptr stk Ptrofs.zero) m) by assumption. constructor. auto. - + + (* TODO *) + (* builtin *) - econstructor; split. eapply exec_Ibuiltin; eauto. -- cgit From e974c5a24dcc80ecb4e61725bb5131570bc447fc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 12:11:42 +0100 Subject: rework --- backend/CSE2proof.v | 69 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 49 insertions(+), 20 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index f2306d21..ad11a8e9 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -420,6 +420,30 @@ Proof. destruct (mpc ! x) as [sv | ]; trivial. destruct negb; trivial. Qed. + +Lemma top_ok: + forall rs, sem_rel RELATION.top rs. +Proof. + unfold sem_rel, sem_reg, RELATION.top. + intros. + rewrite PTree.gempty. + reflexivity. +Qed. + +Lemma sem_rel_ge: + forall r1 r2 : RELATION.t, + (RELATION.ge r1 r2) -> + forall rs : regset, + (sem_rel r2 rs) -> (sem_rel r1 rs). +Proof. + intros r1 r2 GE rs RE x. + pose proof (RE x) as REx. + pose proof (GE x) as GEx. + unfold sem_reg in *. + destruct (r1 ! x) as [r1x | ] in *; + destruct (r2 ! x) as [r2x | ] in *; + congruence. +Qed. End SAME_MEMORY. Lemma kill_mem_sound : @@ -444,7 +468,7 @@ Proof. apply op_depends_on_memory_correct; auto. } Qed. - + End SOUNDNESS. @@ -521,6 +545,7 @@ Definition is_killed_in_fmap fmap pc res := 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. Definition subst_args_ok' := subst_args_ok fundef unit ge. Definition kill_mem_sound' := kill_mem_sound fundef unit ge. @@ -531,16 +556,11 @@ Lemma sem_rel_b_ge: forall rs : regset, (sem_rel_b' sp m rb2 rs) -> (sem_rel_b' sp m rb1 rs). Proof. - unfold sem_rel_b', sem_rel_b, sem_rel, sem_reg. + unfold sem_rel_b', sem_rel_b. destruct rb1 as [r1 | ]; destruct rb2 as [r2 | ]; simpl; intros GE sp m rs RE; try contradiction. - intro x. - pose proof (RE x) as REx. - pose proof (GE x) as GEx. - destruct (r1 ! x) as [r1x | ] in *; - destruct (r2 ! x) as [r2x | ] in *; - congruence. + apply sem_rel_ge with (r2 := r2); assumption. Qed. Lemma apply_instr'_bot : @@ -825,8 +845,6 @@ Proof. rewrite (subst_args_ok' (Vptr stk Ptrofs.zero) m) by assumption. constructor. auto. - (* TODO *) - (* builtin *) - econstructor; split. eapply exec_Ibuiltin; eauto. @@ -835,7 +853,7 @@ Proof. constructor; auto. simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. @@ -854,14 +872,15 @@ Proof. } apply top_ok. + (* cond *) - econstructor; split. eapply exec_Icond; eauto. - rewrite subst_args_ok; eassumption. + rewrite (subst_args_ok' sp m); eassumption. constructor; auto. simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. apply sem_rel_b_ge with (rb2 := map # pc); trivial. replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). @@ -876,15 +895,15 @@ Proof. destruct (map # pc) in *; try contradiction. rewrite H. reflexivity. - + (* jumptbl *) - econstructor; split. eapply exec_Ijumptable; eauto. - rewrite subst_arg_ok; eassumption. + rewrite (subst_arg_ok' sp m); eassumption. constructor; auto. simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. apply sem_rel_b_ge with (rb2 := map # pc); trivial. replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)). @@ -907,7 +926,7 @@ Proof. econstructor; split. eapply exec_Ireturn; eauto. unfold regmap_optget. - rewrite subst_arg_ok by eassumption. + rewrite (subst_arg_ok' (Vptr stk Ptrofs.zero) m) by eassumption. constructor; auto. } econstructor; split. @@ -921,7 +940,7 @@ Proof. constructor; auto. simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. apply sem_rel_b_ge with (rb2 := Some RELATION.top). { @@ -942,12 +961,22 @@ Proof. constructor; auto. simpl in *. - unfold fmap_sem in *. + unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. unfold is_killed_in_fmap in H8. unfold is_killed_in_map in H8. - destruct (map # pc) as [mpc |] in *; try contradiction. + destruct (map # pc) as [mpc |] in *; simpl in *; auto. destruct H8 as [rel' RGE]. + + (* WRONG *) + eapply sem_rel_ge. exact RGE. + apply kill_reg_sound. + assert (sem_rel fundef unit ge sp m (kill_reg res rel') rs # res <- vres). + { + + eapply sem_rel_ge. eassumption. + } + eapply kill_reg_sound. eapply get_rb_killed; eauto. Qed. -- cgit From 76049f12161c0eeeeec8841d2cc07d6601f39b4f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 12:14:55 +0100 Subject: now going back to op --- backend/CSE2proof.v | 51 ++++++--------------------------------------------- 1 file changed, 6 insertions(+), 45 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index ad11a8e9..8e7d7b3b 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -573,9 +573,9 @@ Qed. Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := | match_frames_intro: forall res f sp pc rs, - (forall m : mem, (fmap_sem' sp m (forward_map f) pc rs)) -> - (is_killed_in_fmap (forward_map f) pc res) -> - match_frames (Stackframe 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 := @@ -794,7 +794,7 @@ Proof. constructor. { - intro m'. + intros m' vres. unfold fmap_sem', fmap_sem in *. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. @@ -811,30 +811,10 @@ Proof. rewrite MPC. reflexivity. } - apply kill_reg_weaken. + apply kill_reg_sound. apply (kill_mem_sound' sp m). assumption. } - { - simpl in *. - unfold fmap_sem', fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. - { - eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. - 2: apply apply_instr'_bot. - simpl. tauto. - } - unfold apply_instr' in GE. - rewrite H in GE. - simpl in GE. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - unfold is_killed_in_fmap, is_killed_in_map. - destruct (map # pc') as [mpc' |] eqn:MPC' ; try contradiction. - - exists (kill_mem mpc). - assumption. - } (* tailcall *) - econstructor; split. @@ -959,26 +939,7 @@ Proof. econstructor; split. eapply exec_return; eauto. constructor; auto. - - simpl in *. - unfold fmap_sem', fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - unfold is_killed_in_fmap in H8. - unfold is_killed_in_map in H8. - destruct (map # pc) as [mpc |] in *; simpl in *; auto. - destruct H8 as [rel' RGE]. - - (* WRONG *) - eapply sem_rel_ge. exact RGE. - apply kill_reg_sound. - assert (sem_rel fundef unit ge sp m (kill_reg res rel') rs # res <- vres). - { - - eapply sem_rel_ge. eassumption. - } - eapply kill_reg_sound. - eapply get_rb_killed; eauto. -Qed. +Admitted. Lemma transf_initial_states: -- cgit From 47bcd22f7e1febf10bd0629c1774b7ab39fac872 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 13:25:12 +0100 Subject: CSE2 now works for expressions --- backend/CSE2.v | 11 ++---- backend/CSE2proof.v | 105 +++++++++++++++++++++++++++++++++------------------- 2 files changed, 69 insertions(+), 47 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 0bd5bf81..5b850cbb 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -343,8 +343,8 @@ Definition apply_instr instr (rel : RELATION.t) : RB.t := | Ijumptable _ _ => Some rel | Istore _ _ _ _ _ => Some (kill_mem rel) | Iop op args dst _ => Some (gen_oper op dst args rel) - | Iload _ _ _ dst _ - | Icall _ _ _ dst _ => Some (kill_reg dst rel) + | Iload _ _ _ dst _ => Some (kill_reg dst 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. @@ -377,11 +377,6 @@ Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg : Definition subst_args fmap pc := List.map (subst_arg fmap pc). -Definition gen_move src dst s := - if peq src dst - then Inop s - else Iop Omove (src::nil) dst s. - (* Transform *) Definition find_op_in_fmap fmap pc op args := match fmap with @@ -399,7 +394,7 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) | Iop op args dst s => match find_op_in_fmap fmap pc op args with | None => Iop op (subst_args fmap pc args) dst s - | Some src => gen_move src dst s + | Some src => Iop Omove (src::nil) dst s end | Iload chunk addr args dst s => Iload chunk addr (subst_args fmap pc args) dst s diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 8e7d7b3b..558490ba 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -335,7 +335,7 @@ Qed. Lemma find_op_sound : forall rel : RELATION.t, forall op : operation, - forall src dst : reg, + forall src : reg, forall args: list reg, forall rs : regset, sem_rel rel rs -> @@ -625,47 +625,75 @@ Proof. rewrite H. reflexivity. - (* op *) - (* - econstructor; split. - eapply exec_Iop with (v := v); eauto. - rewrite <- H0. - rewrite subst_args_ok by assumption. - apply eval_operation_preserved. exact symbols_preserved. - constructor; auto. - - unfold fmap_sem in *. - destruct (forward_map _) as [map |] eqn:MAP in *; trivial. - destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE. + unfold transf_instr in *. + destruct find_op_in_fmap eqn:FIND_OP. { - eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. - 2: apply apply_instr'_bot. - simpl. tauto. + unfold find_op_in_fmap, fmap_sem', fmap_sem in *. + destruct (forward_map f) as [map |] eqn:MAP. + 2: discriminate. + change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *. + destruct (map # pc) as [mpc | ] eqn:MPC. + 2: discriminate. + econstructor; split. + { + eapply exec_Iop with (v := v); eauto. + simpl. + rewrite find_op_sound with (rel := mpc) (src := r) in H0 by assumption. + assumption. + } + constructor; eauto. + unfold fmap_sem', fmap_sem in *. + rewrite MAP. + apply sem_rel_b_ge with (rb2 := Some (gen_oper op res args mpc)). + { + replace (Some (gen_oper op res args 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + unfold sem_rel_b', sem_rel_b. + apply gen_oper_sound; auto. } - unfold apply_instr' in GE. - rewrite MPC in GE. - rewrite H in GE. - - destruct (op_cases op args res pc' mpc) as [[src [OP [ARGS MOVE]]] | KILL]. { - subst op. - subst args. - rewrite MOVE in GE. - simpl in H0. - simpl in GE. - apply sem_rel_b_ge with (rb2 := Some (move src res mpc)). - assumption. - replace v with (rs # src) by congruence. - apply move_ok. - assumption. + econstructor; split. + { + eapply exec_Iop with (v := v); eauto. + rewrite (subst_args_ok' sp m) by assumption. + rewrite <- H0. + apply eval_operation_preserved. exact symbols_preserved. + } + constructor; eauto. + unfold fmap_sem', fmap_sem in *. + unfold find_op_in_fmap, fmap_sem', fmap_sem in *. + destruct (forward_map f) as [map |] eqn:MAP. + 2: constructor. + change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *. + destruct (map # pc) as [mpc | ] eqn:MPC. + 2: contradiction. + + apply sem_rel_b_ge with (rb2 := Some (gen_oper op res args mpc)). + { + replace (Some (gen_oper op res args 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + reflexivity. + } + unfold sem_rel_b', sem_rel_b. + apply gen_oper_sound; auto. } - rewrite KILL in GE. - apply sem_rel_b_ge with (rb2 := Some (kill res mpc)). - assumption. - apply kill_ok. - assumption. - *) - admit. + (* load *) - econstructor; split. assert (eval_addressing tge sp addr rs ## args = Some a). @@ -970,6 +998,5 @@ Proof. eexact transf_final_states. exact step_simulation. Qed. - *) End PRESERVATION. \ No newline at end of file -- cgit From 5412aea57eafe2868244a514471d480b83fc51bd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 13:59:55 +0100 Subject: connected (just a silly problem) --- backend/CSE2proof.v | 10 ++++++++-- driver/Clflags.ml | 1 + driver/Compiler.v | 36 ++++++++++++++++++++++++++++++++---- driver/Compopts.v | 3 +++ driver/Driver.ml | 7 +++++-- extraction/extraction.v | 2 ++ 6 files changed, 51 insertions(+), 8 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 558490ba..1d0a617a 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -405,7 +405,6 @@ Lemma kill_reg_weaken: sem_rel mpc rs -> sem_rel (kill_reg res mpc) rs. Proof. - Check kill_reg_sound. intros until rs. intros REL x. pose proof (REL x) as RELx. @@ -471,6 +470,14 @@ Qed. 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. @@ -849,7 +856,6 @@ Proof. eapply exec_Itailcall with (fd := transf_fundef fd); eauto. eapply find_function_translated; eauto. apply sig_preserved. - Check subst_args_ok. rewrite (subst_args_ok' (Vptr stk Ptrofs.zero) m) by assumption. constructor. auto. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 2db9399f..b4ab51e7 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -26,6 +26,7 @@ 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_fredundancy = ref true let option_fifconversion = ref true let option_Obranchless = ref false diff --git a/driver/Compiler.v b/driver/Compiler.v index 75247f71..33e31057 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -40,6 +40,7 @@ Require Inlining. Require Renumber. Require Constprop. Require CSE. +Require CSE2. Require Deadcode. Require Unusedglob. Require Allocation. @@ -61,6 +62,7 @@ Require Inliningproof. Require Renumberproof. Require Constpropproof. Require CSEproof. +Require CSE2proof. Require Deadcodeproof. Require Unusedglobproof. Require Allocproof. @@ -132,10 +134,12 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 5) @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) @@ print (print_RTL 6) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) @@ print (print_RTL 7) - @@@ time "Unused globals" Unusedglob.transform_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 8) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 9) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -241,6 +245,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_constprop Constpropproof.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) ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) ::: mkpass Unusedglobproof.match_prog ::: mkpass Allocproof.match_prog @@ -284,7 +289,27 @@ Proof. set (p10 := total_if optim_constprop Constprop.transf_program p9) in *. set (p11 := total_if optim_constprop Renumber.transf_program p10) in *. destruct (partial_if optim_CSE CSE.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate. - destruct (partial_if optim_redundancy Deadcode.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. + set (p12bis := @total_if RTL.program optim_CSE2 CSE2.transf_program p12). + change (@eq (res Asm.program) + (apply_partial Mach.program Asm.program + (apply_partial Linear.program Mach.program + (apply_partial Linear.program Linear.program + (apply_total Linear.program Linear.program + (apply_partial LTL.program Linear.program + (apply_total LTL.program LTL.program + (apply_partial RTL.program LTL.program + (apply_partial RTL.program RTL.program + (@partial_if RTL.program optim_redundancy + Deadcode.transf_program + p12bis) + Unusedglob.transform_program) + Allocation.transf_program) + Tunneling.tunnel_program) Linearize.transf_program) + CleanupLabels.transf_program) + (@partial_if Linear.program debug Debugvar.transf_program)) + Stacking.transf_program) Asmgen.transf_program) + (@OK Asm.program tp)) in T. + destruct (partial_if optim_redundancy Deadcode.transf_program p12bis) as [p13|e] eqn:P13; simpl in T; try discriminate. destruct (Unusedglob.transform_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. destruct (Allocation.transf_program p14) as [p15|e] eqn:P15; simpl in T; try discriminate. set (p16 := Tunneling.tunnel_program p15) in *. @@ -305,6 +330,7 @@ Proof. exists p10; split. apply total_if_match. apply Constpropproof.transf_program_match. exists p11; split. apply total_if_match. apply Renumberproof.transf_program_match. exists p12; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. + exists p12bis; split. apply total_if_match. apply CSE2proof.transf_program_match. exists p13; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. exists p14; split. apply Unusedglobproof.transf_program_match; auto. exists p15; split. apply Allocproof.transf_program_match; auto. @@ -364,7 +390,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 p21)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p22)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -389,6 +415,8 @@ Ltac DestructM := 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 Deadcodeproof.transf_program_correct; eassumption. eapply compose_forward_simulations. diff --git a/driver/Compopts.v b/driver/Compopts.v index 2a213350..594b74f1 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -36,6 +36,9 @@ Parameter optim_constprop: unit -> bool. (** Flag -fcse. For common subexpression elimination. *) Parameter optim_CSE: unit -> bool. +(** Flag -fcse2. For DMonniaux's common subexpression elimination. *) +Parameter optim_CSE2: unit -> bool. + (** Flag -fredundancy. For dead code elimination. *) Parameter optim_redundancy: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index be1252f9..bdf72250 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -194,6 +194,7 @@ Processing options: -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] -fredundancy Perform redundancy elimination [on] -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their @@ -253,8 +254,9 @@ let dump_mnemonics destfile = exit 0 let optimization_options = [ - option_ftailcalls; option_fifconversion; option_fconstprop; option_fcse; - option_fredundancy; option_finline; option_finline_functions_called_once; + option_ftailcalls; option_fifconversion; option_fconstprop; + option_fcse; option_fcse2; + option_fredundancy; option_finline; option_finline_functions_called_once; ] let set_all opts () = List.iter (fun r -> r := true) opts @@ -372,6 +374,7 @@ let cmdline_actions = @ f_opt "if-conversion" option_fifconversion @ f_opt "const-prop" option_fconstprop @ f_opt "cse" option_fcse + @ f_opt "cse2" option_fcse2 @ f_opt "redundancy" option_fredundancy @ f_opt "inline" option_finline @ f_opt "inline-functions-called-once" option_finline_functions_called_once diff --git a/extraction/extraction.v b/extraction/extraction.v index 521c0cdd..4635f5a2 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -108,6 +108,8 @@ Extract Constant Compopts.optim_constprop => "fun _ -> !Clflags.option_fconstprop". Extract Constant Compopts.optim_CSE => "fun _ -> !Clflags.option_fcse". +Extract Constant Compopts.optim_CSE2 => + "fun _ -> !Clflags.option_fcse2". Extract Constant Compopts.optim_redundancy => "fun _ -> !Clflags.option_fredundancy". Extract Constant Compopts.thumb => -- cgit From a7df9f6f48aa9282cb66b02bb63ca047b01f09b4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 15:01:39 +0100 Subject: still buggy --- backend/CSE2.v | 48 ++++++++++++++---------- backend/CSE2proof.v | 103 ++++++++++++++++++++++++++++++++++------------------ 2 files changed, 95 insertions(+), 56 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 5b850cbb..07bde1ac 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -275,24 +275,6 @@ Definition forward_move (rel : RELATION.t) (x : reg) : reg := Definition move (src dst : reg) (rel : RELATION.t) := PTree.set dst (SMove (forward_move rel src)) (kill_reg dst rel). -Definition oper1 (op: operation) (dst : reg) (args : list reg) - (rel : RELATION.t) := - let rel' := kill_reg dst rel in - PTree.set dst (SOp op (List.map (forward_move rel') args)) rel'. - -Definition oper (op: operation) (dst : reg) (args : list reg) - (rel : RELATION.t) := - if List.in_dec peq dst args - then kill_reg dst rel - else oper1 op dst args rel. - -Definition gen_oper (op: operation) (dst : reg) (args : list reg) - (rel : RELATION.t) := - match op, args with - | Omove, src::nil => move src dst rel - | _, _ => oper op dst args rel - end. - Definition find_op_fold op args (already : option reg) x sv := match already with | Some found => already @@ -309,6 +291,31 @@ Definition find_op_fold op args (already : option reg) x sv := Definition find_op (rel : RELATION.t) (op : operation) (args : list reg) := PTree.fold (find_op_fold op args) rel None. +Definition oper2 (op: operation) (dst : reg) (args : list reg) + (rel : RELATION.t) := + let rel' := kill_reg dst rel in + PTree.set dst (SOp op (List.map (forward_move rel') args)) rel'. + +Definition oper1 (op: operation) (dst : reg) (args : list reg) + (rel : RELATION.t) := + if List.in_dec peq dst args + then kill_reg dst rel + else oper2 op dst args rel. + +Definition oper (op: operation) (dst : reg) (args : list reg) + (rel : RELATION.t) := + match find_op rel op args with + | Some r => move r dst rel + | None => oper1 op dst args rel + end. + +Definition gen_oper (op: operation) (dst : reg) (args : list reg) + (rel : RELATION.t) := + match op, args with + | Omove, src::nil => move src dst rel + | _, _ => oper op dst args rel + end. + (* NO LONGER NEEDED Fixpoint list_represents { X : Type } (l : list (positive*X)) (tr : PTree.t X) : Prop := match l with @@ -392,8 +399,9 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) (pc: node) (instr: instruction) := match instr with | Iop op args dst s => - match find_op_in_fmap fmap pc op args with - | None => Iop op (subst_args fmap pc 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 chunk addr args dst s => diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 1d0a617a..47b60902 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -249,7 +249,7 @@ Proof. destruct s; simpl in *; destruct negb; simpl; congruence. Qed. -Lemma oper1_sound : +Lemma oper2_sound : forall rel : RELATION.t, forall op : operation, forall dst : reg, @@ -259,12 +259,12 @@ Lemma oper1_sound : sem_rel rel rs -> not (In dst args) -> eval_operation genv sp op (rs ## args) m = Some v -> - sem_rel (oper1 op dst args rel) (rs # dst <- v). + sem_rel (oper2 op dst args rel) (rs # dst <- v). Proof. intros until v. intros REL NOT_IN EVAL x. pose proof (kill_reg_sound rel dst rs v REL x) as KILL. - unfold oper1. + unfold oper2. destruct (peq x dst). { subst x. @@ -282,7 +282,7 @@ Proof. exact KILL. Qed. -Lemma oper_sound : +Lemma oper1_sound : forall rel : RELATION.t, forall op : operation, forall dst : reg, @@ -291,45 +291,18 @@ Lemma oper_sound : forall v, sem_rel rel rs -> eval_operation genv sp op (rs ## args) m = Some v -> - sem_rel (oper op dst args rel) (rs # dst <- v). + sem_rel (oper1 op dst args rel) (rs # dst <- v). Proof. intros until v. intros REL EVAL. - unfold oper. + unfold oper1. destruct in_dec. { apply kill_reg_sound; auto. } - apply oper1_sound; auto. + apply oper2_sound; auto. Qed. -Lemma gen_oper_sound : - forall rel : RELATION.t, - forall op : operation, - forall dst : reg, - forall args: list reg, - forall rs : regset, - forall v, - sem_rel rel rs -> - eval_operation genv sp op (rs ## args) m = Some v -> - sem_rel (gen_oper op dst args rel) (rs # dst <- v). -Proof. - intros until v. - intros REL EVAL. - unfold gen_oper. - destruct op. - { destruct args as [ | h0 t0]. - apply oper_sound; auto. - destruct t0. - { - simpl in *. - replace v with (rs # h0) by congruence. - apply move_sound; auto. - } - apply oper_sound; auto. - } - all: apply oper_sound; auto. -Qed. Lemma find_op_sound : @@ -399,6 +372,59 @@ Proof. apply REC; auto. Qed. +Lemma oper_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (oper op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL EVAL. + unfold oper. + destruct find_op eqn:FIND. + { + assert (eval_operation genv sp op rs ## args m = Some rs # r). + { + apply (find_op_sound rel); trivial. + } + replace v with (rs # r) by congruence. + apply move_sound; auto. + } + apply oper1_sound; trivial. +Qed. + +Lemma gen_oper_sound : + forall rel : RELATION.t, + forall op : operation, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall v, + sem_rel rel rs -> + eval_operation genv sp op (rs ## args) m = Some v -> + sem_rel (gen_oper op dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL EVAL. + unfold gen_oper. + destruct op. + { destruct args as [ | h0 t0]. + apply oper_sound; auto. + destruct t0. + { + simpl in *. + replace v with (rs # h0) by congruence. + apply move_sound; auto. + } + apply oper_sound; auto. + } + all: apply oper_sound; auto. +Qed. Lemma kill_reg_weaken: forall res mpc rs, @@ -645,8 +671,13 @@ Proof. { eapply exec_Iop with (v := v); eauto. simpl. - rewrite find_op_sound with (rel := mpc) (src := r) in H0 by assumption. - assumption. + rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0. + { + rewrite MAP in H0. + rewrite find_op_sound with (rel := mpc) (src := r) in H0 by assumption. + assumption. + } + unfold fmap_sem. rewrite MAP. rewrite MPC. assumption. } constructor; eauto. unfold fmap_sem', fmap_sem in *. -- cgit From 3e15c72f5a5e34ac2e96e77022b2129125abcdd0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 15:24:11 +0100 Subject: much better - seems to eliminate CSE not containing loads --- backend/CSE2.v | 2 +- backend/CSE2proof.v | 18 +++++++++++++++++- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 07bde1ac..14c6e042 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -304,7 +304,7 @@ Definition oper1 (op: operation) (dst : reg) (args : list reg) Definition oper (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := - match find_op rel op args with + match find_op rel op (List.map (forward_move rel) args) with | Some r => move r dst rel | None => oper1 op dst args rel end. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 47b60902..049423b0 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -372,6 +372,21 @@ Proof. apply REC; auto. Qed. +Lemma forward_move_map: + forall rel args rs, + sem_rel rel rs -> + rs ## (map (forward_move rel) args) = rs ## args. +Proof. + induction args; simpl; trivial. + intros rs REL. + f_equal. + 2: (apply IHargs; assumption). + unfold forward_move, sem_rel, sem_reg, sem_sym_val in *. + pose proof (REL a) as RELa. + destruct (rel ! a); trivial. + destruct s; congruence. +Qed. + Lemma oper_sound : forall rel : RELATION.t, forall op : operation, @@ -388,10 +403,11 @@ Proof. unfold oper. destruct find_op eqn:FIND. { - assert (eval_operation genv sp op rs ## args m = Some rs # r). + assert (eval_operation genv sp op rs ## (map (forward_move rel) args) m = Some rs # r) as FIND_OP. { apply (find_op_sound rel); trivial. } + rewrite forward_move_map in FIND_OP by assumption. replace v with (rs # r) by congruence. apply move_sound; auto. } -- cgit From 727c890d3174ec313961dd1b7e1b8726125450e9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 15:33:13 +0100 Subject: begin adding loads --- backend/CSE2.v | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 14c6e042..e07e7adc 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -6,8 +6,9 @@ Require Import Memory Registers Op RTL Maps. Inductive sym_val : Type := | SMove (src : reg) -| SOp (op : operation) (args : list reg). - +| SOp (op : operation) (args : list reg) +| SLoad (chunk : memory_chunk) (addr : addressing) (args : list reg). + Definition eq_args (x y : list reg) : { x = y } + { x <> y } := list_eq_dec peq x y. @@ -17,6 +18,8 @@ Proof. generalize eq_operation. generalize eq_args. generalize peq. + generalize eq_addressing. + generalize chunk_eq. decide equality. Defined. @@ -250,6 +253,7 @@ Definition kill_sym_val (dst : reg) (sv : sym_val) := match sv with | SMove src => if peq dst src then true else false | SOp op args => List.existsb (peq dst) args + | SLoad chunk addr args => List.existsb (peq dst) args end. Definition kill_reg (dst : reg) (rel : RELATION.t) := @@ -260,6 +264,7 @@ Definition kill_sym_val_mem (sv: sym_val) := match sv with | SMove _ => false | SOp op _ => op_depends_on_memory op + | SLoad _ _ _ => true end. Definition kill_mem (rel : RELATION.t) := -- cgit From 4414da3d406685a05ae20ba8994c1a9247137874 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 15:58:25 +0100 Subject: find_load_sound --- backend/CSE2proof.v | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 92 insertions(+), 4 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 049423b0..796f3054 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -42,6 +42,11 @@ Definition sem_sym_val sym rs := | SMove src => Some (rs # src) | SOp op args => eval_operation genv sp op (rs ## args) m + | SLoad chunk addr args => + match eval_addressing genv sp addr rs##args with + | Some a => Mem.loadv chunk m a + | None => None + end end. Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := @@ -142,6 +147,11 @@ Proof. rewrite args_unaffected by exact EXISTS. assumption. } + { destruct existsb eqn:EXISTS; simpl. + { reflexivity. } + rewrite args_unaffected by exact EXISTS. + assumption. + } Qed. Lemma write_same: @@ -303,8 +313,6 @@ Proof. apply oper2_sound; auto. Qed. - - Lemma find_op_sound : forall rel : RELATION.t, forall op : operation, @@ -351,8 +359,7 @@ Proof. unfold find_op_fold. destruct start. assumption. - destruct sv. - { trivial. } + destruct sv; trivial. destruct eq_operation; trivial. subst op0. destruct eq_args; trivial. @@ -372,6 +379,87 @@ Proof. apply REC; auto. Qed. +Lemma find_load_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall src : reg, + forall args: list reg, + forall rs : regset, + sem_rel rel rs -> + find_load rel chunk addr args = Some src -> + match eval_addressing genv sp addr rs##args with + | Some a => (Mem.loadv chunk m a) = Some (rs # src) + | None => True + end. +Proof. + intros until rs. + unfold find_load. + rewrite PTree.fold_spec. + intro REL. + assert ( + forall start, + match start with + | None => True + | Some src => + match eval_addressing genv sp addr rs##args with + | Some a => (Mem.loadv chunk m a) = Some (rs # src) + | None => True + end + end -> + fold_left + (fun (a : option reg) (p : positive * sym_val) => + find_load_fold chunk addr args a (fst p) (snd p)) (PTree.elements rel) start = + Some src -> + match eval_addressing genv sp addr rs##args with + | Some a => (Mem.loadv chunk m a) = Some (rs # src) + | None => True + end ) as REC. + + { + unfold sem_rel, sem_reg in REL. + generalize (PTree.elements_complete rel). + generalize (PTree.elements rel). + induction l; simpl. + { + intros. + subst start. + assumption. + } + destruct a as [r sv]; simpl. + intros COMPLETE start GEN. + apply IHl. + { + intros. + apply COMPLETE. + right. + assumption. + } + unfold find_load_fold. + destruct start. + assumption. + destruct sv; trivial. + destruct chunk_eq; trivial. + subst chunk0. + destruct eq_addressing; trivial. + subst addr0. + destruct eq_args; trivial. + subst args0. + simpl. + assert ((rel ! r) = Some (SLoad chunk addr args)) as RELatr. + { + apply COMPLETE. + left. + reflexivity. + } + pose proof (REL r) as RELr. + rewrite RELatr in RELr. + simpl in RELr. + destruct eval_addressing; trivial. + } + apply REC; auto. +Qed. + Lemma forward_move_map: forall rel args rs, sem_rel rel rs -> -- cgit From 2bcac2e8c00493555fb0fb1acd730bab53eb7369 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 16:12:52 +0100 Subject: load_sound --- backend/CSE2proof.v | 96 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 96 insertions(+) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 796f3054..5cb85fc2 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -530,6 +530,102 @@ Proof. all: apply oper_sound; auto. Qed. + +Lemma load2_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall a, + forall v, + sem_rel rel rs -> + not (In dst args) -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.loadv chunk m a = Some v -> + sem_rel (load2 chunk addr dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL NOT_IN ADDR LOAD x. + pose proof (kill_reg_sound rel dst rs v REL x) as KILL. + unfold load2. + destruct (peq x dst). + { + subst x. + unfold sem_reg. + rewrite PTree.gss. + rewrite Regmap.gss. + simpl. + rewrite args_replace_dst by auto. + destruct eval_addressing; congruence. + } + rewrite Regmap.gso by congruence. + unfold sem_reg. + rewrite PTree.gso by congruence. + rewrite Regmap.gso in KILL by congruence. + exact KILL. +Qed. + +Lemma load1_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall a, + forall v, + sem_rel rel rs -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.loadv chunk m a = Some v -> + sem_rel (load1 chunk addr dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL ADDR LOAD. + unfold load1. + destruct in_dec. + { + apply kill_reg_sound; auto. + } + apply load2_sound with (a := a); auto. +Qed. + +Lemma load_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall a, + forall v, + sem_rel rel rs -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.loadv chunk m a = Some v -> + sem_rel (load chunk addr dst args rel) (rs # dst <- v). +Proof. + intros until v. + intros REL ADDR LOAD. + unfold load. + destruct find_load eqn:FIND. + { + assert (match eval_addressing genv sp addr rs##(map (forward_move rel) args) with + | Some a => (Mem.loadv chunk m a) = Some (rs # r) + | None => True + end) as FIND_LOAD. + { + apply (find_load_sound rel); trivial. + } + rewrite forward_move_map in FIND_LOAD by assumption. + destruct eval_addressing in *. + 2: discriminate. + replace v with (rs # r) by congruence. + apply move_sound; auto. + } + apply load1_sound with (a := a); trivial. +Qed. + Lemma kill_reg_weaken: forall res mpc rs, sem_rel mpc rs -> -- cgit From 3bdfc2288714f1c238a5b59586aa1409f4eda056 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 16:38:57 +0100 Subject: with loads too ? --- backend/CSE2.v | 54 +++++++++++++++++++++++++++++++++++++-- backend/CSE2proof.v | 73 ++++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 119 insertions(+), 8 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index e07e7adc..f1ed877a 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -296,6 +296,24 @@ Definition find_op_fold op args (already : option reg) x sv := Definition find_op (rel : RELATION.t) (op : operation) (args : list reg) := PTree.fold (find_op_fold op args) rel None. +Definition find_load_fold chunk addr args (already : option reg) x sv := + match already with + | Some found => already + | None => + match sv with + | (SLoad chunk' addr' args') => + if (chunk_eq chunk chunk') && + (eq_addressing addr addr') && + (eq_args args args') + then Some x + else None + | _ => None + end + end. + +Definition find_load (rel : RELATION.t) (chunk : memory_chunk) (addr : addressing) (args : list reg) := + PTree.fold (find_load_fold chunk addr args) rel None. + Definition oper2 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := let rel' := kill_reg dst rel in @@ -321,6 +339,24 @@ Definition gen_oper (op: operation) (dst : reg) (args : list reg) | _, _ => oper op dst args rel end. +Definition load2 (chunk: memory_chunk) (addr : addressing) + (dst : reg) (args : list reg) (rel : RELATION.t) := + let rel' := kill_reg dst rel in + PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) rel'. + +Definition load1 (chunk: memory_chunk) (addr : addressing) + (dst : reg) (args : list reg) (rel : RELATION.t) := + if List.in_dec peq dst args + then kill_reg dst rel + else load2 chunk addr dst args rel. + +Definition load (chunk: memory_chunk) (addr : addressing) + (dst : reg) (args : list reg) (rel : RELATION.t) := + match find_load rel chunk addr (List.map (forward_move rel) args) with + | Some r => move r dst rel + | 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 @@ -355,7 +391,7 @@ Definition apply_instr instr (rel : RELATION.t) : RB.t := | Ijumptable _ _ => Some rel | Istore _ _ _ _ _ => Some (kill_mem rel) | Iop op args dst _ => Some (gen_oper op dst args rel) - | Iload _ _ _ dst _ => Some (kill_reg dst rel) + | Iload 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) *) | Itailcall _ _ _ | Ireturn _ => RB.bot @@ -400,6 +436,16 @@ Definition find_op_in_fmap fmap pc op args := 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 => find_load rel chunk addr args + | None => None + end + end. + Definition transf_instr (fmap : option (PMap.t RB.t)) (pc: node) (instr: instruction) := match instr with @@ -410,7 +456,11 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) | Some src => Iop Omove (src::nil) dst s end | Iload chunk addr args dst s => - Iload chunk addr (subst_args fmap pc args) dst s + let args' := subst_args fmap pc args in + match find_load_in_fmap fmap pc chunk addr args' with + | None => Iload 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 => diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 5cb85fc2..fe2ade4b 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -460,6 +460,24 @@ Proof. apply REC; auto. Qed. +Lemma find_load_sound' : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall src : reg, + forall args: list reg, + forall rs : regset, + forall a, + sem_rel rel rs -> + find_load rel chunk addr args = Some src -> + eval_addressing genv sp addr rs##args = Some a -> + (Mem.loadv chunk m a) = Some (rs # src). +Proof. + intros until a. intros REL LOAD ADDR. + pose proof (find_load_sound rel chunk addr src args rs REL LOAD) as Z. + destruct eval_addressing in *; congruence. +Qed. + Lemma forward_move_map: forall rel args rs, sem_rel rel rs -> @@ -933,7 +951,49 @@ Proof. } (* load *) -- econstructor; split. +- unfold transf_instr in *. + destruct find_load_in_fmap eqn:FIND_LOAD. + { + unfold find_load_in_fmap, fmap_sem', fmap_sem in *. + destruct (forward_map f) as [map |] eqn:MAP. + 2: discriminate. + change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *. + destruct (map # pc) as [mpc | ] eqn:MPC. + 2: discriminate. + econstructor; split. + { + eapply exec_Iop with (v := v); eauto. + simpl. + rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0. + { + rewrite find_load_sound' with (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs) in H1; trivial. + rewrite MAP in H0. + assumption. + } + unfold fmap_sem. rewrite MAP. rewrite MPC. assumption. + } + constructor; eauto. + unfold fmap_sem', fmap_sem in *. + rewrite MAP. + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). + { + replace (Some (load chunk addr dst args 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + simpl. + reflexivity. + } + unfold sem_rel_b', sem_rel_b. + apply load_sound with (a := a); auto. + } + { + econstructor; split. assert (eval_addressing tge sp addr rs ## args = Some a). rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. @@ -945,9 +1005,9 @@ Proof. unfold fmap_sem', fmap_sem in *. 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_reg dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). { - replace (Some (kill_reg dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (load chunk addr dst args 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. @@ -956,11 +1016,12 @@ Proof. unfold apply_instr'. rewrite H. rewrite MPC. + simpl. reflexivity. } - apply kill_reg_sound. - assumption. - + apply load_sound with (a := a); assumption. + } + (* NOT IN THIS VERSION - (* load notrap1 *) econstructor; split. -- cgit From 1f994be34eac3ca0d938c213c58a36b3a57bad8c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 28 Jan 2020 19:08:42 +0100 Subject: forgot a "in *" --- driver/Compiler.v | 21 +-------------------- 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/driver/Compiler.v b/driver/Compiler.v index 33e31057..0dd413f5 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -289,26 +289,7 @@ Proof. set (p10 := total_if optim_constprop Constprop.transf_program p9) in *. set (p11 := total_if optim_constprop Renumber.transf_program p10) in *. destruct (partial_if optim_CSE CSE.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate. - set (p12bis := @total_if RTL.program optim_CSE2 CSE2.transf_program p12). - change (@eq (res Asm.program) - (apply_partial Mach.program Asm.program - (apply_partial Linear.program Mach.program - (apply_partial Linear.program Linear.program - (apply_total Linear.program Linear.program - (apply_partial LTL.program Linear.program - (apply_total LTL.program LTL.program - (apply_partial RTL.program LTL.program - (apply_partial RTL.program RTL.program - (@partial_if RTL.program optim_redundancy - Deadcode.transf_program - p12bis) - Unusedglob.transform_program) - Allocation.transf_program) - Tunneling.tunnel_program) Linearize.transf_program) - CleanupLabels.transf_program) - (@partial_if Linear.program debug Debugvar.transf_program)) - Stacking.transf_program) Asmgen.transf_program) - (@OK Asm.program tp)) in T. + set (p12bis := @total_if RTL.program optim_CSE2 CSE2.transf_program p12) in *. destruct (partial_if optim_redundancy Deadcode.transf_program p12bis) as [p13|e] eqn:P13; simpl in T; try discriminate. destruct (Unusedglob.transform_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. destruct (Allocation.transf_program p14) as [p15|e] eqn:P15; simpl in T; try discriminate. -- cgit From 39278439ad26cb5eb22b496066c0f044c33ef28b Mon Sep 17 00:00:00 2001 From: "xavier.leroy" Date: Sat, 25 Jan 2020 18:59:33 -0600 Subject: Reduce the checking time for the "decidable_equality_from" tactic Just moved a frequent failure case ahead of a costly "simpl". --- lib/BoolEqual.v | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/BoolEqual.v b/lib/BoolEqual.v index c9e7bad5..e8c1d831 100644 --- a/lib/BoolEqual.v +++ b/lib/BoolEqual.v @@ -106,8 +106,8 @@ Ltac bool_eq_refl_case := end. Ltac bool_eq_refl := - let H := fresh "Hrec" in let x := fresh "x" in - fix H 1; intros x; destruct x; simpl; bool_eq_refl_case. + let Hrec := fresh "Hrec" in let x := fresh "x" in + fix Hrec 1; intros x; destruct x; simpl; bool_eq_refl_case. Lemma false_not_true: forall (P: Prop), false = true -> P. @@ -124,7 +124,6 @@ Qed. Ltac bool_eq_sound_case := match goal with - | [ H: false = true |- _ ] => exact (false_not_true _ H) | [ H: _ && _ = true |- _ ] => apply andb_prop in H; destruct H; bool_eq_sound_case | [ H: proj_sumbool ?a = true |- _ ] => apply proj_sumbool_true in H; bool_eq_sound_case | [ |- ?C ?x1 ?x2 ?x3 ?x4 = ?C ?y1 ?y2 ?y3 ?y4 ] => apply f_equal4; auto @@ -137,7 +136,9 @@ Ltac bool_eq_sound_case := Ltac bool_eq_sound := let Hrec := fresh "Hrec" in let x := fresh "x" in let y := fresh "y" in - fix Hrec 1; intros x y; destruct x, y; simpl; intro; bool_eq_sound_case. + let H := fresh "EQ" in + fix Hrec 1; intros x y; destruct x, y; intro H; + try (apply (false_not_true _ H)); simpl in H; bool_eq_sound_case. Lemma dec_eq_from_bool_eq: forall (A: Type) (f: A -> A -> bool) -- cgit From 326bdc281c60ac826129b0a0fda33dc17d8498fa Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 31 Jan 2020 16:55:32 +0100 Subject: Adding threshold to duplicate instructions --- backend/Duplicateaux.ml | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index a553a370..2dd07b76 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -498,6 +498,7 @@ let tail_duplicate code preds ptree trace = (* last_node and last_duplicate store resp. the last processed node of the trace, and its duplication *) in let last_node = ref None in let last_duplicate = ref None + in let nb_duplicated = ref 0 (* recursive function on a trace *) in let rec f code ptree is_first = function | [] -> (code, ptree) @@ -515,6 +516,7 @@ let tail_duplicate code preds ptree trace = in let (newc, newp) = duplicate code ptree !last_node n final_node_preds (P.of_int n') in begin next_int := !next_int + 1; + nb_duplicated := !nb_duplicated + 1; last_duplicate := Some (P.of_int n'); (newc, newp) end @@ -523,16 +525,20 @@ let tail_duplicate code preds ptree trace = last_node := Some n; f new_code new_ptree false t end - in f code ptree true trace + in let new_code, new_ptree = f code ptree true trace + in (new_code, new_ptree, !nb_duplicated) let superblockify_traces code preds traces = - let ptree = make_identity_ptree code + let max_nb_duplicated = 2 (* FIXME - should be architecture dependent *) + in let ptree = make_identity_ptree code in let rec f code ptree = function - | [] -> (code, ptree) + | [] -> (code, ptree, 0) | trace :: traces -> - let new_code, new_ptree = tail_duplicate code preds ptree trace - in f new_code new_ptree traces - in f code ptree 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 let new_code, new_ptree, _ = f code ptree traces + in (new_code, new_ptree) let rec invert_iconds_trace code = function | [] -> code -- cgit From 7dca7590aa212806ee939244b253a6a067f34bfc Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 3 Feb 2020 10:52:53 +0100 Subject: Added flag to desactivate condition inversion --- backend/Duplicateaux.ml | 3 ++- driver/Clflags.ml | 1 + driver/Driver.ml | 3 +++ 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 2dd07b76..84daa329 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -557,7 +557,8 @@ let rec invert_iconds_trace code = function let rec invert_iconds code = function | [] -> code | t :: ts -> - let code' = invert_iconds_trace code t + let code' = if !Clflags.option_finvertcond then invert_iconds_trace code t + else code in invert_iconds code' ts (* For now, identity function *) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 088845fe..a195e38b 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -28,6 +28,7 @@ let option_fconstprop = ref true let option_fcse = 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 *) let option_fpostpass = ref true let option_fpostpass_sched = ref "list" let option_fifconversion = ref true diff --git a/driver/Driver.ml b/driver/Driver.ml index 129248dc..3af1a937 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -200,6 +200,8 @@ Processing options: -fpostpass= Perform postpass scheduling with the specified optimization [list] (=list: list scheduling, =ilp: ILP, =greedy: just packing bundles) -fduplicate Perform tail duplication to form superblocks on predicted traces + -finvertcond Invert conditions based on predicted paths (to prefer fallthrough). + Requires -fduplicate to be also activated [on] -fforward-moves Forward moves after CSE -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their @@ -386,6 +388,7 @@ let cmdline_actions = @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass @ f_opt "duplicate" option_fduplicate + @ f_opt "invertcond" option_finvertcond @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched @ f_opt "inline" option_finline @ f_opt "inline-functions-called-once" option_finline_functions_called_once -- cgit From 1dd98d18c57abdbc8dc50bbef729e8a898d55aad Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 3 Feb 2020 17:11:35 +0100 Subject: comments --- backend/CSE2.v | 6 ++++++ backend/CSE2proof.v | 8 ++++++++ 2 files changed, 14 insertions(+) diff --git a/backend/CSE2.v b/backend/CSE2.v index f1ed877a..b7665097 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -1,3 +1,9 @@ +(* +Replace available expressions by the register containing their value. + +David Monniaux, CNRS, VERIMAG + *) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index fe2ade4b..73feccf0 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1,3 +1,11 @@ +(* +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. -- cgit From aa042a1654698d7bfd1e3cd8cf7abacd528e7133 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 3 Feb 2020 17:45:02 +0100 Subject: Using k1-elf-as instead of k1-cos-gcc for assembling --- configure | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure b/configure index b8555973..716e5e81 100755 --- a/configure +++ b/configure @@ -457,8 +457,8 @@ if test "$arch" = "mppa_k1c"; then fi osupper=`echo $os|tr a-z A-Z` k1base="k1-$os" - casm="$k1base-gcc" - casm_options="$model_options -c" + casm="k1-elf-as" + casm_options="$model_options" cc="$k1base-gcc $model_options" clinker="$k1base-gcc" bindir="$HOME/.usr/bin" -- cgit From 65281dfbf2ce12f4fca5c1bfa57a14a429687ca7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 3 Feb 2020 19:14:25 +0100 Subject: another version of proof that allows Vundef in loaded values --- backend/CSE2proof.v | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 73feccf0..82fa8a28 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -45,26 +45,26 @@ Section SOUNDNESS. Section SAME_MEMORY. Variable m : mem. -Definition sem_sym_val sym rs := +Definition sem_sym_val sym rs (v : option val) : Prop := match sym with - | SMove src => Some (rs # src) + | SMove src => v = Some (rs # src) | SOp op args => - eval_operation genv sp op (rs ## args) m + v = (eval_operation genv sp op (rs ## args) m) | SLoad chunk addr args => match eval_addressing genv sp addr rs##args with - | Some a => Mem.loadv chunk m a - | None => None + | Some a => v = (Mem.loadv chunk m a) + | None => v = None \/ v = Some Vundef end end. -Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) : option val := +Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) (v : val) : Prop := match rel ! x with - | None => Some (rs # x) - | Some sym => sem_sym_val sym rs + | None => True + | Some sym => sem_sym_val sym rs (Some (rs # x)) end. Definition sem_rel (rel : RELATION.t) (rs : regset) := - forall x : reg, (sem_reg rel x rs) = Some (rs # x). + forall x : reg, (sem_reg rel x rs (rs # x)). Definition sem_rel_b (relb : RB.t) (rs : regset) := match relb with @@ -133,13 +133,11 @@ Proof. { subst x. rewrite PTree.grs. - rewrite Regmap.gss. - reflexivity. + trivial. } rewrite PTree.gro by congruence. rewrite Regmap.gso by congruence. - destruct (rel ! x) as [relx | ] eqn:RELx. - 2: reflexivity. + destruct (rel ! x) as [relx | ] eqn:RELx; trivial. unfold kill_sym_val. pose proof (REL x) as RELinstx. rewrite RELx in RELinstx. @@ -194,11 +192,11 @@ Proof. unfold sem_reg. rewrite PTree.gss. rewrite Regmap.gss. - unfold sem_reg in RELsrc. + unfold sem_reg in *. simpl. unfold forward_move. destruct (rel ! src) as [ sv |]; simpl. - destruct sv; simpl in *. + destruct sv eqn:SV; simpl in *. { destruct (peq dst src0). { @@ -209,7 +207,7 @@ Proof. rewrite Regmap.gso by congruence. assumption. } - all: f_equal; apply write_same. + all: f_equal; symmetry; apply write_same. } rewrite Regmap.gso by congruence. unfold sem_reg. @@ -291,6 +289,7 @@ Proof. rewrite Regmap.gss. simpl. rewrite args_replace_dst by auto. + symmetry. assumption. } rewrite Regmap.gso by congruence. @@ -382,6 +381,7 @@ Proof. pose proof (REL r) as RELr. rewrite RELatr in RELr. simpl in RELr. + symmetry. assumption. } apply REC; auto. @@ -463,7 +463,7 @@ Proof. pose proof (REL r) as RELr. rewrite RELatr in RELr. simpl in RELr. - destruct eval_addressing; trivial. + destruct eval_addressing; congruence. } apply REC; auto. Qed. @@ -715,7 +715,7 @@ Proof. destruct sv; simpl in *; trivial. { destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial. - rewrite <- SEMx. + rewrite SEMx. apply op_depends_on_memory_correct; auto. } Qed. -- cgit From 3633136560b72c6311c77dc2698e7b7b18a887bb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 3 Feb 2020 20:44:35 +0100 Subject: NOTRAP in CSE2: progress --- backend/CSE2.v | 3 +- backend/CSE2proof.v | 290 ++++++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 260 insertions(+), 33 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 1b3d415d..a001d073 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -397,8 +397,7 @@ Definition apply_instr instr (rel : RELATION.t) : RB.t := | Ijumptable _ _ => Some rel | Istore _ _ _ _ _ => Some (kill_mem rel) | Iop op args dst _ => Some (gen_oper op dst args rel) - | Iload TRAP chunk addr args dst _ => Some (load chunk addr dst args rel) - | Iload NOTRAP chunk addr args dst _ => Some (kill_reg dst 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) *) | Itailcall _ _ _ | Ireturn _ => RB.bot diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 3ecc0e35..3b28cf84 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -52,8 +52,11 @@ Definition sem_sym_val sym rs (v : option val) : Prop := v = (eval_operation genv sp op (rs ## args) m) | SLoad chunk addr args => match eval_addressing genv sp addr rs##args with - | Some a => v = (Mem.loadv chunk m a) - | None => v = None \/ v = Some Vundef + | Some a => match Mem.loadv chunk m a with + | Some dat => v = Some dat + | None => v = None \/ v = Some (default_notrap_load_value chunk) + end + | None => v = None \/ v = Some (default_notrap_load_value chunk) end end. @@ -397,8 +400,11 @@ Lemma find_load_sound : sem_rel rel rs -> find_load rel chunk addr args = Some src -> match eval_addressing genv sp addr rs##args with - | Some a => (Mem.loadv chunk m a) = Some (rs # src) - | None => True + | Some a => match Mem.loadv chunk m a with + | Some dat => rs#src = dat + | None => rs#src = default_notrap_load_value chunk + end + | None => rs#src = default_notrap_load_value chunk end. Proof. intros until rs. @@ -411,18 +417,24 @@ Proof. | None => True | Some src => match eval_addressing genv sp addr rs##args with - | Some a => (Mem.loadv chunk m a) = Some (rs # src) - | None => True - end + | Some a => match Mem.loadv chunk m a with + | Some dat => rs#src = dat + | None => rs#src = default_notrap_load_value chunk + end + | None => rs#src = default_notrap_load_value chunk + end end -> fold_left (fun (a : option reg) (p : positive * sym_val) => find_load_fold chunk addr args a (fst p) (snd p)) (PTree.elements rel) start = Some src -> match eval_addressing genv sp addr rs##args with - | Some a => (Mem.loadv chunk m a) = Some (rs # src) - | None => True - end ) as REC. + | Some a => match Mem.loadv chunk m a with + | Some dat => rs#src = dat + | None => rs#src = default_notrap_load_value chunk + end + | None => rs#src = default_notrap_load_value chunk + end) as REC. { unfold sem_rel, sem_reg in REL. @@ -463,11 +475,18 @@ Proof. pose proof (REL r) as RELr. rewrite RELatr in RELr. simpl in RELr. - destruct eval_addressing; congruence. + Show. + destruct eval_addressing. + { destruct Mem.loadv. + congruence. + destruct RELr; congruence. + } + destruct RELr; congruence. } apply REC; auto. Qed. + Lemma find_load_sound' : forall rel : RELATION.t, forall chunk : memory_chunk, @@ -476,14 +495,21 @@ Lemma find_load_sound' : forall args: list reg, forall rs : regset, forall a, + forall v, sem_rel rel rs -> find_load rel chunk addr args = Some src -> eval_addressing genv sp addr rs##args = Some a -> - (Mem.loadv chunk m a) = Some (rs # src). + Mem.loadv chunk m a = Some v -> + v = rs # src. Proof. - intros until a. intros REL LOAD ADDR. - pose proof (find_load_sound rel chunk addr src args rs REL LOAD) as Z. - destruct eval_addressing in *; congruence. + intros until v. intros REL FINDLOAD ADDR LOAD. + pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z. + destruct eval_addressing in *. + { + replace a with v0 in * by congruence. + destruct Mem.loadv in * ; congruence. + } + discriminate. Qed. Lemma forward_move_map: @@ -584,7 +610,84 @@ Proof. rewrite Regmap.gss. simpl. rewrite args_replace_dst by auto. - destruct eval_addressing; congruence. + destruct eval_addressing. + { + replace a with v0 in * by congruence. + destruct Mem.loadv; congruence. + } + discriminate. + } + rewrite Regmap.gso by congruence. + unfold sem_reg. + rewrite PTree.gso by congruence. + rewrite Regmap.gso in KILL by congruence. + exact KILL. +Qed. + +Lemma load2_notrap1_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + sem_rel rel rs -> + not (In dst args) -> + eval_addressing genv sp addr (rs ## args) = None -> + sem_rel (load2 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). +Proof. + intros until rs. + intros REL NOT_IN ADDR x. + pose proof (kill_reg_sound rel dst rs (default_notrap_load_value chunk) REL x) as KILL. + unfold load2. + destruct (peq x dst). + { + subst x. + unfold sem_reg. + rewrite PTree.gss. + rewrite Regmap.gss. + simpl. + rewrite args_replace_dst by auto. + rewrite ADDR. + right. + trivial. + } + rewrite Regmap.gso by congruence. + unfold sem_reg. + rewrite PTree.gso by congruence. + rewrite Regmap.gso in KILL by congruence. + exact KILL. +Qed. + +Lemma load2_notrap2_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall a, + sem_rel rel rs -> + not (In dst args) -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.loadv chunk m a = None -> + sem_rel (load2 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). +Proof. + intros until a. + intros REL NOT_IN ADDR LOAD x. + pose proof (kill_reg_sound rel dst rs (default_notrap_load_value chunk) REL x) as KILL. + unfold load2. + destruct (peq x dst). + { + subst x. + unfold sem_reg. + rewrite PTree.gss. + rewrite Regmap.gss. + simpl. + rewrite args_replace_dst by auto. + rewrite ADDR. + rewrite LOAD. + right; trivial. } rewrite Regmap.gso by congruence. unfold sem_reg. @@ -617,6 +720,50 @@ Proof. apply load2_sound with (a := a); auto. Qed. +Lemma load1_notrap1_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + sem_rel rel rs -> + eval_addressing genv sp addr (rs ## args) = None -> + sem_rel (load1 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). +Proof. + intros until rs. + intros REL ADDR LOAD. + unfold load1. + destruct in_dec. + { + apply kill_reg_sound; auto. + } + apply load2_notrap1_sound; auto. +Qed. + +Lemma load1_notrap2_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall a, + sem_rel rel rs -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.loadv chunk m a = None -> + sem_rel (load1 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). +Proof. + intros until a. + intros REL ADDR LOAD. + unfold load1. + destruct in_dec. + { + apply kill_reg_sound; auto. + } + apply load2_notrap2_sound with (a := a); auto. +Qed. + Lemma load_sound : forall rel : RELATION.t, forall chunk : memory_chunk, @@ -634,11 +781,14 @@ Proof. intros until v. intros REL ADDR LOAD. unfold load. - destruct find_load eqn:FIND. + destruct find_load as [src | ] eqn:FIND. { - assert (match eval_addressing genv sp addr rs##(map (forward_move rel) args) with - | Some a => (Mem.loadv chunk m a) = Some (rs # r) - | None => True + assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with + | Some a => match Mem.loadv chunk m a with + | Some dat => rs#src = dat + | None => rs#src = default_notrap_load_value chunk + end + | None => rs#src = default_notrap_load_value chunk end) as FIND_LOAD. { apply (find_load_sound rel); trivial. @@ -646,12 +796,88 @@ Proof. rewrite forward_move_map in FIND_LOAD by assumption. destruct eval_addressing in *. 2: discriminate. - replace v with (rs # r) by congruence. + replace v0 with a in * by congruence. + destruct Mem.loadv in *. + 2: discriminate. + replace v with (rs # src) by congruence. apply move_sound; auto. } apply load1_sound with (a := a); trivial. Qed. +Lemma load_notrap1_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + sem_rel rel rs -> + eval_addressing genv sp addr (rs ## args) = None -> + sem_rel (load chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). +Proof. + intros until rs. + intros REL ADDR. + unfold load. + destruct find_load as [src | ] eqn:FIND. + { + assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with + | Some a => match Mem.loadv chunk m a with + | Some dat => rs#src = dat + | None => rs#src = default_notrap_load_value chunk + end + | None => rs#src = default_notrap_load_value chunk + end) as FIND_LOAD. + { + apply (find_load_sound rel); trivial. + } + rewrite forward_move_map in FIND_LOAD by assumption. + destruct eval_addressing in *. + discriminate. + rewrite <- FIND_LOAD. + apply move_sound; auto. + } + apply load1_notrap1_sound; trivial. +Qed. + +Lemma load_notrap2_sound : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall dst : reg, + forall args: list reg, + forall rs : regset, + forall a, + sem_rel rel rs -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.loadv chunk m a = None -> + sem_rel (load chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). +Proof. + intros until a. + intros REL ADDR. + unfold load. + destruct find_load as [src | ] eqn:FIND. + { + assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with + | Some a => match Mem.loadv chunk m a with + | Some dat => rs#src = dat + | None => rs#src = default_notrap_load_value chunk + end + | None => rs#src = default_notrap_load_value chunk + end) as FIND_LOAD. + { + apply (find_load_sound rel); trivial. + } + rewrite forward_move_map in FIND_LOAD by assumption. + rewrite ADDR in FIND_LOAD. + destruct Mem.loadv; intro. + discriminate. + rewrite <- FIND_LOAD. + apply move_sound; auto. + } + apply load1_notrap2_sound; trivial. +Qed. + Lemma kill_reg_weaken: forall res mpc rs, sem_rel mpc rs -> @@ -976,7 +1202,9 @@ Proof. simpl. rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0. { - rewrite find_load_sound' with (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs) in H1; trivial. + f_equal. + symmetry. + apply find_load_sound' with (chunk := chunk) (m := m) (a := a) (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs); trivial. rewrite MAP in H0. assumption. } @@ -1046,9 +1274,9 @@ Proof. unfold fmap_sem', fmap_sem in *. 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_reg dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). { - replace (Some (kill_reg dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (load chunk addr dst args 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. @@ -1060,7 +1288,7 @@ Proof. simpl. reflexivity. } - apply kill_reg_sound; assumption. + apply load_sound with (a := a); assumption. } - (* load notrap1 *) @@ -1075,9 +1303,9 @@ Proof. unfold fmap_sem', fmap_sem in *. 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_reg dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). { - replace (Some (kill_reg dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (load chunk addr dst args 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. @@ -1089,7 +1317,7 @@ Proof. simpl. reflexivity. } - apply kill_reg_sound; assumption. + apply load_notrap1_sound; trivial. - (* load notrap2 *) econstructor; split. @@ -1103,9 +1331,9 @@ Proof. unfold fmap_sem', fmap_sem in *. 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_reg dst mpc)). + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). { - replace (Some (kill_reg dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (load chunk addr dst args 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. @@ -1117,7 +1345,7 @@ Proof. simpl. reflexivity. } - apply kill_reg_sound; assumption. + apply load_notrap2_sound with (a := a); assumption. - (* store *) econstructor. split. -- cgit From 1cd3c4c9b7372ca8de128a9ce60ed00210fd0e28 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 3 Feb 2020 21:35:34 +0100 Subject: CSE2 with NOTRAP --- backend/CSE2.v | 6 +- backend/CSE2proof.v | 275 +++++++++++++++++++++++++++++++++++----------------- 2 files changed, 186 insertions(+), 95 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index a001d073..38a46c1b 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -461,14 +461,12 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) | None => Iop op args' dst s | Some src => Iop Omove (src::nil) dst s end - | Iload TRAP chunk addr args dst s => + | 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 + | None => Iload trap chunk addr args' dst s | Some src => Iop Omove (src::nil) dst s end - | Iload NOTRAP chunk addr args dst s => - Iload NOTRAP chunk addr (subst_args fmap pc args) dst s | Istore chunk addr args src s => Istore chunk addr (subst_args fmap pc args) src s | Icall sig ros args dst s => diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 3b28cf84..254cc4ce 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -475,7 +475,6 @@ Proof. pose proof (REL r) as RELr. rewrite RELatr in RELr. simpl in RELr. - Show. destruct eval_addressing. { destruct Mem.loadv. congruence. @@ -512,6 +511,46 @@ Proof. discriminate. Qed. +Lemma find_load_notrap1_sound' : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall src : reg, + forall args: list reg, + forall rs : regset, + sem_rel rel rs -> + find_load rel chunk addr args = Some src -> + eval_addressing genv sp addr rs##args = None -> + rs # src = (default_notrap_load_value chunk). +Proof. + intros until rs. intros REL FINDLOAD ADDR. + pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z. + rewrite ADDR in Z. + assumption. +Qed. + +Lemma find_load_notrap2_sound' : + forall rel : RELATION.t, + forall chunk : memory_chunk, + forall addr : addressing, + forall src : reg, + forall args: list reg, + forall rs : regset, + forall a, + sem_rel rel rs -> + find_load rel chunk addr args = Some src -> + eval_addressing genv sp addr rs##args = Some a -> + Mem.loadv chunk m a = None -> + rs # src = (default_notrap_load_value chunk). +Proof. + intros until a. intros REL FINDLOAD ADDR LOAD. + pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z. + rewrite ADDR in Z. + destruct Mem.loadv. + discriminate. + assumption. +Qed. + Lemma forward_move_map: forall rel args rs, sem_rel rel rs -> @@ -1186,82 +1225,49 @@ Proof. (* load *) - unfold transf_instr in *. - destruct trap. - { (* TRAP *) - destruct find_load_in_fmap eqn:FIND_LOAD. + destruct find_load_in_fmap eqn:FIND_LOAD. + { + unfold find_load_in_fmap, fmap_sem', fmap_sem in *. + destruct (forward_map f) as [map |] eqn:MAP. + 2: discriminate. + change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *. + destruct (map # pc) as [mpc | ] eqn:MPC. + 2: discriminate. + econstructor; split. { - unfold find_load_in_fmap, fmap_sem', fmap_sem in *. - destruct (forward_map f) as [map |] eqn:MAP. - 2: discriminate. - change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *. - destruct (map # pc) as [mpc | ] eqn:MPC. - 2: discriminate. - econstructor; split. - { - eapply exec_Iop with (v := v); eauto. - simpl. - rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0. - { - f_equal. - symmetry. - apply find_load_sound' with (chunk := chunk) (m := m) (a := a) (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs); trivial. - rewrite MAP in H0. - assumption. - } - unfold fmap_sem. rewrite MAP. rewrite MPC. assumption. - } - constructor; eauto. - unfold fmap_sem', fmap_sem in *. - rewrite MAP. - apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). + eapply exec_Iop with (v := v); eauto. + simpl. + rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0. { - replace (Some (load chunk addr dst args 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. - simpl. tauto. - } - unfold apply_instr'. - rewrite H. - rewrite MPC. - simpl. - reflexivity. + f_equal. + symmetry. + apply find_load_sound' with (chunk := chunk) (m := m) (a := a) (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs); trivial. + rewrite MAP in H0. + assumption. } - unfold sem_rel_b', sem_rel_b. - apply load_sound with (a := a); auto. + unfold fmap_sem. rewrite MAP. rewrite MPC. assumption. } - { - 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. - rewrite (subst_args_ok' sp m); assumption. - constructor; auto. - - simpl in *. - unfold fmap_sem', fmap_sem in *. - 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 (load chunk addr dst args mpc)). + constructor; eauto. + unfold fmap_sem', fmap_sem in *. + rewrite MAP. + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). + { + replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)). { - replace (Some (load chunk addr dst args 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. - simpl. tauto. - } - unfold apply_instr'. - rewrite H. - rewrite MPC. - simpl. - reflexivity. + eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. + 2: apply apply_instr'_bot. + simpl. tauto. } - apply load_sound with (a := a); assumption. + unfold apply_instr'. + rewrite H. + rewrite MPC. + simpl. + reflexivity. } + unfold sem_rel_b', sem_rel_b. + apply load_sound with (a := a); auto. } - - { (* NOTRAP *) + { econstructor; split. assert (eval_addressing tge sp addr rs ## args = Some a). rewrite <- H0. @@ -1291,35 +1297,121 @@ Proof. apply load_sound with (a := a); assumption. } -- (* 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. - rewrite subst_args_ok with (genv := ge) (sp := sp) (m := m); assumption. - constructor; auto. +- unfold transf_instr in *. + destruct find_load_in_fmap eqn:FIND_LOAD. + { + unfold find_load_in_fmap, fmap_sem', fmap_sem in *. + destruct (forward_map f) as [map |] eqn:MAP. + 2: discriminate. + change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *. + destruct (map # pc) as [mpc | ] eqn:MPC. + 2: discriminate. - simpl in *. - unfold fmap_sem', fmap_sem in *. - 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 (load chunk addr dst args mpc)). + econstructor; split. + { + eapply exec_Iop with (v := (default_notrap_load_value chunk)); eauto. + rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0. + { simpl. + f_equal. + apply find_load_notrap1_sound' with (chunk := chunk) (m := m) (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs); trivial. + rewrite MAP in H0. + assumption. + } + unfold fmap_sem. rewrite MAP. rewrite MPC. assumption. + } + constructor; eauto. + unfold fmap_sem', fmap_sem in *. + rewrite MAP. + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). + { + replace (Some (load chunk addr dst args 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + simpl. + reflexivity. + } + unfold sem_rel_b', sem_rel_b. + apply load_notrap1_sound; auto. + } { - replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + 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. + rewrite subst_args_ok with (genv := ge) (sp := sp) (m := m) ; assumption. + constructor; auto. + + simpl in *. + unfold fmap_sem', fmap_sem in *. + 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 (load chunk addr dst args mpc)). { - eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. - 2: apply apply_instr'_bot. - simpl. tauto. + replace (Some (load chunk addr dst args 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + simpl. + reflexivity. } - unfold apply_instr'. - rewrite H. - rewrite MPC. - simpl. - reflexivity. + apply load_notrap1_sound; trivial. } - apply load_notrap1_sound; trivial. - (* load notrap2 *) + unfold transf_instr in *. + destruct find_load_in_fmap eqn:FIND_LOAD. + { + unfold find_load_in_fmap, fmap_sem', fmap_sem in *. + destruct (forward_map f) as [map |] eqn:MAP. + 2: discriminate. + change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *. + destruct (map # pc) as [mpc | ] eqn:MPC. + 2: discriminate. + econstructor; split. + { + eapply exec_Iop with (v := (default_notrap_load_value chunk)); eauto. + simpl. + rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0. + { + f_equal. + apply find_load_notrap2_sound' with (chunk := chunk) (m := m) (a := a) (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs); trivial. + rewrite MAP in H0. + assumption. + } + unfold fmap_sem. rewrite MAP. rewrite MPC. assumption. + } + constructor; eauto. + unfold fmap_sem', fmap_sem in *. + rewrite MAP. + apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)). + { + replace (Some (load chunk addr dst args 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. + simpl. tauto. + } + unfold apply_instr'. + rewrite H. + rewrite MPC. + simpl. + reflexivity. + } + unfold sem_rel_b', sem_rel_b. + apply load_notrap2_sound with (a := a); auto. + } + { econstructor; split. assert (eval_addressing tge sp addr rs ## args = Some a). rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. @@ -1346,6 +1438,7 @@ Proof. reflexivity. } apply load_notrap2_sound with (a := a); assumption. + } - (* store *) econstructor. split. -- cgit From 3fde34d48925db4153c5c288fa37da35725502ce Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 09:14:25 +0100 Subject: stuff information into a record --- backend/CSE2.v | 59 ++++++++++++++++++++++++++++++----------------------- backend/CSE2proof.v | 50 +++++++++++++++++++++++++++------------------ 2 files changed, 63 insertions(+), 46 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index b7665097..0479dad9 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -29,13 +29,18 @@ Proof. decide equality. Defined. +Record relmap := mkrel { + var_to_sym : (PTree.t sym_val) + }. + Module RELATION. - -Definition t := (PTree.t sym_val). + +Definition t := relmap. + Definition eq (r1 r2 : t) := - forall x, (PTree.get x r1) = (PTree.get x r2). + forall x, (PTree.get x (var_to_sym r1)) = (PTree.get x (var_to_sym r2)). -Definition top : t := PTree.empty sym_val. +Definition top : t := mkrel (PTree.empty sym_val). Lemma eq_refl: forall x, eq x x. Proof. @@ -58,27 +63,27 @@ Qed. Definition sym_val_beq (x y : sym_val) := if eq_sym_val x y then true else false. -Definition beq (r1 r2 : t) := PTree.beq sym_val_beq r1 r2. +Definition beq (r1 r2 : t) := PTree.beq sym_val_beq (var_to_sym r1) (var_to_sym r2). Lemma beq_correct: forall r1 r2, beq r1 r2 = true -> eq r1 r2. Proof. unfold beq, eq. intros r1 r2 EQ x. - pose proof (PTree.beq_correct sym_val_beq r1 r2) as CORRECT. + pose proof (PTree.beq_correct sym_val_beq (var_to_sym r1) (var_to_sym r2)) as CORRECT. destruct CORRECT as [CORRECTF CORRECTB]. pose proof (CORRECTF EQ x) as EQx. clear CORRECTF CORRECTB EQ. unfold sym_val_beq in *. - destruct (r1 ! x) as [R1x | ] in *; - destruct (r2 ! x) as [R2x | ] in *; + destruct ((var_to_sym r1) ! x) as [R1x | ] in *; + destruct ((var_to_sym r2) ! x) as [R2x | ] in *; trivial; try contradiction. destruct (eq_sym_val R1x R2x) in *; congruence. Qed. Definition ge (r1 r2 : t) := forall x, - match PTree.get x r1 with + match PTree.get x (var_to_sym r1) with | None => True - | Some v => (PTree.get x r2) = Some v + | Some v => (PTree.get x (var_to_sym r2)) = Some v end. Lemma ge_refl: forall r1 r2, eq r1 r2 -> ge r1 r2. @@ -87,7 +92,7 @@ Proof. intros r1 r2 EQ x. pose proof (EQ x) as EQx. clear EQ. - destruct (r1 ! x). + destruct ((var_to_sym r1) ! x). - congruence. - trivial. Qed. @@ -98,12 +103,13 @@ Proof. intros r1 r2 r3 GE12 GE23 x. pose proof (GE12 x) as GE12x; clear GE12. pose proof (GE23 x) as GE23x; clear GE23. - destruct (r1 ! x); trivial. - destruct (r2 ! x); congruence. + destruct ((var_to_sym r1) ! x); trivial. + destruct ((var_to_sym r2) ! x); congruence. Qed. Definition lub (r1 r2 : t) := - PTree.combine + mkrel + (PTree.combine (fun ov1 ov2 => match ov1, ov2 with | (Some v1), (Some v2) => @@ -113,12 +119,12 @@ Definition lub (r1 r2 : t) := | None, _ | _, None => None end) - r1 r2. + (var_to_sym r1) (var_to_sym r2)). Lemma ge_lub_left: forall x y, ge (lub x y) x. Proof. unfold ge, lub. - intros r1 r2 x. + intros r1 r2 x. simpl. rewrite PTree.gcombine by reflexivity. destruct (_ ! _); trivial. destruct (_ ! _); trivial. @@ -128,7 +134,7 @@ Qed. Lemma ge_lub_right: forall x y, ge (lub x y) y. Proof. unfold ge, lub. - intros r1 r2 x. + intros r1 r2 x. simpl. rewrite PTree.gcombine by reflexivity. destruct (_ ! _); trivial. destruct (_ ! _); trivial. @@ -263,8 +269,8 @@ Definition kill_sym_val (dst : reg) (sv : sym_val) := end. Definition kill_reg (dst : reg) (rel : RELATION.t) := - PTree.filter1 (fun x => negb (kill_sym_val dst x)) - (PTree.remove dst rel). + mkrel (PTree.filter1 (fun x => negb (kill_sym_val dst x)) + (PTree.remove dst (var_to_sym rel))). Definition kill_sym_val_mem (sv: sym_val) := match sv with @@ -274,17 +280,18 @@ Definition kill_sym_val_mem (sv: sym_val) := end. Definition kill_mem (rel : RELATION.t) := - PTree.filter1 (fun x => negb (kill_sym_val_mem x)) rel. + mkrel + (PTree.filter1 (fun x => negb (kill_sym_val_mem x)) (var_to_sym rel)). Definition forward_move (rel : RELATION.t) (x : reg) : reg := - match rel ! x with + match (var_to_sym rel) ! x with | Some (SMove org) => org | _ => x end. Definition move (src dst : reg) (rel : RELATION.t) := - PTree.set dst (SMove (forward_move rel src)) (kill_reg dst rel). + mkrel (PTree.set dst (SMove (forward_move rel src)) (var_to_sym (kill_reg dst rel))). Definition find_op_fold op args (already : option reg) x sv := match already with @@ -300,7 +307,7 @@ Definition find_op_fold op args (already : option reg) x sv := end. Definition find_op (rel : RELATION.t) (op : operation) (args : list reg) := - PTree.fold (find_op_fold op args) rel None. + PTree.fold (find_op_fold op args) (var_to_sym rel) None. Definition find_load_fold chunk addr args (already : option reg) x sv := match already with @@ -318,12 +325,12 @@ Definition find_load_fold chunk addr args (already : option reg) x sv := end. Definition find_load (rel : RELATION.t) (chunk : memory_chunk) (addr : addressing) (args : list reg) := - PTree.fold (find_load_fold chunk addr args) rel None. + PTree.fold (find_load_fold chunk addr args) (var_to_sym rel) None. Definition oper2 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := let rel' := kill_reg dst rel in - PTree.set dst (SOp op (List.map (forward_move rel') args)) rel'. + mkrel (PTree.set dst (SOp op (List.map (forward_move rel') args)) (var_to_sym rel')). Definition oper1 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) := @@ -348,7 +355,7 @@ Definition gen_oper (op: operation) (dst : reg) (args : list reg) Definition load2 (chunk: memory_chunk) (addr : addressing) (dst : reg) (args : list reg) (rel : RELATION.t) := let rel' := kill_reg dst rel in - PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) rel'. + mkrel (PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) (var_to_sym rel')). Definition load1 (chunk: memory_chunk) (addr : addressing) (dst : reg) (args : list reg) (rel : RELATION.t) := diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 82fa8a28..a29bf202 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -58,7 +58,7 @@ Definition sem_sym_val sym rs (v : option val) : Prop := end. Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) (v : val) : Prop := - match rel ! x with + match (var_to_sym rel) ! x with | None => True | Some sym => sem_sym_val sym rs (Some (rs # x)) end. @@ -98,7 +98,7 @@ Proof. pose proof (SEM arg) as SEMarg. simpl. unfold forward_move. unfold sem_sym_val in *. - destruct (t ! arg); trivial. + destruct (_ ! arg); trivial. destruct s; congruence. Qed. @@ -127,7 +127,7 @@ Lemma kill_reg_sound : Proof. unfold sem_rel, kill_reg, sem_reg, sem_sym_val. intros until v. - intros REL x. + intros REL x. simpl. rewrite PTree.gfilter1. destruct (Pos.eq_dec dst x). { @@ -137,7 +137,7 @@ Proof. } rewrite PTree.gro by congruence. rewrite Regmap.gso by congruence. - destruct (rel ! x) as [relx | ] eqn:RELx; trivial. + destruct (_ ! x) as [relx | ] eqn:RELx; trivial. unfold kill_sym_val. pose proof (REL x) as RELinstx. rewrite RELx in RELinstx. @@ -190,12 +190,13 @@ Proof. { subst x. unfold sem_reg. + simpl. rewrite PTree.gss. rewrite Regmap.gss. unfold sem_reg in *. simpl. unfold forward_move. - destruct (rel ! src) as [ sv |]; simpl. + destruct (_ ! src) as [ sv |]; simpl. destruct sv eqn:SV; simpl in *. { destruct (peq dst src0). @@ -211,6 +212,7 @@ Proof. } rewrite Regmap.gso by congruence. unfold sem_reg. + simpl. rewrite PTree.gso by congruence. rewrite Regmap.gso in KILL by congruence. exact KILL. @@ -223,9 +225,10 @@ Lemma move_cases_neq: Proof. intros until a. intro NEQ. unfold kill_reg, forward_move. + simpl. rewrite PTree.gfilter1. rewrite PTree.gro by congruence. - destruct (rel ! a); simpl. + destruct (_ ! a); simpl. 2: congruence. destruct s. { @@ -259,9 +262,10 @@ Proof. unfold kill_reg. unfold sem_reg in RELa. unfold forward_move. + simpl. rewrite PTree.gfilter1. rewrite PTree.gro by auto. - destruct (rel ! a); simpl; trivial. + destruct (_ ! a); simpl; trivial. destruct s; simpl in *; destruct negb; simpl; congruence. Qed. @@ -285,6 +289,7 @@ Proof. { subst x. unfold sem_reg. + simpl. rewrite PTree.gss. rewrite Regmap.gss. simpl. @@ -294,6 +299,7 @@ Proof. } rewrite Regmap.gso by congruence. unfold sem_reg. + simpl. rewrite PTree.gso by congruence. rewrite Regmap.gso in KILL by congruence. exact KILL. @@ -341,13 +347,13 @@ Proof. | Some src => eval_operation genv sp op rs ## args m = Some rs # src end -> fold_left (fun (a : option reg) (p : positive * sym_val) => - find_op_fold op args a (fst p) (snd p)) (PTree.elements rel) start = + find_op_fold op args a (fst p) (snd p)) (PTree.elements (var_to_sym rel)) start = Some src -> eval_operation genv sp op rs ## args m = Some rs # src) as REC. { unfold sem_rel, sem_reg in REL. - generalize (PTree.elements_complete rel). - generalize (PTree.elements rel). + generalize (PTree.elements_complete (var_to_sym rel)). + generalize (PTree.elements (var_to_sym rel)). induction l; simpl. { intros. @@ -372,7 +378,7 @@ Proof. destruct eq_args; trivial. subst args0. simpl. - assert ((rel ! r) = Some (SOp op args)) as RELatr. + assert (((var_to_sym rel) ! r) = Some (SOp op args)) as RELatr. { apply COMPLETE. left. @@ -417,7 +423,7 @@ Proof. end -> fold_left (fun (a : option reg) (p : positive * sym_val) => - find_load_fold chunk addr args a (fst p) (snd p)) (PTree.elements rel) start = + find_load_fold chunk addr args a (fst p) (snd p)) (PTree.elements (var_to_sym rel)) start = Some src -> match eval_addressing genv sp addr rs##args with | Some a => (Mem.loadv chunk m a) = Some (rs # src) @@ -426,8 +432,8 @@ Proof. { unfold sem_rel, sem_reg in REL. - generalize (PTree.elements_complete rel). - generalize (PTree.elements rel). + generalize (PTree.elements_complete (var_to_sym rel)). + generalize (PTree.elements (var_to_sym rel)). induction l; simpl. { intros. @@ -454,7 +460,7 @@ Proof. destruct eq_args; trivial. subst args0. simpl. - assert ((rel ! r) = Some (SLoad chunk addr args)) as RELatr. + assert (((var_to_sym rel) ! r) = Some (SLoad chunk addr args)) as RELatr. { apply COMPLETE. left. @@ -497,7 +503,7 @@ Proof. 2: (apply IHargs; assumption). unfold forward_move, sem_rel, sem_reg, sem_sym_val in *. pose proof (REL a) as RELa. - destruct (rel ! a); trivial. + destruct (_ ! a); trivial. destruct s; congruence. Qed. @@ -580,6 +586,7 @@ Proof. { subst x. unfold sem_reg. + simpl. rewrite PTree.gss. rewrite Regmap.gss. simpl. @@ -588,6 +595,7 @@ Proof. } rewrite Regmap.gso by congruence. unfold sem_reg. + simpl. rewrite PTree.gso by congruence. rewrite Regmap.gso in KILL by congruence. exact KILL. @@ -661,6 +669,7 @@ Proof. intros REL x. pose proof (REL x) as RELx. unfold kill_reg, sem_reg in *. + simpl. rewrite PTree.gfilter1. destruct (peq res x). { subst x. @@ -668,7 +677,7 @@ Proof. reflexivity. } rewrite PTree.gro by congruence. - destruct (mpc ! x) as [sv | ]; trivial. + destruct (_ ! x) as [sv | ]; trivial. destruct negb; trivial. Qed. @@ -691,8 +700,8 @@ Proof. pose proof (RE x) as REx. pose proof (GE x) as GEx. unfold sem_reg in *. - destruct (r1 ! x) as [r1x | ] in *; - destruct (r2 ! x) as [r2x | ] in *; + destruct ((var_to_sym r1) ! x) as [r1x | ] in *; + destruct ((var_to_sym r2) ! x) as [r2x | ] in *; congruence. Qed. End SAME_MEMORY. @@ -708,9 +717,10 @@ Proof. intros SEM x. pose proof (SEM x) as SEMx. unfold kill_mem. + simpl. rewrite PTree.gfilter1. unfold kill_sym_val_mem. - destruct (rel ! x) as [ sv | ]. + destruct ((var_to_sym rel) ! x) as [ sv | ]. 2: reflexivity. destruct sv; simpl in *; trivial. { -- cgit From 04dc160b4962fedd1ef1b322809377a2fa1434a2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 14:03:35 +0100 Subject: gcombine_null --- lib/Maps.v | 40 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/lib/Maps.v b/lib/Maps.v index 9e44a7fe..e938f205 100644 --- a/lib/Maps.v +++ b/lib/Maps.v @@ -625,7 +625,45 @@ Module PTree <: TREE. auto. Qed. - Fixpoint xelements (A : Type) (m : t A) (i : positive) + Section COMBINE_NULL. + + Variables A B C: Type. + Variable f: A -> B -> option C. + + + Fixpoint combine_null (m1: t A) (m2: t B) {struct m1} : t C := + match m1, m2 with + | (Node l1 o1 r1), (Node l2 o2 r2) => + Node' (combine_null l1 l2) + (match o1, o2 with + | (Some x1), (Some x2) => f x1 x2 + | _, _ => None + end) + (combine_null r1 r2) + | _, _ => Leaf + end. + + Theorem gcombine_null: + forall (m1: t A) (m2: t B) (i: positive), + get i (combine_null m1 m2) = + match (get i m1), (get i m2) with + | (Some x1), (Some x2) => f x1 x2 + | _, _ => None + end. + Proof. + induction m1; intros; simpl. + - rewrite gleaf. rewrite gleaf. + reflexivity. + - destruct m2; simpl. + + rewrite gleaf. rewrite gleaf. + destruct get; reflexivity. + + rewrite gnode'. + destruct i; simpl; try rewrite IHm1_1; try rewrite IHm1; trivial. + Qed. + + End COMBINE_NULL. + + Fixpoint xelements (A : Type) (m : t A) (i : positive) (k: list (positive * A)) {struct m} : list (positive * A) := match m with -- cgit From ed0ad804bd09b2b76ec2535367ab9dd57b2600b0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 14:06:47 +0100 Subject: gcombine_null --- lib/Maps.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lib/Maps.v b/lib/Maps.v index e938f205..0beb11b4 100644 --- a/lib/Maps.v +++ b/lib/Maps.v @@ -116,6 +116,19 @@ Module Type TREE. forall (m1: t A) (m2: t B) (i: elt), get i (combine f m1 m2) = f (get i m1) (get i m2). + Parameter combine_null : + forall (A B C: Type) (f: A -> B -> option C), + t A -> t B -> t C. + + Axiom gcombine_null: + forall (A B C: Type) (f: A -> B -> option C), + forall (m1: t A) (m2: t B) (i: elt), + get i (combine_null f m1 m2) = + match (get i m1), (get i m2) with + | (Some x1), (Some x2) => f x1 x2 + | _, _ => None + end. + (** Enumerating the bindings of a tree. *) Parameter elements: forall (A: Type), t A -> list (elt * A). -- cgit From 4f5ea8b8373dc994714aa563182bad9c9ed21526 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 14:53:25 +0100 Subject: gremove_t --- lib/Maps.v | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/lib/Maps.v b/lib/Maps.v index 0beb11b4..5a0e6d5a 100644 --- a/lib/Maps.v +++ b/lib/Maps.v @@ -676,6 +676,42 @@ Module PTree <: TREE. End COMBINE_NULL. + Section REMOVE_TREE. + + Variables A B: Type. + + Fixpoint remove_t (m1: t A) (m2: t B) {struct m1} : t A := + match m1, m2 with + | Leaf, _ | _, Leaf => m1 + | (Node l1 o1 r1), (Node l2 o2 r2) => + Node' (remove_t l1 l2) + (match o2 with + | Some _ => None + | None => o1 + end) + (remove_t r1 r2) + end. + + Theorem gremove_t: + forall m1 : t A, + forall m2 : t B, + forall i : positive, + get i (remove_t m1 m2) = match get i m2 with + | None => get i m1 + | Some _ => None + end. + Proof. + induction m1; intros; simpl. + - rewrite gleaf. + destruct get; reflexivity. + - destruct m2; simpl. + + rewrite gleaf. + reflexivity. + + rewrite gnode'. + destruct i; simpl; try rewrite IHm1_1; try rewrite IHm1; trivial. + Qed. + End REMOVE_TREE. + Fixpoint xelements (A : Type) (m : t A) (i : positive) (k: list (positive * A)) {struct m} : list (positive * A) := -- cgit From 0c07f0f560547ae83f3398adcd53be31e7707a62 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 16:01:59 +0100 Subject: begin well formedness --- backend/CSE2.v | 47 +++++++++++++++++-------- backend/CSE2proof.v | 98 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 130 insertions(+), 15 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 0479dad9..358fade4 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -29,9 +29,20 @@ Proof. decide equality. Defined. +Definition pset := PTree.t unit. + +Definition pset_inter : pset -> pset -> pset := + PTree.combine_null + (fun ov1 ov2 => Some tt). + +Definition pset_empty : pset := PTree.empty unit. +Definition pset_add (i : positive) (s : pset) := PTree.set i tt s. +Definition pset_remove (i : positive) (s : pset) := PTree.remove i s. + Record relmap := mkrel { - var_to_sym : (PTree.t sym_val) - }. + var_to_sym : PTree.t sym_val ; + mem_used : pset + }. Module RELATION. @@ -40,7 +51,7 @@ Definition t := relmap. Definition eq (r1 r2 : t) := forall x, (PTree.get x (var_to_sym r1)) = (PTree.get x (var_to_sym r2)). -Definition top : t := mkrel (PTree.empty sym_val). +Definition top : t := mkrel (PTree.empty sym_val) pset_empty. Lemma eq_refl: forall x, eq x x. Proof. @@ -119,7 +130,8 @@ Definition lub (r1 r2 : t) := | None, _ | _, None => None end) - (var_to_sym r1) (var_to_sym r2)). + (var_to_sym r1) (var_to_sym r2)) + (pset_inter (mem_used r1) (mem_used r2)). Lemma ge_lub_left: forall x y, ge (lub x y) x. Proof. @@ -268,9 +280,10 @@ Definition kill_sym_val (dst : reg) (sv : sym_val) := | SLoad chunk addr args => List.existsb (peq dst) args end. -Definition kill_reg (dst : reg) (rel : RELATION.t) := +Definition kill_reg (dst : reg) (rel : RELATION.t) : RELATION.t := mkrel (PTree.filter1 (fun x => negb (kill_sym_val dst x)) - (PTree.remove dst (var_to_sym rel))). + (PTree.remove dst (var_to_sym rel))) + (pset_remove dst (mem_used rel)). Definition kill_sym_val_mem (sv: sym_val) := match sv with @@ -281,7 +294,8 @@ Definition kill_sym_val_mem (sv: sym_val) := Definition kill_mem (rel : RELATION.t) := mkrel - (PTree.filter1 (fun x => negb (kill_sym_val_mem x)) (var_to_sym rel)). + (PTree.filter1 (fun x => negb (kill_sym_val_mem x)) (var_to_sym rel)) + pset_empty. Definition forward_move (rel : RELATION.t) (x : reg) : reg := @@ -291,7 +305,8 @@ Definition forward_move (rel : RELATION.t) (x : reg) : reg := end. Definition move (src dst : reg) (rel : RELATION.t) := - mkrel (PTree.set dst (SMove (forward_move rel src)) (var_to_sym (kill_reg dst rel))). + mkrel (PTree.set dst (SMove (forward_move rel src)) (var_to_sym (kill_reg dst rel))) + (mem_used rel). Definition find_op_fold op args (already : option reg) x sv := match already with @@ -328,34 +343,36 @@ Definition find_load (rel : RELATION.t) (chunk : memory_chunk) (addr : addressin PTree.fold (find_load_fold chunk addr args) (var_to_sym rel) None. Definition oper2 (op: operation) (dst : reg) (args : list reg) - (rel : RELATION.t) := + (rel : RELATION.t) : RELATION.t := let rel' := kill_reg dst rel in - mkrel (PTree.set dst (SOp op (List.map (forward_move rel') args)) (var_to_sym rel')). + mkrel (PTree.set dst (SOp op (List.map (forward_move rel') args)) (var_to_sym rel')) + (mem_used rel). Definition oper1 (op: operation) (dst : reg) (args : list reg) - (rel : RELATION.t) := + (rel : RELATION.t) : RELATION.t := if List.in_dec peq dst args then kill_reg dst rel else oper2 op dst args rel. Definition oper (op: operation) (dst : reg) (args : list reg) - (rel : RELATION.t) := + (rel : RELATION.t) : RELATION.t := match find_op rel op (List.map (forward_move rel) args) with | Some r => move r dst rel | None => oper1 op dst args rel end. Definition gen_oper (op: operation) (dst : reg) (args : list reg) - (rel : RELATION.t) := + (rel : RELATION.t) : RELATION.t := match op, args with | Omove, src::nil => move src dst rel | _, _ => oper op dst args rel end. Definition load2 (chunk: memory_chunk) (addr : addressing) - (dst : reg) (args : list reg) (rel : RELATION.t) := + (dst : reg) (args : list reg) (rel : RELATION.t) : RELATION.t := let rel' := kill_reg dst rel in - mkrel (PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) (var_to_sym rel')). + mkrel (PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) (var_to_sym rel')) + (pset_add dst (mem_used rel)). Definition load1 (chunk: memory_chunk) (addr : addressing) (dst : reg) (args : list reg) (rel : RELATION.t) := diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index a29bf202..bd917163 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -37,6 +37,104 @@ Proof. assumption. Qed. +Lemma gpset_inter_none: forall a b i, + (pset_inter a b) ! i = None <-> + (a ! i = None) \/ (b ! i = None). +Proof. + intros. unfold pset_inter. + rewrite PTree.gcombine_null. + destruct (a ! i); destruct (b ! i); intuition discriminate. +Qed. + +Lemma some_some: + forall x : option unit, + x <> None <-> x = Some tt. +Proof. + destruct x as [[] | ]; split; congruence. +Qed. + +Lemma gpset_inter_some: forall a b i, + (pset_inter a b) ! i = Some tt <-> + (a ! i = Some tt) /\ (b ! i = Some tt). +Proof. + intros. unfold pset_inter. + rewrite PTree.gcombine_null. + destruct (a ! i) as [[] | ]; destruct (b ! i) as [[] | ]; intuition congruence. +Qed. + +Definition wellformed (rel : RELATION.t) : Prop := + forall i sv, + (var_to_sym rel) ! i = Some sv -> + kill_sym_val_mem sv = true -> + (mem_used rel) ! i = Some tt. + +Lemma wellformed_top : wellformed RELATION.top. +Proof. + unfold wellformed, RELATION.top, pset_empty. + simpl. + intros. + rewrite PTree.gempty in *. + discriminate. +Qed. + +Lemma wellformed_lub : forall a b, + (wellformed a) -> (wellformed b) -> (wellformed (RELATION.lub a b)). +Proof. + unfold wellformed, RELATION.lub. + simpl. + intros a b Ha Hb. + intros i sv COMBINE KILLABLE. + rewrite PTree.gcombine in *. + 2: reflexivity. + destruct (var_to_sym a) ! i as [syma | ] eqn:SYMA; + destruct (var_to_sym b) ! i as [symb | ] eqn:SYMB; + try discriminate. + destruct (eq_sym_val syma symb); try discriminate. + subst syma. + inv COMBINE. + apply gpset_inter_some. + split; eauto. +Qed. + +Lemma wellformed_kill_reg: + forall dst rel, + (wellformed rel) -> (wellformed (kill_reg dst rel)). +Proof. + unfold wellformed, kill_reg, pset_remove. + simpl. + intros dst rel Hrel. + intros i sv KILLREG KILLABLE. + rewrite PTree.gfilter1 in KILLREG. + destruct (peq dst i). + { subst i. + rewrite PTree.grs in *. + discriminate. + } + rewrite PTree.gro in * by congruence. + specialize Hrel with (i := i). + eapply Hrel. + 2: eassumption. + destruct (_ ! i); try discriminate. + destruct negb; congruence. +Qed. + +Lemma wellformed_kill_mem: + forall rel, + (wellformed rel) -> (wellformed (kill_mem rel)). +Proof. + unfold wellformed, kill_mem. + simpl. + intros rel Hrel. + intros i sv KILLMEM KILLABLE. + rewrite PTree.gfilter1 in KILLMEM. + exfalso. + specialize Hrel with (i := i). + destruct ((var_to_sym rel) ! i) eqn:RELi. + 2: discriminate. + specialize Hrel with (sv := s). + destruct (kill_sym_val_mem s) eqn:KILLs; simpl in KILLMEM; congruence. +Qed. + Section SOUNDNESS. Variable F V : Type. Variable genv: Genv.t F V. -- cgit From e88c7fa00a5174ecf897b3cb59b7adee818a1788 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 16:59:18 +0100 Subject: wellformedness for memory --- backend/CSE2.v | 10 ++-- backend/CSE2proof.v | 165 +++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 158 insertions(+), 17 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 358fade4..2fc0c323 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -305,8 +305,9 @@ Definition forward_move (rel : RELATION.t) (x : reg) : reg := end. Definition move (src dst : reg) (rel : RELATION.t) := - mkrel (PTree.set dst (SMove (forward_move rel src)) (var_to_sym (kill_reg dst rel))) - (mem_used rel). + let rel0 := kill_reg dst rel in + mkrel (PTree.set dst (SMove (forward_move rel src)) (var_to_sym rel0)) + (mem_used rel0). Definition find_op_fold op args (already : option reg) x sv := match already with @@ -346,7 +347,8 @@ Definition oper2 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) : RELATION.t := let rel' := kill_reg dst rel in mkrel (PTree.set dst (SOp op (List.map (forward_move rel') args)) (var_to_sym rel')) - (mem_used rel). + (if op_depends_on_memory op then (pset_add dst (mem_used rel')) + else mem_used rel'). Definition oper1 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) : RELATION.t := @@ -372,7 +374,7 @@ Definition load2 (chunk: memory_chunk) (addr : addressing) (dst : reg) (args : list reg) (rel : RELATION.t) : RELATION.t := let rel' := kill_reg dst rel in mkrel (PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) (var_to_sym rel')) - (pset_add dst (mem_used rel)). + (pset_add dst (mem_used rel')). Definition load1 (chunk: memory_chunk) (addr : addressing) (dst : reg) (args : list reg) (rel : RELATION.t) := diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index bd917163..15ce3ffb 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -62,25 +62,26 @@ Proof. destruct (a ! i) as [[] | ]; destruct (b ! i) as [[] | ]; intuition congruence. Qed. -Definition wellformed (rel : RELATION.t) : Prop := +Definition wellformed_mem (rel : RELATION.t) : Prop := forall i sv, (var_to_sym rel) ! i = Some sv -> kill_sym_val_mem sv = true -> (mem_used rel) ! i = Some tt. -Lemma wellformed_top : wellformed RELATION.top. +Lemma wellformed_mem_top : wellformed_mem RELATION.top. Proof. - unfold wellformed, RELATION.top, pset_empty. + unfold wellformed_mem, RELATION.top, pset_empty. simpl. intros. rewrite PTree.gempty in *. discriminate. Qed. +Local Hint Resolve wellformed_mem_top : wellformed. -Lemma wellformed_lub : forall a b, - (wellformed a) -> (wellformed b) -> (wellformed (RELATION.lub a b)). +Lemma wellformed_mem_lub : forall a b, + (wellformed_mem a) -> (wellformed_mem b) -> (wellformed_mem (RELATION.lub a b)). Proof. - unfold wellformed, RELATION.lub. + unfold wellformed_mem, RELATION.lub. simpl. intros a b Ha Hb. intros i sv COMBINE KILLABLE. @@ -95,12 +96,13 @@ Proof. apply gpset_inter_some. split; eauto. Qed. +Local Hint Resolve wellformed_mem_lub : wellformed. -Lemma wellformed_kill_reg: +Lemma wellformed_mem_kill_reg: forall dst rel, - (wellformed rel) -> (wellformed (kill_reg dst rel)). + (wellformed_mem rel) -> (wellformed_mem (kill_reg dst rel)). Proof. - unfold wellformed, kill_reg, pset_remove. + unfold wellformed_mem, kill_reg, pset_remove. simpl. intros dst rel Hrel. intros i sv KILLREG KILLABLE. @@ -117,12 +119,13 @@ Proof. destruct (_ ! i); try discriminate. destruct negb; congruence. Qed. +Local Hint Resolve wellformed_mem_kill_reg : wellformed. -Lemma wellformed_kill_mem: +Lemma wellformed_mem_kill_mem: forall rel, - (wellformed rel) -> (wellformed (kill_mem rel)). + (wellformed_mem rel) -> (wellformed_mem (kill_mem rel)). Proof. - unfold wellformed, kill_mem. + unfold wellformed_mem, kill_mem. simpl. intros rel Hrel. intros i sv KILLMEM KILLABLE. @@ -134,7 +137,143 @@ Proof. specialize Hrel with (sv := s). destruct (kill_sym_val_mem s) eqn:KILLs; simpl in KILLMEM; congruence. Qed. - +Local Hint Resolve wellformed_mem_kill_mem : wellformed. + +Lemma wellformed_mem_move: + forall r dst rel, + (wellformed_mem rel) -> (wellformed_mem (move r dst rel)). +Proof. + Local Opaque kill_reg. + intros; unfold move, wellformed_mem; simpl. + intros i sv MOVE KILL. + destruct (peq i dst). + { subst i. + rewrite PTree.gss in MOVE. + inv MOVE. + simpl in KILL. + discriminate. + } + rewrite PTree.gso in MOVE by congruence. + eapply wellformed_mem_kill_reg; eauto. +Qed. +Local Hint Resolve wellformed_mem_move : wellformed. + +Lemma wellformed_mem_oper2: + forall op dst args rel, + (wellformed_mem rel) -> + (wellformed_mem (oper2 op dst args rel)). +Proof. + intros until rel. intro WELLFORMED. + unfold oper2. + intros i sv MOVE OPER. + simpl in *. + destruct (peq i dst). + { subst i. + rewrite PTree.gss in MOVE. + inv MOVE. + simpl in OPER. + rewrite OPER. + apply PTree.gss. + } + unfold pset_add. + rewrite PTree.gso in MOVE by congruence. + destruct op_depends_on_memory. + - rewrite PTree.gso by congruence. + eapply wellformed_mem_kill_reg; eauto. + - eapply wellformed_mem_kill_reg; eauto. +Qed. +Local Hint Resolve wellformed_mem_oper2 : wellformed. + +Lemma wellformed_mem_oper1: + forall op dst args rel, + (wellformed_mem rel) -> + (wellformed_mem (oper1 op dst args rel)). +Proof. + unfold oper1. intros. + destruct in_dec ; auto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_oper1 : wellformed. + +Lemma wellformed_mem_oper: + forall op dst args rel, + (wellformed_mem rel) -> + (wellformed_mem (oper op dst args rel)). +Proof. + unfold oper. intros. + destruct find_op ; auto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_oper : wellformed. + +Lemma wellformed_mem_gen_oper: + forall op dst args rel, + (wellformed_mem rel) -> + (wellformed_mem (gen_oper op dst args rel)). +Proof. + intros. + unfold gen_oper. + destruct op; auto with wellformed. + destruct args; auto with wellformed. + destruct args; auto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_gen_oper : wellformed. + +Lemma wellformed_mem_load2 : + forall chunk addr dst args rel, + (wellformed_mem rel) -> + (wellformed_mem (load2 chunk addr dst args rel)). +Proof. + intros. + unfold load2, wellformed_mem. + simpl. + intros i sv LOAD KILL. + destruct (peq i dst). + { subst i. + apply PTree.gss. + } + unfold pset_add. + rewrite PTree.gso in * by congruence. + eapply wellformed_mem_kill_reg; eauto. +Qed. +Local Hint Resolve wellformed_mem_load2 : wellformed. + +Lemma wellformed_mem_load1 : + forall chunk addr dst args rel, + (wellformed_mem rel) -> + (wellformed_mem (load1 chunk addr dst args rel)). +Proof. + intros. + unfold load1. + destruct in_dec; eauto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_load1 : wellformed. + +Lemma wellformed_mem_load : + forall chunk addr dst args rel, + (wellformed_mem rel) -> + (wellformed_mem (load chunk addr dst args rel)). +Proof. + intros. + unfold load. + destruct find_load; eauto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_load : wellformed. + +Definition wellformed_mem' (rb : RB.t) := + match rb with + | None => True + | Some r => wellformed_mem r + end. + +Definition wellformed_apply_instr: + forall instr rel, + (wellformed_mem rel) -> + (wellformed_mem' (apply_instr instr rel)). +Proof. + destruct instr; simpl; auto with wellformed. +Qed. + +Local Transparent kill_reg. + Section SOUNDNESS. Variable F V : Type. Variable genv: Genv.t F V. -- cgit From b55e522ca286bbe96be3ce5fc05c984b2a4a130a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 17:23:41 +0100 Subject: invariant guaranteed --- backend/CSE2.v | 4 +++- backend/CSE2proof.v | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 56 insertions(+), 4 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 2fc0c323..a818996b 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -268,6 +268,8 @@ Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM). - apply L.ge_refl. apply L.eq_refl. Qed. + + Definition top := Some RELATION.top. End ADD_BOTTOM. Module RB := ADD_BOTTOM(RELATION). @@ -441,7 +443,7 @@ Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t := 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). + (apply_instr' (RTL.fn_code f)) (RTL.fn_entrypoint f) RB.top. Definition forward_move_b (rb : RB.t) (x : reg) := match rb with diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 15ce3ffb..351a4219 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -258,19 +258,69 @@ Proof. Qed. Local Hint Resolve wellformed_mem_load : wellformed. -Definition wellformed_mem' (rb : RB.t) := +Definition wellformed_mem_rb (rb : RB.t) := match rb with | None => True | Some r => wellformed_mem r end. -Definition wellformed_apply_instr: +Lemma wellformed_mem_apply_instr: forall instr rel, (wellformed_mem rel) -> - (wellformed_mem' (apply_instr instr rel)). + (wellformed_mem_rb (apply_instr instr rel)). Proof. destruct instr; simpl; auto with wellformed. Qed. +Local Hint Resolve wellformed_mem_apply_instr : wellformed. + +Lemma wellformed_mem_rb_bot : + wellformed_mem_rb RB.bot. +Proof. + simpl. + trivial. +Qed. +Local Hint Resolve wellformed_mem_rb_bot: wellformed. + +Lemma wellformed_mem_rb_top : + wellformed_mem_rb RB.top. +Proof. + simpl. + auto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_rb_top: wellformed. + +Lemma wellformed_mem_rb_apply_instr': + forall code pc rel, + (wellformed_mem_rb rel) -> + (wellformed_mem_rb (apply_instr' code pc rel)). +Proof. + destruct rel; simpl; trivial. + intro. + destruct (code ! pc); + eauto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_rb_apply_instr' : wellformed. + +Lemma wellformed_mem_rb_lub : forall a b, + (wellformed_mem_rb a) -> (wellformed_mem_rb b) -> (wellformed_mem_rb (RB.lub a b)). +Proof. + destruct a; destruct b; simpl; auto with wellformed. +Qed. +Local Hint Resolve wellformed_mem_rb_lub: wellformed. + +Definition wellformed_mem_fmap fmap := + forall i, wellformed_mem_rb (fmap !! i). + +Theorem wellformed_mem_forward_map : forall f, + forall fmap, (forward_map f) = Some fmap -> + wellformed_mem_fmap fmap. +Proof. + intros. + unfold forward_map in *. + unfold wellformed_mem_fmap. + intro. + eapply DS.fixpoint_invariant with (ev := Some RELATION.top); eauto with wellformed. +Qed. Local Transparent kill_reg. -- cgit From e0257f612a1358ad9927bd198cb11798cd8ccae4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 17:57:05 +0100 Subject: kill memory focused --- backend/CSE2.v | 2 +- backend/CSE2proof.v | 64 +++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 46 insertions(+), 20 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index a818996b..a76104af 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -296,7 +296,7 @@ Definition kill_sym_val_mem (sv: sym_val) := Definition kill_mem (rel : RELATION.t) := mkrel - (PTree.filter1 (fun x => negb (kill_sym_val_mem x)) (var_to_sym rel)) + (PTree.remove_t (var_to_sym rel) (mem_used rel)) pset_empty. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 351a4219..825cfbcd 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -129,13 +129,16 @@ Proof. simpl. intros rel Hrel. intros i sv KILLMEM KILLABLE. - rewrite PTree.gfilter1 in KILLMEM. + rewrite PTree.gremove_t in KILLMEM. exfalso. specialize Hrel with (i := i). destruct ((var_to_sym rel) ! i) eqn:RELi. - 2: discriminate. - specialize Hrel with (sv := s). - destruct (kill_sym_val_mem s) eqn:KILLs; simpl in KILLMEM; congruence. + - specialize Hrel with (sv := s). + destruct ((mem_used rel) ! i) eqn:USEDi. + discriminate. + inv KILLMEM. + intuition congruence. + - destruct ((mem_used rel) ! i); discriminate. Qed. Local Hint Resolve wellformed_mem_kill_mem : wellformed. @@ -321,6 +324,7 @@ Proof. intro. eapply DS.fixpoint_invariant with (ev := Some RELATION.top); eauto with wellformed. Qed. +Local Hint Resolve wellformed_mem_forward_map: wellformed. Local Transparent kill_reg. @@ -997,24 +1001,33 @@ Lemma kill_mem_sound : forall m m' : mem, forall rel : RELATION.t, forall rs, + wellformed_mem rel -> sem_rel m rel rs -> sem_rel m' (kill_mem rel) rs. Proof. unfold sem_rel, sem_reg. intros until rs. - intros SEM x. - pose proof (SEM x) as SEMx. + intros WELLFORMED SEM x. + unfold wellformed_mem in *. + specialize SEM with (x := x). + specialize WELLFORMED with (i := x). unfold kill_mem. simpl. - rewrite PTree.gfilter1. + rewrite PTree.gremove_t. unfold kill_sym_val_mem. - destruct ((var_to_sym rel) ! x) as [ sv | ]. - 2: reflexivity. - destruct sv; simpl in *; trivial. - { - destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial. - rewrite SEMx. - apply op_depends_on_memory_correct; auto. - } + destruct ((var_to_sym rel) ! x) as [ sv | ] eqn:VAR. + - specialize WELLFORMED with (sv0 := sv). + destruct ((mem_used rel) ! x) eqn:USED; trivial. + unfold sem_sym_val in *. + destruct sv; simpl in *; trivial. + + rewrite op_depends_on_memory_correct with (m2 := m). + assumption. + destruct op_depends_on_memory; intuition congruence. + + intuition discriminate. + - replace (match (mem_used rel) ! x with + | Some _ | _ => None + end) with (@None sym_val) by + (destruct ((mem_used rel) ! x); trivial). + trivial. Qed. End SOUNDNESS. @@ -1155,6 +1168,21 @@ Ltac TR_AT := generalize (transf_function_at _ _ _ A); intros end. +Lemma wellformed_mem_mpc: + forall f map pc mpc, + (forward_map f) = Some map -> + map # pc = Some mpc -> + wellformed_mem mpc. +Proof. + intros. + assert (wellformed_mem_fmap map) by eauto with wellformed. + unfold wellformed_mem_fmap, wellformed_mem_rb in *. + specialize H1 with (i := pc). + rewrite H0 in H1. + assumption. +Qed. +Hint Resolve wellformed_mem_mpc : wellformed. + Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> @@ -1413,8 +1441,7 @@ Proof. rewrite H. reflexivity. } - apply (kill_mem_sound' sp m). - assumption. + apply (kill_mem_sound' sp m); eauto with wellformed. (* call *) - econstructor; split. @@ -1444,8 +1471,7 @@ Proof. reflexivity. } apply kill_reg_sound. - apply (kill_mem_sound' sp m). - assumption. + apply (kill_mem_sound' sp m); eauto with wellformed. } (* tailcall *) -- cgit From c877fef46e86bbd088e3d3937ce96572bee0101d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 20:31:27 +0100 Subject: wellformedness for reg begins --- backend/CSE2proof.v | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 825cfbcd..86bc123d 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -68,6 +68,13 @@ Definition wellformed_mem (rel : RELATION.t) : Prop := kill_sym_val_mem sv = true -> (mem_used rel) ! i = Some tt. +Definition wellformed_reg (rel : RELATION.t) : Prop := + forall i j sv, + (var_to_sym rel) ! i = Some sv -> + kill_sym_val j sv = true -> + exists uses, (reg_used rel) ! j = Some uses /\ + uses ! i = Some tt. + Lemma wellformed_mem_top : wellformed_mem RELATION.top. Proof. unfold wellformed_mem, RELATION.top, pset_empty. @@ -78,6 +85,16 @@ Proof. Qed. Local Hint Resolve wellformed_mem_top : wellformed. +Lemma wellformed_reg_top : wellformed_reg RELATION.top. +Proof. + unfold wellformed_reg, RELATION.top, pset_empty. + simpl. + intros. + rewrite PTree.gempty in *. + discriminate. +Qed. +Local Hint Resolve wellformed_reg_top : wellformed. + Lemma wellformed_mem_lub : forall a b, (wellformed_mem a) -> (wellformed_mem b) -> (wellformed_mem (RELATION.lub a b)). Proof. @@ -98,6 +115,42 @@ Proof. Qed. Local Hint Resolve wellformed_mem_lub : wellformed. +Lemma wellformed_reg_lub : forall a b, + (wellformed_reg a) -> (wellformed_reg b) -> (wellformed_reg (RELATION.lub a b)). +Proof. + unfold wellformed_reg, RELATION.lub. + simpl. + intros a b Ha Hb. + intros i j sv COMBINE KILLABLE. + specialize Ha with (i := i) (j := j). + specialize Hb with (i := i) (j := j). + rewrite PTree.gcombine in *. + 2: reflexivity. + destruct (var_to_sym a) ! i as [syma | ] eqn:SYMA; + destruct (var_to_sym b) ! i as [symb | ] eqn:SYMB; + try discriminate. + specialize Ha with (sv := syma). + specialize Hb with (sv := symb). + destruct (eq_sym_val syma symb); try discriminate. + subst syma. + inv COMBINE. + assert (exists usesA : pset, (reg_used a) ! j = Some usesA /\ usesA ! i = Some tt) as USESA by auto. + assert (exists usesB : pset, (reg_used b) ! j = Some usesB /\ usesB ! i = Some tt) as USESB by auto. + destruct USESA as [uA [uA1 uA2]]. + destruct USESB as [uB [uB1 uB2]]. + rewrite PTree.gcombine_null. + rewrite uA1. + rewrite uB1. + pose proof (PTree.bempty_canon_correct (pset_inter uA uB) i) as EMPTY. + destruct PTree.bempty_canon. + - rewrite gpset_inter_none in EMPTY. + intuition congruence. + - econstructor; split; eauto. + rewrite gpset_inter_some. + auto. +Qed. +Local Hint Resolve wellformed_reg_lub : wellformed. + Lemma wellformed_mem_kill_reg: forall dst rel, (wellformed_mem rel) -> (wellformed_mem (kill_reg dst rel)). -- cgit From dabfcfe9aeffe4bcb3d2a27a46e2b10b5d725154 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Feb 2020 21:08:04 +0100 Subject: wellformedness for reg begins; simplified --- backend/CSE2proof.v | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 86bc123d..350cdb24 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -72,8 +72,10 @@ Definition wellformed_reg (rel : RELATION.t) : Prop := forall i j sv, (var_to_sym rel) ! i = Some sv -> kill_sym_val j sv = true -> - exists uses, (reg_used rel) ! j = Some uses /\ - uses ! i = Some tt. + match (reg_used rel) ! j with + | Some uses => uses ! i = Some tt + | None => False + end. Lemma wellformed_mem_top : wellformed_mem RELATION.top. Proof. @@ -134,20 +136,15 @@ Proof. destruct (eq_sym_val syma symb); try discriminate. subst syma. inv COMBINE. - assert (exists usesA : pset, (reg_used a) ! j = Some usesA /\ usesA ! i = Some tt) as USESA by auto. - assert (exists usesB : pset, (reg_used b) ! j = Some usesB /\ usesB ! i = Some tt) as USESB by auto. - destruct USESA as [uA [uA1 uA2]]. - destruct USESB as [uB [uB1 uB2]]. rewrite PTree.gcombine_null. - rewrite uA1. - rewrite uB1. - pose proof (PTree.bempty_canon_correct (pset_inter uA uB) i) as EMPTY. - destruct PTree.bempty_canon. + destruct ((reg_used a) ! j) as [uA| ]; destruct ((reg_used b) ! j) as [uB | ]; auto. + { pose proof (PTree.bempty_canon_correct (pset_inter uA uB) i) as EMPTY. + destruct PTree.bempty_canon. - rewrite gpset_inter_none in EMPTY. intuition congruence. - - econstructor; split; eauto. - rewrite gpset_inter_some. + - rewrite gpset_inter_some. auto. + } Qed. Local Hint Resolve wellformed_reg_lub : wellformed. -- cgit From ad16517ee345e53398c69c62d975474475880799 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Feb 2020 15:37:58 +0100 Subject: progress on wellformed reg --- backend/CSE2.v | 64 +++++++++++++++++++++------ backend/CSE2proof.v | 32 ++++++++++++++ lib/Maps.v | 121 +++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 204 insertions(+), 13 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index a76104af..1e3bc3b7 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -41,7 +41,8 @@ Definition pset_remove (i : positive) (s : pset) := PTree.remove i s. Record relmap := mkrel { var_to_sym : PTree.t sym_val ; - mem_used : pset + mem_used : pset ; + reg_used : PTree.t pset }. Module RELATION. @@ -51,7 +52,7 @@ Definition t := relmap. Definition eq (r1 r2 : t) := forall x, (PTree.get x (var_to_sym r1)) = (PTree.get x (var_to_sym r2)). -Definition top : t := mkrel (PTree.empty sym_val) pset_empty. +Definition top : t := mkrel (PTree.empty sym_val) pset_empty (PTree.empty pset). Lemma eq_refl: forall x, eq x x. Proof. @@ -131,7 +132,13 @@ Definition lub (r1 r2 : t) := | _, None => None end) (var_to_sym r1) (var_to_sym r2)) - (pset_inter (mem_used r1) (mem_used r2)). + (pset_inter (mem_used r1) (mem_used r2)) + (PTree.combine_null + (fun x y => let r := pset_inter x y in + if PTree.bempty_canon r + then None + else Some r) + (reg_used r1) (reg_used r2)). Lemma ge_lub_left: forall x y, ge (lub x y) x. Proof. @@ -275,17 +282,46 @@ End ADD_BOTTOM. Module RB := ADD_BOTTOM(RELATION). Module DS := Dataflow_Solver(RB)(NodeSetForward). -Definition kill_sym_val (dst : reg) (sv : sym_val) := +Definition kill_sym_val (dst : reg) (sv : sym_val) : bool := match sv with | SMove src => if peq dst src then true else false | SOp op args => List.existsb (peq dst) args | SLoad chunk addr args => List.existsb (peq dst) args end. - + +Definition referenced_by sv := + match sv with + | SMove src => src :: nil + | SOp op args => args + | SLoad chunk addr args => args + end. + +Definition referenced_by' osv := + match osv with + | None => nil + | Some sv => referenced_by sv + end. + +Definition remove_from_sets + (to_remove : reg) : + list reg -> PTree.t pset -> PTree.t pset := + List.fold_left + (fun sets reg => + match PTree.get reg sets with + | None => sets + | Some xset => + let xset' := PTree.remove to_remove xset in + if PTree.bempty_canon xset' + then PTree.remove reg sets + else PTree.set reg xset' sets + end). + Definition kill_reg (dst : reg) (rel : RELATION.t) : RELATION.t := - mkrel (PTree.filter1 (fun x => negb (kill_sym_val dst x)) - (PTree.remove dst (var_to_sym rel))) - (pset_remove dst (mem_used rel)). + let rel' := PTree.remove dst (var_to_sym rel) in + mkrel (PTree.filter1 (fun x => negb (kill_sym_val dst x)) rel') + (pset_remove dst (mem_used rel)) + (remove_from_sets dst (referenced_by' (PTree.get dst (var_to_sym rel))) + (PTree.remove dst (reg_used rel))). Definition kill_sym_val_mem (sv: sym_val) := match sv with @@ -297,7 +333,8 @@ Definition kill_sym_val_mem (sv: sym_val) := Definition kill_mem (rel : RELATION.t) := mkrel (PTree.remove_t (var_to_sym rel) (mem_used rel)) - pset_empty. + pset_empty + (reg_used rel). (* FIXME *) Definition forward_move (rel : RELATION.t) (x : reg) : reg := @@ -309,7 +346,8 @@ Definition forward_move (rel : RELATION.t) (x : reg) : reg := Definition move (src dst : reg) (rel : RELATION.t) := let rel0 := kill_reg dst rel in mkrel (PTree.set dst (SMove (forward_move rel src)) (var_to_sym rel0)) - (mem_used rel0). + (mem_used rel0) + (reg_used rel0). (* FIXME *) Definition find_op_fold op args (already : option reg) x sv := match already with @@ -350,7 +388,8 @@ Definition oper2 (op: operation) (dst : reg) (args : list reg) let rel' := kill_reg dst rel in mkrel (PTree.set dst (SOp op (List.map (forward_move rel') args)) (var_to_sym rel')) (if op_depends_on_memory op then (pset_add dst (mem_used rel')) - else mem_used rel'). + else mem_used rel') + (reg_used rel'). (* FIXME *) Definition oper1 (op: operation) (dst : reg) (args : list reg) (rel : RELATION.t) : RELATION.t := @@ -376,7 +415,8 @@ Definition load2 (chunk: memory_chunk) (addr : addressing) (dst : reg) (args : list reg) (rel : RELATION.t) : RELATION.t := let rel' := kill_reg dst rel in mkrel (PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) (var_to_sym rel')) - (pset_add dst (mem_used rel')). + (pset_add dst (mem_used rel')) + (reg_used rel'). (* FIXME *) Definition load1 (chunk: memory_chunk) (addr : addressing) (dst : reg) (args : list reg) (rel : RELATION.t) := diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 350cdb24..e0244518 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -171,6 +171,38 @@ Proof. Qed. Local Hint Resolve wellformed_mem_kill_reg : wellformed. +Lemma kill_sym_val_referenced: + forall dst, + forall sv, + (kill_sym_val dst sv)=true <-> In dst (referenced_by sv). +Proof. + intros. + destruct sv; simpl. + - destruct peq; intuition congruence. + - rewrite existsb_exists. + split. + + intros [x [IN EQ]]. + destruct peq. + * subst x; trivial. + * discriminate. + + intro. + exists dst. + split; trivial. + destruct peq; trivial. + congruence. + - rewrite existsb_exists. + split. + + intros [x [IN EQ]]. + destruct peq. + * subst x; trivial. + * discriminate. + + intro. + exists dst. + split; trivial. + destruct peq; trivial. + congruence. +Qed. + Lemma wellformed_mem_kill_mem: forall rel, (wellformed_mem rel) -> (wellformed_mem (kill_mem rel)). diff --git a/lib/Maps.v b/lib/Maps.v index 5a0e6d5a..ec1b0bee 100644 --- a/lib/Maps.v +++ b/lib/Maps.v @@ -164,6 +164,12 @@ Module Type TREE. forall (A B: Type) (f: B -> A -> B) (v: B) (m: t A), fold1 f m v = List.fold_left (fun a p => f a (snd p)) (elements m) v. + + Parameter bempty_canon : + forall (A : Type), t A -> bool. + Axiom bempty_canon_correct: + forall (A : Type) (tr : t A) (i : elt), + bempty_canon tr = true -> get i tr = None. End TREE. (** * The abstract signatures of maps *) @@ -274,6 +280,12 @@ Module PTree <: TREE. induction i; simpl; auto. Qed. + Definition bempty_canon (A : Type) (tr : t A) : bool := + match tr with + | Leaf => true + | _ => false + end. + Theorem gss: forall (A: Type) (i: positive) (x: A) (m: t A), get i (set i x m) = Some x. Proof. @@ -282,7 +294,16 @@ Module PTree <: TREE. Lemma gleaf : forall (A : Type) (i : positive), get i (Leaf : t A) = None. Proof. exact gempty. Qed. - + + Lemma bempty_canon_correct: + forall (A : Type) (tr : t A) (i : elt), + bempty_canon tr = true -> get i tr = None. + Proof. + destruct tr; intros. + - rewrite gleaf; trivial. + - discriminate. + Qed. + Theorem gso: forall (A: Type) (i j: positive) (x: A) (m: t A), i <> j -> get i (set j x m) = get i m. @@ -1045,6 +1066,104 @@ Module PTree <: TREE. intros. apply fold1_xelements with (l := @nil (positive * A)). Qed. + (* DM + Fixpoint xfind_any (A : Type) (P : elt -> A -> bool) (i : elt) (m : t A): + option elt := + match m with + | Leaf => None + | Node l None r => + match xfind_any P (xO i) l with + | None => xfind_any P (xI i) r + | r => r + end + | Node l (Some x) r => + if P i x + then Some i + else + match xfind_any P (xO i) l with + | None => xfind_any P (xI i) r + | r => r + end + end. + + Definition find_any (A : Type) (P : elt -> A -> bool) (m : t A) := + xfind_any P xH m. + + Fixpoint pos_concat (i : positive) (j : positive) := + match i with + | xI r => xI (pos_concat r j) + | xO r => xO (pos_concat r j) + | xH => j + end. + + Lemma pos_concat_assoc : + forall i j k, + (pos_concat (pos_concat i j) k) = (pos_concat i (pos_concat j k)). + Admitted. + + Lemma pos_concat_eq_l : forall i j, + (pos_concat i j) = i -> j = xH. + Proof. + induction i; simpl; intros j EQ. + - inv EQ. auto. + - inv EQ. auto. + - trivial. + Qed. + + Lemma pos_concat_eq_r : forall i j, + (pos_concat i j) = j -> i = xH. + Admitted. + + Local Hint Resolve pos_concat_eq_r : trees. + + Lemma pos_concat_xH_r: forall i, (pos_concat i xH) = i. + Proof. + induction i; simpl; try rewrite IHi; trivial. + Qed. + + Local Hint Resolve pos_concat_xH_r : trees. + + (* + Fixpoint pos_is_prefix (i j : elt) := + match i, j with + | xI i1, xI j1 => pos_is_prefix i1 j1 + | xO i1, xO j1 => pos_is_prefix i1 j1 + | xH, _ => true + | _, _ => false + end. + *) + + Lemma xfind_any_correct: + forall A P (m : t A) i k, + xfind_any P i m = Some k -> exists j v, k = pos_concat j i + /\ (get j m)=Some v /\ (P k v)=true. + Proof. + induction m; simpl. + { (* leaf *) + discriminate. + } + intros i k FOUND. + destruct o. + { destruct P eqn:Pval in FOUND. + { inv FOUND. + exists xH. exists a. + simpl. + eauto. + } + specialize IHm1 with (i := xO i) (k := k). + specialize IHm2 with (i := xI i) (k := k). + assert (Some k = Some k) as SK by trivial. + destruct (xfind_any P (xO i) m1). + { + inv FOUND. + destruct (IHm1 SK) as [j' [v [EQk [GET PP]]]]. + exists (pos_concat j' (xO xH)). exists v. + rewrite pos_concat_assoc. + simpl. + split; trivial. + split; trivial. + } + *) End PTree. (** * An implementation of maps over type [positive] *) -- cgit From 56dc34adcd147d8ac29f57edc9da1718a493dcce Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Feb 2020 17:26:28 +0100 Subject: wellformed_reg_kill_reg --- backend/CSE2proof.v | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 129 insertions(+) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index e0244518..e62e2ae6 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -202,7 +202,136 @@ Proof. destruct peq; trivial. congruence. Qed. +Local Hint Resolve kill_sym_val_referenced : wellformed. +Lemma in_or_not: + forall (x : reg) l, + (In x l) \/ ~(In x l). +Admitted. + +Lemma remove_from_sets_notin: + forall dst l sets j, + not (In j l) -> + (remove_from_sets dst l sets) ! j = sets ! j. +Proof. + induction l; simpl; trivial. + intros. + rewrite IHl by tauto. + destruct (@PTree.get (PTree.t unit) a sets) eqn:SETSA; trivial. + pose proof (PTree.bempty_canon_correct (PTree.remove dst t)) as CORRECT. + destruct (PTree.bempty_canon (PTree.remove dst t)). + - apply PTree.gro. + intuition. + - rewrite PTree.gso by intuition. + trivial. +Qed. + +Lemma remove_from_sets_pass: + forall dst l sets i j, + i <> dst -> + match sets ! j with + | Some uses => uses ! i = Some tt + | None => False + end -> + match (remove_from_sets dst l sets) ! j with + | Some uses => uses ! i = Some tt + | None => False + end. +Proof. + induction l; simpl; trivial. + intros. + apply IHl; trivial. + destruct (@PTree.get (PTree.t unit) a sets) eqn:SETSA; trivial. + pose proof (PTree.bempty_canon_correct (PTree.remove dst t)) as CORRECT. + specialize CORRECT with (i := i). + destruct (PTree.bempty_canon (PTree.remove dst t)). + - rewrite PTree.gro in CORRECT by congruence. + destruct (peq a j). + + subst a. + rewrite SETSA in *. + intuition congruence. + + rewrite PTree.gro by congruence. + assumption. + - destruct (peq a j). + + subst a. + rewrite SETSA in *. + rewrite PTree.gss. + rewrite PTree.gro by congruence. + assumption. + + rewrite PTree.gso by congruence. + assumption. +Qed. +Local Hint Resolve remove_from_sets_pass : wellformed. + +Lemma rem_comes_from: + forall A x y (tr: PTree.t A) v, + (PTree.remove x tr) ! y = Some v -> tr ! y = Some v. +Proof. + intros. + destruct (peq x y). + - subst y. + rewrite PTree.grs in *. + discriminate. + - rewrite PTree.gro in * by congruence. + assumption. +Qed. +Local Hint Resolve rem_comes_from : wellformed. + +Lemma rem_ineq: + forall A x y (tr: PTree.t A) v, + (PTree.remove x tr) ! y = Some v -> x<>y. +Proof. + intros. + intro. + subst y. + rewrite PTree.grs in *. + discriminate. +Qed. +Local Hint Resolve rem_ineq : wellformed. + +Lemma wellformed_reg_kill_reg: + forall dst rel, + (wellformed_reg rel) -> (wellformed_reg (kill_reg dst rel)). +Proof. + unfold wellformed_reg, kill_reg. + simpl. + intros dst rel Hrel. + intros i j sv KILLREG KILLABLE. + + rewrite PTree.gfilter1 in KILLREG. + destruct PTree.get eqn:REMi in KILLREG. + 2: discriminate. + destruct negb eqn:NEGB in KILLREG. + 2: discriminate. + inv KILLREG. + + assert ((var_to_sym rel) ! i = Some sv) as RELi by eauto with wellformed. + + destruct (peq dst j). + { (* absurd case *) + subst j. + rewrite KILLABLE in NEGB. + simpl in NEGB. + discriminate. + } + specialize Hrel with (i := i) (j := j) (sv := sv). + destruct ((var_to_sym rel) ! dst) eqn:DST; simpl. + { + destruct (in_or_not j (referenced_by s)). + { assert (dst <> i) by eauto with wellformed. + apply remove_from_sets_pass. + congruence. + rewrite PTree.gro by congruence. + apply Hrel; trivial. + } + rewrite remove_from_sets_notin by assumption. + rewrite PTree.gro by congruence. + apply Hrel; trivial. + } + rewrite PTree.gro by congruence. + apply Hrel; trivial. +Qed. + Lemma wellformed_mem_kill_mem: forall rel, (wellformed_mem rel) -> (wellformed_mem (kill_mem rel)). -- cgit From bc89c7487901c6056c84bf598ea4ab6535de68c2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Feb 2020 17:27:57 +0100 Subject: wellformed_reg_kill_reg simpliied --- backend/CSE2proof.v | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index e62e2ae6..3799e38b 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -317,14 +317,9 @@ Proof. specialize Hrel with (i := i) (j := j) (sv := sv). destruct ((var_to_sym rel) ! dst) eqn:DST; simpl. { - destruct (in_or_not j (referenced_by s)). - { assert (dst <> i) by eauto with wellformed. - apply remove_from_sets_pass. - congruence. - rewrite PTree.gro by congruence. - apply Hrel; trivial. - } - rewrite remove_from_sets_notin by assumption. + assert (dst <> i) by eauto with wellformed. + apply remove_from_sets_pass. + congruence. rewrite PTree.gro by congruence. apply Hrel; trivial. } -- cgit From 27b985393cd8d90a3d6f5e9f13bdf90e4300bb8e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Feb 2020 17:28:21 +0100 Subject: rm useless admitted lemma --- backend/CSE2proof.v | 5 ----- 1 file changed, 5 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 3799e38b..4d503f90 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -204,11 +204,6 @@ Proof. Qed. Local Hint Resolve kill_sym_val_referenced : wellformed. -Lemma in_or_not: - forall (x : reg) l, - (In x l) \/ ~(In x l). -Admitted. - Lemma remove_from_sets_notin: forall dst l sets j, not (In j l) -> -- cgit From e4c7ff447ad30832c42ee51f0fe7e1cf62d2eee9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Feb 2020 17:34:03 +0100 Subject: wellformed_reg_kill_mem --- backend/CSE2proof.v | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 4d503f90..0d369e7a 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -321,7 +321,8 @@ Proof. rewrite PTree.gro by congruence. apply Hrel; trivial. Qed. - +Local Hint Resolve wellformed_reg_kill_reg : wellformed. + Lemma wellformed_mem_kill_mem: forall rel, (wellformed_mem rel) -> (wellformed_mem (kill_mem rel)). @@ -343,6 +344,21 @@ Proof. Qed. Local Hint Resolve wellformed_mem_kill_mem : wellformed. +Lemma wellformed_reg_kill_mem: + forall rel, + (wellformed_reg rel) -> (wellformed_reg (kill_mem rel)). +Proof. + unfold wellformed_reg, kill_mem. + simpl. + intros rel Hrel. + intros i j sv KILLMEM KILLABLE. + apply Hrel with (sv := sv); trivial. + rewrite PTree.gremove_t in KILLMEM. + destruct ((mem_used rel) ! i) in KILLMEM. + discriminate. + assumption. +Qed. + Lemma wellformed_mem_move: forall r dst rel, (wellformed_mem rel) -> (wellformed_mem (move r dst rel)). -- cgit From e35365927d1289687aaff6d7ca5ebee1ac09d249 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Feb 2020 17:40:02 +0100 Subject: add hint --- backend/CSE2proof.v | 1 + 1 file changed, 1 insertion(+) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 0d369e7a..0b92f5e5 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -358,6 +358,7 @@ Proof. discriminate. assumption. Qed. +Local Hint Resolve wellformed_reg_kill_mem : wellformed. Lemma wellformed_mem_move: forall r dst rel, -- cgit From 3e5fba812749b9240b655a99809e62231d1145aa Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 5 Feb 2020 18:31:20 +0100 Subject: Incorrect computation of extra stack size for vararg calls in RISC-V (#213) Currently, the extra size for the variable arguments is too small for the 64 bit RISC-V and the extra arguments are stored in the wrong stack slots. --- riscV/Asmexpand.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 3e734747..1df63308 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -483,7 +483,7 @@ let expand_instruction instr = emit (Pmv (X30, X2)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in - let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in + let extra_sz = if n >= 8 then 0 else align ((8 - n) * wordsize) 16 in let full_sz = Z.add sz (Z.of_uint extra_sz) in expand_addptrofs X2 X2 (Ptrofs.repr (Z.neg full_sz)); expand_storeind_ptr X30 X2 ofs; @@ -501,7 +501,7 @@ let expand_instruction instr = let extra_sz = if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in - if n >= 8 then 0 else align 16 ((8 - n) * wordsize) + if n >= 8 then 0 else align ((8 - n) * wordsize) 16 end else 0 in expand_addptrofs X2 X2 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) -- cgit From b0fdbb0e88d6decd068709ea673dbe51fd6727b0 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 5 Feb 2020 18:33:13 +0100 Subject: Support Coq 8.11.0 (#212) Update configure. Ignore and clean up .vok and .vos files, which Coq 8.11.0 generates. --- .gitignore | 2 ++ Changelog | 4 ++++ Makefile | 2 +- configure | 2 +- 4 files changed, 8 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 4b497387..da883cff 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ # Object files, in general *.vo +*.vok +*.vos *.glob *.o *.a diff --git a/Changelog b/Changelog index 935f77f2..08586da5 100644 --- a/Changelog +++ b/Changelog @@ -1,3 +1,7 @@ +Coq development: +- Compatibility with Coq version 8.11.0 (#316) + + Release 3.6, 2019-09-17 ======================= diff --git a/Makefile b/Makefile index 80eca80d..af069e3f 100644 --- a/Makefile +++ b/Makefile @@ -258,7 +258,7 @@ endif clean: - rm -f $(patsubst %, %/*.vo, $(DIRS)) + rm -f $(patsubst %, %/*.vo*, $(DIRS)) rm -f $(patsubst %, %/.*.aux, $(DIRS)) rm -rf doc/html doc/*.glob rm -f driver/Version.ml diff --git a/configure b/configure index b964c124..d91bfebf 100755 --- a/configure +++ b/configure @@ -530,7 +530,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.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1|8.10.2) + 8.8.0|8.8.1|8.8.2|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 6950ac8fb096768cb3811ae7f89d0db080bf965a Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 5 Feb 2020 18:36:08 +0100 Subject: Revised menhirLib autoconfiguration (#331) Since Menhir version 20200123, we need to link with menhirLib.cmxa instead of menhirLib.cmx. This commit chooses automatically the file to link with: menhirLib.cmxa if it exists in the menhirLib installation directory, menhirLib.cmx otherwise. To reliably find the installation directory, configure was changed to record the menhirLib directory in Makefile.config, variable MENHIR_DIR, instead of a pre-cooked command-line option MENHIR_INCLUDES. Makefile.extr was adapted accordingly. Fixes: #329 Closes: #330 --- Makefile.extr | 2 +- Makefile.menhir | 6 +++++- configure | 6 +++--- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/Makefile.extr b/Makefile.extr index d375fd29..7b59ed24 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -55,7 +55,7 @@ extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60 cparser/pre_parser.cmx: WARNINGS += -w -41 cparser/pre_parser.cmo: WARNINGS += -w -41 -COMPFLAGS+=-g $(INCLUDES) $(MENHIR_INCLUDES) $(WARNINGS) +COMPFLAGS+=-g $(INCLUDES) -I "$(MENHIR_DIR)" $(WARNINGS) # Using .opt compilers if available diff --git a/Makefile.menhir b/Makefile.menhir index 98bfc750..7909b2f6 100644 --- a/Makefile.menhir +++ b/Makefile.menhir @@ -41,7 +41,11 @@ MENHIR_FLAGS = -v --no-stdlib -la 1 # Using Menhir in --table mode requires MenhirLib. ifeq ($(MENHIR_TABLE),true) - MENHIR_LIBS = menhirLib.cmx + ifeq ($(wildcard $(MENHIR_DIR)/menhirLib.cmxa),) + MENHIR_LIBS = menhirLib.cmx + else + MENHIR_LIBS = menhirLib.cmxa + endif else MENHIR_LIBS = endif diff --git a/configure b/configure index d91bfebf..a8efb551 100755 --- a/configure +++ b/configure @@ -582,8 +582,8 @@ case "$menhir_ver" in 20[0-9][0-9][0-9][0-9][0-9][0-9]) if test "$menhir_ver" -ge $MENHIR_REQUIRED; then echo "version $menhir_ver -- good!" - menhir_include_dir=$(menhir --suggest-menhirLib | tr -d '\r' | tr '\\' '/') - if test -z "$menhir_include_dir"; then + menhir_dir=$(menhir --suggest-menhirLib | tr -d '\r' | tr '\\' '/') + if test -z "$menhir_dir"; then echo "Error: cannot determine the location of the Menhir API library." echo "This can be due to an incorrect Menhir package." echo "Consider using the OPAM package for Menhir." @@ -677,7 +677,7 @@ MANDIR=$sharedir/man SHAREDIR=$sharedir COQDEVDIR=$coqdevdir OCAML_OPT_COMP=$ocaml_opt_comp -MENHIR_INCLUDES=-I "$menhir_include_dir" +MENHIR_DIR=$menhir_dir COMPFLAGS=-bin-annot EOF -- cgit From 4f980e9903ddfb213247bf45015d486e36977383 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 6 Feb 2020 11:20:15 +0100 Subject: accessors for records are now not extracted it seems --- backend/Duplicateaux.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 84daa329..c3340cca 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -563,10 +563,10 @@ let rec invert_iconds code = function (* For now, identity function *) let duplicate_aux f = - let entrypoint = fn_entrypoint f in - let code = fn_code f in + let entrypoint = f.fn_entrypoint in + let code = f.fn_code in let traces = select_traces (to_ttl_code code entrypoint) entrypoint in let icond_code = invert_iconds code traces in let preds = get_predecessors_rtl icond_code in let (new_code, pTreeId) = (print_traces traces; superblockify_traces icond_code preds traces) in - ((new_code, (fn_entrypoint f)), pTreeId) + ((new_code, f.fn_entrypoint), pTreeId) -- cgit From 0c25f714e690681c50420a218dad518fbecdb42a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 11:48:30 +0100 Subject: Fixed using ccomp assembly preprocessor --- runtime/mppa_k1c/vararg.S | 54 ----------------------------------------------- runtime/mppa_k1c/vararg.s | 54 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 54 insertions(+), 54 deletions(-) delete mode 100644 runtime/mppa_k1c/vararg.S create mode 100644 runtime/mppa_k1c/vararg.s diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S deleted file mode 100644 index 9e23e0b3..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/runtime/mppa_k1c/vararg.s b/runtime/mppa_k1c/vararg.s new file mode 100644 index 00000000..65c1eab8 --- /dev/null +++ b/runtime/mppa_k1c/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 + ;; -- cgit From ae8c21b078fda638b706d157e1b9a16e4bcc4ab7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 11:49:05 +0100 Subject: Breaking the prologue to satisfy resource constraints --- mppa_k1c/Asmexpand.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index d52bd485..8ab10bc5 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -514,8 +514,8 @@ let expand_instruction instr = end else begin let below = Integers.Ptrofs.repr (Z.neg sz) in expand_addptrofs stack_pointer stack_pointer below; + emit Psemi; (* Psemi required to fit in resource constraints *) expand_storeind_ptr stack_pointer stack_pointer (Integers.Ptrofs.add ofs below); - (* DM we don't need it emit Psemi; *) vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> -- cgit From 56240b6f831e3aeca751c718dace1fd42724749d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 12:06:46 +0100 Subject: Fixed reservation tables --- mppa_k1c/PostpassSchedulingOracle.ml | 90 ++++++++++++++++++------------------ 1 file changed, 46 insertions(+), 44 deletions(-) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index cdda0e6d..a97fda83 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -442,7 +442,7 @@ let encode_imm (imm:int64) = else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm (** Resources *) -let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"] +let resource_names = ["ISSUE"; "TINY"; "LITE"; "FULL"; "LSU"; "MAU"; "BCU"; "TCA"; "AUXR"; "AUXW"; "CRRP"; "CRWL"; "CRWH"; "NOP"] let rec find_index elt l = match l with @@ -457,31 +457,24 @@ let resource_bound resource : int = | "ISSUE" -> 8 | "TINY" -> 4 | "LITE" -> 2 - | "ALU" -> 1 + | "FULL" -> 1 | "LSU" -> 1 | "MAU" -> 1 | "BCU" -> 1 - | "ACC" -> 1 - | "DATA" -> 1 | "TCA" -> 1 - | "BRE" -> 1 - | "BRO" -> 1 + | "AUXR" -> 1 + | "AUXW" -> 1 + | "CRRP" -> 1 + | "CRWL" -> 1 + | "CRWH" -> 1 | "NOP" -> 4 | _ -> raise Not_found let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) (** Reservation tables *) -let alu_tiny : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 +let alu_full : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite : int array = let resmap = fun r -> match r with @@ -496,24 +489,20 @@ let alu_lite_y : int array = let resmap = fun r -> match r with | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let alu_full : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - let alu_nop : int array = let resmap = fun r -> match r with | "ISSUE" -> 1 | "NOP" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu : int array = let resmap = fun r -> match r with @@ -524,30 +513,43 @@ let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with | "ISSUE" -> 1 | "TINY" -> 2 | "MAU" -> 1 | "BCU" -> 1 | "NOP" -> 4 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxr : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxw : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxw_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let lsu_auxw_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let mau : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let mau_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) +let mau_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + + (** Real instructions *) exception InvalidEncoding @@ -612,13 +614,13 @@ let rec_to_usage r = | Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> - (match encoding with None | Some U6 | Some S10 -> lsu_data - | Some U27L5 | Some U27L10 -> lsu_data_x - | Some E27U27L10 -> lsu_data_y) + (match encoding with None | Some U6 | Some S10 -> lsu_auxw + | Some U27L5 | Some U27L10 -> lsu_auxw_x + | Some E27U27L10 -> lsu_auxw_y) | Sb | Sh | Sw | Sd | Sq | So -> - (match encoding with None | Some U6 | Some S10 -> lsu_acc - | Some U27L5 | Some U27L10 -> lsu_acc_x - | Some E27U27L10 -> lsu_acc_y) + (match encoding with None | Some U6 | Some S10 -> lsu_auxr + | Some U27L5 | Some U27L10 -> lsu_auxr_x + | Some E27U27L10 -> lsu_auxr_y) | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu | Get -> bcu_tiny_tiny_mau_xnop | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd -- cgit From 4d0cc4318d6f46d9575ff7ebb1b74d8d8632ebb1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 12:18:53 +0100 Subject: Using Ocaml type instead of string to identify resources --- mppa_k1c/PostpassSchedulingOracle.ml | 71 ++++++++++++++++++------------------ 1 file changed, 36 insertions(+), 35 deletions(-) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index a97fda83..49cece02 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -442,7 +442,9 @@ let encode_imm (imm:int64) = else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm (** Resources *) -let resource_names = ["ISSUE"; "TINY"; "LITE"; "FULL"; "LSU"; "MAU"; "BCU"; "TCA"; "AUXR"; "AUXW"; "CRRP"; "CRWL"; "CRWH"; "NOP"] +type rname = Rissue | Rtiny | Rlite | Rfull | Rlsu | Rmau | Rbcu | Rtca | Rauxr | Rauxw | Rcrrp | Rcrwl | Rcrwh | Rnop + +let resource_names = [Rissue; Rtiny; Rlite; Rfull; Rlsu; Rmau; Rbcu; Rtca; Rauxr; Rauxw; Rcrrp; Rcrwl; Rcrwh; Rnop] let rec find_index elt l = match l with @@ -454,99 +456,98 @@ let resource_id resource : int = find_index resource resource_names let resource_bound resource : int = match resource with - | "ISSUE" -> 8 - | "TINY" -> 4 - | "LITE" -> 2 - | "FULL" -> 1 - | "LSU" -> 1 - | "MAU" -> 1 - | "BCU" -> 1 - | "TCA" -> 1 - | "AUXR" -> 1 - | "AUXW" -> 1 - | "CRRP" -> 1 - | "CRWL" -> 1 - | "CRWH" -> 1 - | "NOP" -> 4 - | _ -> raise Not_found + | Rissue -> 8 + | Rtiny -> 4 + | Rlite -> 2 + | Rfull -> 1 + | Rlsu -> 1 + | Rmau -> 1 + | Rbcu -> 1 + | Rtca -> 1 + | Rauxr -> 1 + | Rauxw -> 1 + | Rcrrp -> 1 + | Rcrwl -> 1 + | Rcrwh -> 1 + | Rnop -> 4 let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) (** Reservation tables *) let alu_full : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | Rfull -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_nop : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "NOP" -> 1 | _ -> 0 + | Rissue -> 1 | Rnop -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_tiny : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_tiny_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_tiny_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "BCU" -> 1 | _ -> 0 + | Rissue -> 1 | Rbcu -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 2 | "MAU" -> 1 | "BCU" -> 1 | "NOP" -> 4 | _ -> 0 + | Rissue -> 1 | Rtiny -> 2 | Rmau -> 1 | Rbcu -> 1 | Rnop -> 4 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let mau : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let mau_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let mau_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -- cgit From fadf090fcc33d9d5aabde1cb1f2c5116302427a4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 14:30:28 +0100 Subject: Fixing maddw and maddd resource tables --- mppa_k1c/PostpassSchedulingOracle.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 49cece02..686979a6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -550,6 +550,17 @@ let mau_y : int array = let resmap = fun r -> match r with | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) +let mau_auxr : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) (** Real instructions *) @@ -602,10 +613,16 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) - | Mulw| Maddw | Msbfw -> (match encoding with None -> mau + | Maddw -> (match encoding with None -> mau_auxr + | Some U6 | Some S10 | Some U27L5 -> mau_auxr_x + | _ -> raise InvalidEncoding) + | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau_auxr + | Some U27L5 | Some U27L10 -> mau_auxr_x + | Some E27U27L10 -> mau_auxr_y) + | Mulw| Msbfw -> (match encoding with None -> mau | Some U6 | Some S10 | Some U27L5 -> mau_x | _ -> raise InvalidEncoding) - | Muld | Maddd | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau + | Muld | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop -- cgit From d5435a34169d92a96f1436128f3e90df7f4f9e9a Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 6 Feb 2020 17:27:05 +0100 Subject: Compatibility with OCaml 4.10 (#214) debug/DwarfPrinter.mli: unused functor parameter trigger warning 69, replace by non-dependent functor type. Makefile.extr: turn warning 69 (unused functor parameter) off for extracted code configure: accept OCaml versions above 4.09 configure: update messages for unsupported versions of OCaml and Coq --- Makefile.extr | 4 ++-- configure | 8 ++++---- debug/DwarfPrinter.mli | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Makefile.extr b/Makefile.extr index 7b59ed24..5948bfc6 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -50,8 +50,8 @@ INCLUDES=$(patsubst %,-I %, $(DIRS)) # Control of warnings: WARNINGS=-w +a-4-9-27 -strict-sequence -safe-string -warn-error +a #Deprication returns with ocaml 4.03 -extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60 -extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60 +extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 +extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 cparser/pre_parser.cmx: WARNINGS += -w -41 cparser/pre_parser.cmo: WARNINGS += -w -41 diff --git a/configure b/configure index a8efb551..6bd7ed0e 100755 --- a/configure +++ b/configure @@ -537,7 +537,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.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.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" missingtools=true fi;; "") @@ -553,15 +553,15 @@ case "$ocaml_ver" in echo "version $ocaml_ver -- UNSUPPORTED" echo "Error: CompCert requires OCaml version 4.05 or later." missingtools=true;; - 4.0*) + 4.*) echo "version $ocaml_ver -- good!";; ?.*) echo "version $ocaml_ver -- UNSUPPORTED" - echo "Error: CompCert requires OCaml version 4.02 or later." + echo "Error: CompCert requires OCaml version 4.05 or later." missingtools=true;; *) echo "NOT FOUND" - echo "Error: make sure OCaml version 4.02 or later is installed." + echo "Error: make sure OCaml version 4.05 or later is installed." missingtools=true;; esac diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index e1e10601..78dc05fb 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -12,7 +12,7 @@ open DwarfTypes -module DwarfPrinter: functor (Target: DWARF_TARGET) -> +module DwarfPrinter: DWARF_TARGET -> sig val print_debug: out_channel -> debug_entries -> unit end -- cgit From 6ca9f9bfc7119f1ca4f48de3b5a37cbaee07e4fd Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 6 Feb 2020 14:55:34 +0100 Subject: Added base address if needed. Ranges of locations are relative to some base address. Most times this is just the same as the compilation unit. However if the compilation unit contains functions in multiple sections we need to add a base address of the section that the locations are contained. --- debug/DwarfPrinter.ml | 45 +++++++++++++++++++++++++-------------------- debug/DwarfTypes.mli | 25 +++++++++++++++++-------- debug/Dwarfgen.ml | 16 +++++++++++----- 3 files changed, 53 insertions(+), 33 deletions(-) diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 9a24041b..2cb8c7d9 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -602,8 +602,13 @@ module DwarfPrinter(Target: DWARF_TARGET): print_sleb128 oc "" 0; print_label oc debug_end (* End of the debug section *) - let print_location_entry oc c_low l = + let print_location_entry oc needs_base c_low l = print_label oc (loc_to_label l.loc_id); + (* If we have multiple ranges per compilation unit we need to specify a base address for the location *) + if needs_base then begin + fprintf oc " %s -1\n" address; + fprintf oc " %s %a\n" address label c_low; + end; List.iter (fun (b,e,loc) -> fprintf oc " %s %a-%a\n" address label b label c_low; fprintf oc " %s %a-%a\n" address label e label c_low; @@ -621,11 +626,11 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " %s 0\n" address - let print_location_list oc (c_low,l) = - let f = match c_low with - | Some s -> print_location_entry oc s - | None -> print_location_entry_abs oc in - List.iter f l + let print_location_list oc needs_base l = + let f l = match l.loc_sec_begin with + | Some s -> print_location_entry oc needs_base s l + | None -> print_location_entry_abs oc l in + List.iter f l let list_opt l f = match l with @@ -635,15 +640,15 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_diab_entries oc entries = let abbrev_start = new_label () in abbrev_start_addr := abbrev_start; - List.iter (fun e -> compute_abbrev e.entry) entries; + List.iter (fun e -> compute_abbrev e.diab_entry) entries; print_abbrev oc; List.iter (fun e -> let name = if e.section_name <> ".text" then Some e.section_name else None in section oc (Section_debug_info name); - print_debug_info oc e.start_label e.line_label e.entry) entries; - if List.exists (fun e -> match e.dlocs with _,[] -> false | _,_ -> true) entries then begin + print_debug_info oc e.start_label e.line_label e.diab_entry) entries; + if List.exists (fun e -> match e.diab_locs with [] -> false | _ -> true) entries then begin section oc Section_debug_loc; - List.iter (fun e -> print_location_list oc e.dlocs) entries + List.iter (fun e -> print_location_list oc false e.diab_locs) entries end let print_ranges oc r = @@ -665,8 +670,8 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " %s 0\n" address; fprintf oc " %s 0\n" address) r - let print_gnu_entries oc cp (lpc,loc) s r = - compute_abbrev cp; + let print_gnu_entries oc entries = + compute_abbrev entries.gnu_entry; let line_start = new_label () and start = new_label () and abbrev_start = new_label () @@ -674,18 +679,18 @@ module DwarfPrinter(Target: DWARF_TARGET): debug_ranges_addr := range_label; abbrev_start_addr := abbrev_start; section oc (Section_debug_info None); - print_debug_info oc start line_start cp; + print_debug_info oc start line_start entries.gnu_entry; print_abbrev oc; - list_opt loc (fun () -> + list_opt entries.gnu_locs (fun () -> section oc Section_debug_loc; - print_location_list oc (lpc,loc)); - list_opt r (fun () -> - print_ranges oc r); + print_location_list oc entries.several_secs entries.gnu_locs); + list_opt entries.range_table (fun () -> + print_ranges oc entries.range_table); section oc (Section_debug_line None); print_label oc line_start; - list_opt s (fun () -> + list_opt entries.string_table (fun () -> section oc Section_debug_str; - let s = List.sort (fun (a,_) (b,_) -> compare a b) s in + let s = List.sort (fun (a,_) (b,_) -> compare a b) entries.string_table in List.iter (fun (id,s) -> print_label oc (loc_to_label id); fprintf oc " .asciz %S\n" s) s) @@ -698,6 +703,6 @@ module DwarfPrinter(Target: DWARF_TARGET): Hashtbl.clear loc_labels; match debug with | Diab entries -> print_diab_entries oc entries - | Gnu (cp,loc,s,r) -> print_gnu_entries oc cp loc s r + | Gnu entries -> print_gnu_entries oc entries end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 5a2bce3b..567c65cd 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -266,11 +266,13 @@ type dw_entry = (* The type for the location list. *) type location_entry = - { - loc: (address * address * location_value) list; - loc_id: reference; - } -type dw_locations = constant option * location_entry list + { + loc: (address * address * location_value) list; + loc_id: reference; + loc_sec_begin : address option; + } + +type dw_locations = location_entry list type range_entry = | AddressRange of (address * address) list @@ -285,13 +287,20 @@ type diab_entry = section_name: string; start_label: int; line_label: int; - entry: dw_entry; - dlocs: dw_locations; + diab_entry: dw_entry; + diab_locs: dw_locations; } type diab_entries = diab_entry list -type gnu_entries = dw_entry * dw_locations * dw_string * dw_ranges +type gnu_entries = + { + string_table: dw_string; + range_table: dw_ranges; + gnu_locs: dw_locations; + gnu_entry: dw_entry; + several_secs: bool; + } type debug_entries = | Diab of diab_entries diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index e1b71f13..6c1d0846 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -408,7 +408,7 @@ module Dwarfgenaux (Target: TARGET) = and lo = translate_label f_id lo in hi,lo,range_entry_loc i.var_loc) l in let id = next_id () in - Some (LocRef id),[{loc = l;loc_id = id;}] + Some (LocRef id),[{loc_sec_begin = !current_section_start; loc = l;loc_id = id;}] end with Not_found -> None,[] else @@ -574,8 +574,8 @@ let diab_gen_compilation_section sec_name s defs acc = section_name = s; start_label = debug_start; line_label = line_start; - entry = cp; - dlocs = Some low_pc,accu.locs; + diab_entry = cp; + diab_locs = accu.locs; }::acc let gen_diab_debug_info sec_name var_section : debug_entries = @@ -643,6 +643,12 @@ let gen_gnu_debug_info sec_name var_section : debug_entries = } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in let cp = add_children cp (types@defs) in - let loc_pc = if StringSet.cardinal sec > 1 then None else low_pc in let string_table = Hashtbl.fold (fun s i acc -> (i,s)::acc) string_table [] in - Gnu (cp,(loc_pc,accu.locs),string_table,snd accu.ranges) + let cp = { + string_table = string_table; + range_table = snd accu.ranges; + gnu_locs = accu.locs; + gnu_entry = cp; + several_secs = StringSet.cardinal sec > 1} + in + Gnu cp -- cgit From 1b6667cf268189104bc3320e83fa23fe0d053717 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 7 Feb 2020 14:29:32 +0100 Subject: stubs to keep compiling on architectures not K1c --- aarch64/DuplicateOpcodeHeuristic.ml | 3 +++ arm/DuplicateOpcodeHeuristic.ml | 3 +++ powerpc/DuplicateOpcodeHeuristic.ml | 3 +++ riscV/DuplicateOpcodeHeuristic.ml | 3 +++ x86/DuplicateOpcodeHeuristic.ml | 3 +++ 5 files changed, 15 insertions(+) create mode 100644 aarch64/DuplicateOpcodeHeuristic.ml create mode 100644 arm/DuplicateOpcodeHeuristic.ml create mode 100644 powerpc/DuplicateOpcodeHeuristic.ml create mode 100644 riscV/DuplicateOpcodeHeuristic.ml create mode 100644 x86/DuplicateOpcodeHeuristic.ml diff --git a/aarch64/DuplicateOpcodeHeuristic.ml b/aarch64/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..85505245 --- /dev/null +++ b/aarch64/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,3 @@ +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = () diff --git a/arm/DuplicateOpcodeHeuristic.ml b/arm/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..85505245 --- /dev/null +++ b/arm/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,3 @@ +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = () diff --git a/powerpc/DuplicateOpcodeHeuristic.ml b/powerpc/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..85505245 --- /dev/null +++ b/powerpc/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,3 @@ +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = () diff --git a/riscV/DuplicateOpcodeHeuristic.ml b/riscV/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..85505245 --- /dev/null +++ b/riscV/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,3 @@ +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = () diff --git a/x86/DuplicateOpcodeHeuristic.ml b/x86/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..85505245 --- /dev/null +++ b/x86/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,3 @@ +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = () -- cgit From 9a58ce92702efdca3cb756c9edd59596e293fba1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 8 Feb 2020 22:07:31 +0100 Subject: why did we remove the ppc runtime ?! --- runtime/powerpc/i64_dtos.s | 100 ++++++++++++++++++ runtime/powerpc/i64_dtou.s | 92 +++++++++++++++++ runtime/powerpc/i64_sar.s | 60 +++++++++++ runtime/powerpc/i64_sdiv.s | 71 +++++++++++++ runtime/powerpc/i64_shl.s | 64 ++++++++++++ runtime/powerpc/i64_shr.s | 65 ++++++++++++ runtime/powerpc/i64_smod.s | 70 +++++++++++++ runtime/powerpc/i64_smulh.s | 80 +++++++++++++++ runtime/powerpc/i64_stod.s | 67 ++++++++++++ runtime/powerpc/i64_stof.s | 68 ++++++++++++ runtime/powerpc/i64_udiv.s | 54 ++++++++++ runtime/powerpc/i64_udivmod.s | 234 ++++++++++++++++++++++++++++++++++++++++++ runtime/powerpc/i64_umod.s | 47 +++++++++ runtime/powerpc/i64_umulh.s | 65 ++++++++++++ runtime/powerpc/i64_utod.s | 66 ++++++++++++ runtime/powerpc/i64_utof.s | 64 ++++++++++++ runtime/powerpc/vararg.s | 163 +++++++++++++++++++++++++++++ 17 files changed, 1430 insertions(+) create mode 100644 runtime/powerpc/i64_dtos.s create mode 100644 runtime/powerpc/i64_dtou.s create mode 100644 runtime/powerpc/i64_sar.s create mode 100644 runtime/powerpc/i64_sdiv.s create mode 100644 runtime/powerpc/i64_shl.s create mode 100644 runtime/powerpc/i64_shr.s create mode 100644 runtime/powerpc/i64_smod.s create mode 100644 runtime/powerpc/i64_smulh.s create mode 100644 runtime/powerpc/i64_stod.s create mode 100644 runtime/powerpc/i64_stof.s create mode 100644 runtime/powerpc/i64_udiv.s create mode 100644 runtime/powerpc/i64_udivmod.s create mode 100644 runtime/powerpc/i64_umod.s create mode 100644 runtime/powerpc/i64_umulh.s create mode 100644 runtime/powerpc/i64_utod.s create mode 100644 runtime/powerpc/i64_utof.s create mode 100644 runtime/powerpc/vararg.s diff --git a/runtime/powerpc/i64_dtos.s b/runtime/powerpc/i64_dtos.s new file mode 100644 index 00000000..85c60b27 --- /dev/null +++ b/runtime/powerpc/i64_dtos.s @@ -0,0 +1,100 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Conversion from double float to signed long + + .balign 16 + .globl __compcert_i64_dtos +__compcert_i64_dtos: + stfdu f1, -16(r1) # extract LO (r4) and HI (r3) halves of double + lwz r3, 0(r1) + lwz r4, 4(r1) + addi r1, r1, 16 + srawi r10, r3, 31 # save sign of double in r10 + # extract unbiased exponent ((HI & 0x7FF00000) >> 20) - (1023 + 52) + rlwinm r5, r3, 12, 21, 31 + addi r5, r5, -1075 + # check range of exponent + cmpwi r5, -52 # if EXP < -52, abs(double) is < 1.0 + blt 1f + cmpwi r5, 11 # if EXP >= 63 - 52, abs(double) is >= 2^63 + bge 2f + # extract true mantissa + rlwinm r3, r3, 0, 12, 31 # HI &= ~0xFFF00000 + oris r3, r3, 0x10 # HI |= 0x00100000 + # shift it appropriately + cmpwi r5, 0 + blt 3f + # if EXP >= 0, shift left by EXP. Note that EXP < 11. + subfic r6, r5, 32 # r6 = 32 - EXP + slw r3, r3, r5 + srw r0, r4, r6 + or r3, r3, r0 + slw r4, r4, r5 + b 4f + # if EXP < 0, shift right by -EXP. Note that -EXP <= 52 but can be >= 32. +3: subfic r5, r5, 0 # r5 = -EXP = shift amount + subfic r6, r5, 32 # r6 = 32 - amount + addi r7, r5, -32 # r7 = amount - 32 (see i64_shr.s) + srw r4, r4, r5 + slw r0, r3, r6 + or r4, r4, r0 + srw r0, r3, r7 + or r4, r4, r0 + srw r3, r3, r5 + # apply sign to result +4: xor r4, r4, r10 + xor r3, r3, r10 + subfc r4, r10, r4 + subfe r3, r10, r3 + blr + # Special cases +1: li r3, 0 # result is 0 + li r4, 0 + blr +2: li r4, -1 # result is MAX_SINT or MIN_SINT + bge 5f # depending on sign + li r4, -1 # result is MAX_SINT = 0x7FFF_FFFF + srwi r3, r4, 1 + blr +5: lis r3, 0x8000 # result is MIN_SINT = 0x8000_0000 + li r4, 0 + blr + .type __compcert_i64_dtos, @function + .size __compcert_i64_dtos, .-__compcert_i64_dtos + \ No newline at end of file diff --git a/runtime/powerpc/i64_dtou.s b/runtime/powerpc/i64_dtou.s new file mode 100644 index 00000000..67a721d4 --- /dev/null +++ b/runtime/powerpc/i64_dtou.s @@ -0,0 +1,92 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Conversion from double float to unsigned long + + .balign 16 + .globl __compcert_i64_dtou +__compcert_i64_dtou: + stfdu f1, -16(r1) # extract LO (r4) and HI (r3) halves of double + lwz r3, 0(r1) + lwz r4, 4(r1) + addi r1, r1, 16 + cmpwi r3, 0 # is double < 0? + blt 1f # then it converts to 0 + # extract unbiased exponent ((HI & 0x7FF00000) >> 20) - (1023 + 52) + rlwinm r5, r3, 12, 21, 31 + addi r5, r5, -1075 + # check range of exponent + cmpwi r5, -52 # if EXP < -52, double is < 1.0 + blt 1f + cmpwi r5, 12 # if EXP >= 64 - 52, double is >= 2^64 + bge 2f + # extract true mantissa + rlwinm r3, r3, 0, 12, 31 # HI &= ~0xFFF00000 + oris r3, r3, 0x10 # HI |= 0x00100000 + # shift it appropriately + cmpwi r5, 0 + blt 3f + # if EXP >= 0, shift left by EXP. Note that EXP < 12. + subfic r6, r5, 32 # r6 = 32 - EXP + slw r3, r3, r5 + srw r0, r4, r6 + or r3, r3, r0 + slw r4, r4, r5 + blr + # if EXP < 0, shift right by -EXP. Note that -EXP <= 52 but can be >= 32. +3: subfic r5, r5, 0 # r5 = -EXP = shift amount + subfic r6, r5, 32 # r6 = 32 - amount + addi r7, r5, -32 # r7 = amount - 32 (see i64_shr.s) + srw r4, r4, r5 + slw r0, r3, r6 + or r4, r4, r0 + srw r0, r3, r7 + or r4, r4, r0 + srw r3, r3, r5 + blr + # Special cases +1: li r3, 0 # result is 0 + li r4, 0 + blr +2: li r3, -1 # result is MAX_UINT + li r4, -1 + blr + .type __compcert_i64_dtou, @function + .size __compcert_i64_dtou, .-__compcert_i64_dtou + + \ No newline at end of file diff --git a/runtime/powerpc/i64_sar.s b/runtime/powerpc/i64_sar.s new file mode 100644 index 00000000..c7da448f --- /dev/null +++ b/runtime/powerpc/i64_sar.s @@ -0,0 +1,60 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +# Shift right signed + + .balign 16 + .globl __compcert_i64_sar +__compcert_i64_sar: + andi. r5, r5, 63 # take amount modulo 64 + cmpwi r5, 32 + bge 1f # amount < 32? + subfic r6, r5, 32 # r6 = 32 - amount + srw r4, r4, r5 # RH = XH >>s amount + slw r0, r3, r6 # RL = XL >>u amount | XH << (32 - amount) + or r4, r4, r0 + sraw r3, r3, r5 + blr +1: addi r6, r5, -32 # amount >= 32 + sraw r4, r3, r6 # RL = XH >>s (amount - 32) + srawi r3, r3, 31 # RL = sign extension of XH + blr + .type __compcert_i64_sar, @function + .size __compcert_i64_sar, .-__compcert_i64_sar + + \ No newline at end of file diff --git a/runtime/powerpc/i64_sdiv.s b/runtime/powerpc/i64_sdiv.s new file mode 100644 index 00000000..9787ea3b --- /dev/null +++ b/runtime/powerpc/i64_sdiv.s @@ -0,0 +1,71 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Signed division + + .balign 16 + .globl __compcert_i64_sdiv +__compcert_i64_sdiv: + mflr r0 + stw r0, 4(r1) # save return address in caller's frame + xor r0, r3, r5 # compute sign of result (top bit) + mtctr r0 # save it in CTR (why not?) + srawi r0, r3, 31 # take absolute value of N + xor r4, r4, r0 # (i.e. N = N ^ r0 - r0, + xor r3, r3, r0 # where r0 = 0 if N >= 0 and r0 = -1 if N < 0) + subfc r4, r0, r4 + subfe r3, r0, r3 + srawi r0, r5, 31 # take absolute value of D + xor r6, r6, r0 # (same trick) + xor r5, r5, r0 + subfc r6, r0, r6 + subfe r5, r0, r5 + bl __compcert_i64_udivmod # do unsigned division + lwz r0, 4(r1) + mtlr r0 # restore return address + mfctr r0 + srawi r0, r0, 31 # apply expected sign to quotient + xor r6, r6, r0 # RES = Q if CTR >= 0, -Q if CTR < 0 + xor r5, r5, r0 + subfc r4, r0, r6 + subfe r3, r0, r5 + blr + .type __compcert_i64_sdiv, @function + .size __compcert_i64_sdiv, .-__compcert_i64_sdiv + + \ No newline at end of file diff --git a/runtime/powerpc/i64_shl.s b/runtime/powerpc/i64_shl.s new file mode 100644 index 00000000..f6edb6c2 --- /dev/null +++ b/runtime/powerpc/i64_shl.s @@ -0,0 +1,64 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +# Shift left + + .balign 16 + .globl __compcert_i64_shl +__compcert_i64_shl: +# On PowerPC, shift instructions with amount mod 64 >= 32 return 0 +# hi = (hi << amount) | (lo >> (32 - amount)) | (lo << (amount - 32)) +# lo = lo << amount +# if 0 <= amount < 32: +# (amount - 32) mod 64 >= 32, hence lo << (amount - 32) == 0 +# if 32 <= amount < 64: +# lo << amount == 0 +# (32 - amount) mod 64 >= 32, hence lo >> (32 - amount) == 0 + andi. r5, r5, 63 # take amount modulo 64 + subfic r6, r5, 32 # r6 = 32 - amount + addi r7, r5, -32 # r7 = amount - 32 + slw r3, r3, r5 + srw r0, r4, r6 + or r3, r3, r0 + slw r0, r4, r7 + or r3, r3, r0 + slw r4, r4, r5 + blr + .type __compcert_i64_shl, @function + .size __compcert_i64_shl, .-__compcert_i64_shl + \ No newline at end of file diff --git a/runtime/powerpc/i64_shr.s b/runtime/powerpc/i64_shr.s new file mode 100644 index 00000000..b634aafd --- /dev/null +++ b/runtime/powerpc/i64_shr.s @@ -0,0 +1,65 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +# Shift right unsigned + + .balign 16 + .globl __compcert_i64_shr +__compcert_i64_shr: +# On PowerPC, shift instructions with amount mod 64 >= 32 return 0 +# lo = (lo >> amount) | (hi << (32 - amount)) | (hi >> (amount - 32)) +# hi = hi >> amount +# if 0 <= amount < 32: +# (amount - 32) mod 64 >= 32, hence hi >> (amount - 32) == 0 +# if 32 <= amount < 64: +# hi >> amount == 0 +# (32 - amount) mod 64 >= 32, hence hi << (32 - amount) == 0 + andi. r5, r5, 63 # take amount modulo 64 + subfic r6, r5, 32 # r6 = 32 - amount + addi r7, r5, -32 # r7 = amount - 32 + srw r4, r4, r5 + slw r0, r3, r6 + or r4, r4, r0 + srw r0, r3, r7 + or r4, r4, r0 + srw r3, r3, r5 + blr + .type __compcert_i64_shr, @function + .size __compcert_i64_shr, .-__compcert_i64_shr + + \ No newline at end of file diff --git a/runtime/powerpc/i64_smod.s b/runtime/powerpc/i64_smod.s new file mode 100644 index 00000000..6b4e1f89 --- /dev/null +++ b/runtime/powerpc/i64_smod.s @@ -0,0 +1,70 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +## Signed remainder + + .balign 16 + .globl __compcert_i64_smod +__compcert_i64_smod: + mflr r0 + stw r0, 4(r1) # save return address in caller's frame + mtctr r3 # save sign of result in CTR (sign of N) + srawi r0, r3, 31 # take absolute value of N + xor r4, r4, r0 # (i.e. N = N ^ r0 - r0, + xor r3, r3, r0 # where r0 = 0 if N >= 0 and r0 = -1 if N < 0) + subfc r4, r0, r4 + subfe r3, r0, r3 + srawi r0, r5, 31 # take absolute value of D + xor r6, r6, r0 # (same trick) + xor r5, r5, r0 + subfc r6, r0, r6 + subfe r5, r0, r5 + bl __compcert_i64_udivmod # do unsigned division + lwz r0, 4(r1) + mtlr r0 # restore return address + mfctr r0 + srawi r0, r0, 31 # apply expected sign to remainder + xor r4, r4, r0 # RES = R if CTR >= 0, -Q if CTR < 0 + xor r3, r3, r0 + subfc r4, r0, r4 + subfe r3, r0, r3 + blr + .type __compcert_i64_smod, @function + .size __compcert_i64_smod, .-__compcert_i64_smod + + \ No newline at end of file diff --git a/runtime/powerpc/i64_smulh.s b/runtime/powerpc/i64_smulh.s new file mode 100644 index 00000000..73393fce --- /dev/null +++ b/runtime/powerpc/i64_smulh.s @@ -0,0 +1,80 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris +# +# Copyright (c) 2016 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Signed multiply-high + +# Hacker's Delight section 8.3: +# - compute high 64 bits of the unsigned product X * Y (see i64_umulh.S) +# - subtract X if Y < 0 +# - subtract Y if X < 0 + + .balign 16 + .globl __compcert_i64_smulh +__compcert_i64_smulh: +# r7:r8:r9 accumulate bits 127:32 of the full unsigned product + mulhwu r9, r4, r6 # r9 = high half of XL.YL + mullw r0, r4, r5 # r0 = low half of XL.YH + addc r9, r9, r0 + mulhwu r0, r4, r5 # r0 = high half of XL.YH + addze r8, r0 + mullw r0, r3, r6 # r0 = low half of XH.YL + addc r9, r9, r0 + mulhwu r0, r3, r6 # r0 = high half of XH.YL + adde r8, r8, r0 + li r7, 0 + addze r7, r7 + mullw r0, r3, r5 # r0 = low half of XH.YH + addc r8, r8, r0 + mulhwu r0, r3, r5 # r0 = high half of XH.YH + adde r7, r7, r0 +# Here r7:r8 contains the high 64 bits of the unsigned product. +# Now, test signs and subtract if needed + srawi r0, r3, 31 # r0 = -1 if X < 0, r0 = 0 if X >= 0 + srawi r9, r5, 31 # r9 = -1 if Y < 0, r9 = 0 if Y >= 0 + and r3, r3, r9 # set X = 0 if Y >= 0 + and r4, r4, r9 + and r5, r5, r0 # set Y = 0 if X >= 0 + and r6, r6, r0 + subfc r8, r4, r8 # subtract X + subfe r7, r3, r7 + subfc r4, r6, r8 # subtract Y + subfe r3, r5, r7 + blr + .type __compcert_i64_smulh, @function + .size __compcert_i64_smulh, .-__compcert_i64_smulh + diff --git a/runtime/powerpc/i64_stod.s b/runtime/powerpc/i64_stod.s new file mode 100644 index 00000000..0c1ab720 --- /dev/null +++ b/runtime/powerpc/i64_stod.s @@ -0,0 +1,67 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + +### Conversion from signed long to double float + + .balign 16 + .globl __compcert_i64_stod +__compcert_i64_stod: + addi r1, r1, -16 + lis r5, 0x4330 + li r6, 0 + stw r5, 0(r1) + stw r4, 4(r1) # 0(r1) = 2^52 + (double) XL + stw r5, 8(r1) + stw r6, 12(r1) # 8(r1) = 2^52 + lfd f1, 0(r1) + lfd f2, 8(r1) + fsub f1, f1, f2 # f1 is XL (unsigned) as a double + lis r5, 0x4530 + lis r6, 0x8000 + stw r5, 0(r1) # 0(r1) = 2^84 + ((double)XH - 2^31) * 2^32 + add r3, r3, r6 + stw r3, 4(r1) + stw r5, 8(r1) # 8(r1) = 2^84 + 2^31 * 2^32 + stw r6, 12(r1) + lfd f2, 0(r1) + lfd f3, 8(r1) + fsub f2, f2, f3 # f2 is XH (signed) * 2^32 as a double + fadd f1, f1, f2 # add both to get result + addi r1, r1, 16 + blr + .type __compcert_i64_stod, @function + .size __compcert_i64_stod, .-__compcert_i64_stod + diff --git a/runtime/powerpc/i64_stof.s b/runtime/powerpc/i64_stof.s new file mode 100644 index 00000000..97fa6bb8 --- /dev/null +++ b/runtime/powerpc/i64_stof.s @@ -0,0 +1,68 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Conversion from signed long to single float + + .balign 16 + .globl __compcert_i64_stof +__compcert_i64_stof: + mflr r9 + # Check whether -2^53 <= X < 2^53 + srawi r5, r3, 31 + srawi r6, r3, 21 # (r5,r6) = X >> 53 + addic r6, r6, 1 + addze r5, r5 # (r5,r6) = (X >> 53) + 1 + cmplwi r5, 2 + blt 1f + # X is large enough that double rounding can occur. + # Avoid it by nudging X away from the points where double rounding + # occurs (the "round to odd" technique) + rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X + addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF + # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-31 of r0 are 0 + or r4, r4, r0 # correct bit number 12 of X + rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X + # Convert to double, then round to single +1: bl __compcert_i64_stod + mtlr r9 + frsp f1, f1 + blr + .type __compcert_i64_stof, @function + .size __compcert_i64_stof, .-__compcert_i64_stof + diff --git a/runtime/powerpc/i64_udiv.s b/runtime/powerpc/i64_udiv.s new file mode 100644 index 00000000..e2da855a --- /dev/null +++ b/runtime/powerpc/i64_udiv.s @@ -0,0 +1,54 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Unsigned division + + .balign 16 + .globl __compcert_i64_udiv +__compcert_i64_udiv: + mflr r0 + stw r0, 4(r1) # save return address in caller's frame + bl __compcert_i64_udivmod # unsigned divide + lwz r0, 4(r1) + mtlr r0 # restore return address + mr r3, r5 # result = quotient + mr r4, r6 + blr + .type __compcert_i64_udiv, @function + .size __compcert_i64_udiv, .-__compcert_i64_udiv + diff --git a/runtime/powerpc/i64_udivmod.s b/runtime/powerpc/i64_udivmod.s new file mode 100644 index 00000000..e81c6cef --- /dev/null +++ b/runtime/powerpc/i64_udivmod.s @@ -0,0 +1,234 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +# Unsigned division and modulus + +# This function computes both the quotient and the remainder of two +# unsigned 64-bit integers. + +# Input: numerator N in (r3,r4), divisor D in (r5,r6) +# Output: quotient Q in (r5,r6), remainder R in (r3,r4) +# Destroys: all integer caller-save registers + + .globl __compcert_i64_udivmod + .balign 16 +__compcert_i64_udivmod: + cmplwi r5, 0 # DH == 0 ? + stwu r1, -32(r1) + mflr r0 + stw r0, 8(r1) + stw r31, 12(r1) + beq 1f +# The general case + stw r30, 16(r1) + stw r29, 20(r1) + stw r28, 24(r1) + mr r28, r3 # Save N in (r28, r29) + mr r29, r4 + mr r30, r5 # Save D in (r30, r31) + mr r31, r6 + # Scale N and D down, giving N' and D', such that 2^31 <= D' < 2^32 + cntlzw r7, r5 # r7 = leading zeros in DH = 32 - shift amount + subfic r8, r7, 32 # r8 = shift amount + slw r0, r3, r7 # N' = N >> shift amount + srw r3, r3, r8 + srw r4, r4, r8 + or r4, r4, r0 + slw r0, r5, r7 # D' = D >> shift amount + srw r6, r6, r8 + or r5, r6, r0 + # Divide N' by D' to get an approximate quotient Q + bl __compcert_i64_udiv6432 # r3 = quotient, r4 = remainder + mr r6, r3 # low half of quotient Q + li r5, 0 # high half of quotient is 0 + # Tentative quotient is either correct or one too high + # Compute Q * D in (r7, r8) +4: mullw r7, r6, r30 # r7 = Q * DH + mullw r8, r6, r31 # r8 = low 32 bits of Q * DL + mulhwu r0, r6, r31 # r0 = high 32 bits of Q * DL + addc r7, r7, r0 + subfe. r0, r0, r0 # test carry: EQ iff carry + beq 2f # handle overflow case + # Compute R = N - Q * D, with borrow + subfc r4, r8, r29 + subfe r3, r7, r28 + subfe. r0, r0, r0 # test borrow: EQ iff no borrow + beq 3f # no borrow: N >= Q * D, we are good + addi r6, r6, -1 # borrow: adjust Q down by 1 + addc r4, r4, r31 # and R up by D + adde r3, r3, r30 + # Finished +3: lwz r0, 8(r1) + mtlr r0 + lwz r31, 12(r1) + lwz r30, 16(r1) + lwz r29, 20(r1) + lwz r28, 24(r1) + addi r1, r1, 32 + blr + # Special case when Q * D overflows +2: addi r6, r6, -1 # adjust Q down by 1 + b 4b # and redo computation and check of remainder + .balign 16 +# Special case 64 bits divided by 32 bits +1: cmplwi r3, 0 # NH == 0? + beq 4f + divwu r31, r3, r6 # Divide NH by DL, quotient QH in r31 + mullw r0, r31, r6 + subf r3, r0, r3 # NH is remainder of this division + mr r5, r6 + bl __compcert_i64_udiv6432 # divide NH : NL by DL + mr r5, r31 # high word of quotient + mr r6, r3 # low word of quotient + # r4 contains low word of remainder + li r3, 0 # high word of remainder = 0 + lwz r0, 8(r1) + mtlr r0 + lwz r31, 12(r1) + addi r1, r1, 32 + blr + .balign 16 +# Special case 32 bits divided by 32 bits +4: mr r0, r6 + divwu r6, r4, r6 # low word of quotient + li r5, 0 # high word of quotient is 0 + mullw r0, r6, r0 + subf r4, r0, r4 # low word of remainder + li r3, 0 # high word of remainder is 0 + addi r1, r1, 32 + blr + + .type __compcert_i64_udivmod, @function + .size __compcert_i64_udivmod, .-__compcert_i64_udivmod + +# Auxiliary division function: 64 bit integer divided by 32 bit integer +# Not exported +# Input: numerator N in (r3,r4), divisor D in r5 +# Output: quotient Q in r3, remainder R in r4 +# Destroys: all integer caller-save registers +# Assumes: high word of N is less than D + + .balign 16 +__compcert_i64_udiv6432: +# Algorithm 9.3 from Hacker's Delight, section 9.4 +# Initially: u1 in r3, u0 in r4, v in r5 +# s = __builtin_clz(v); + cntlzw r6, r5 # s in r6 +# v = v << s; + slw r5, r5, r6 +# vn1 = v >> 16; # vn1 in r7 + srwi r7, r5, 16 +# vn0 = v & 0xFFFF; # vn0 in r8 + rlwinm r8, r5, 0, 16, 31 +# un32 = (u1 << s) | (u0 >> 32 - s); + subfic r0, r6, 32 + srw r0, r4, r0 + slw r3, r3, r6 # u1 dies, un32 in r3 + or r3, r3, r0 +# un10 = u0 << s; + slw r4, r4, r6 # u0 dies, un10 in r4 +# un1 = un10 >> 16; + srwi r9, r4, 16 # un1 in r9 +# un0 = un10 & 0xFFFF; + rlwinm r4, r4, 0, 16, 31 # un10 dies, un0 in r4 +# q1 = un32/vn1; + divwu r10, r3, r7 # q in r10 +# rhat = un32 - q1*vn1; + mullw r0, r10, r7 + subf r11, r0, r3 # rhat in r11 +# again1: +1: +# if (q1 >= b || q1*vn0 > b*rhat + un1) { + cmplwi r10, 0xFFFF + bgt 2f + mullw r0, r10, r8 + slwi r12, r11, 16 + add r12, r12, r9 + cmplw r0, r12 + ble 3f +2: +# q1 = q1 - 1; + addi r10, r10, -1 +# rhat = rhat + vn1; + add r11, r11, r7 +# if (rhat < b) goto again1;} + cmplwi r11, 0xFFFF + ble 1b +3: +# un21 = un32*b + un1 - q1*v; + slwi r0, r3, 16 # un32 dies + add r9, r0, r9 # un1 dies + mullw r0, r10, r5 + subf r9, r0, r9 # un21 in r9 +# q0 = un21/vn1; + divwu r3, r9, r7 # q0 in r3 +# rhat = un21 - q0*vn1; + mullw r0, r3, r7 + subf r11, r0, r9 # rhat in r11 +# again2: +4: +# if (q0 >= b || q0*vn0 > b*rhat + un0) { + cmplwi r3, 0xFFFF + bgt 5f + mullw r0, r3, r8 + slwi r12, r11, 16 + add r12, r12, r4 + cmplw r0, r12 + ble 6f +5: +# q0 = q0 - 1; + addi r3, r3, -1 +# rhat = rhat + vn1; + add r11, r11, r7 +# if (rhat < b) goto again2;} + cmplwi r11, 0xFFFF + ble 4b +6: +# remainder = (un21*b + un0 - q0*v) >> s; + slwi r0, r9, 16 + add r4, r0, r4 # un0 dies, remainder in r4 + mullw r0, r3, r5 + subf r4, r0, r4 + srw r4, r4, r6 +# quotient = q1*b + q0; + slwi r0, r10, 16 + add r3, r0, r3 + blr + + .type __compcert_i64_udiv6432, @function + .size __compcert_i64_udiv6432,.-__compcert_i64_udiv6432 diff --git a/runtime/powerpc/i64_umod.s b/runtime/powerpc/i64_umod.s new file mode 100644 index 00000000..bf8d6121 --- /dev/null +++ b/runtime/powerpc/i64_umod.s @@ -0,0 +1,47 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Unsigned modulus + + .balign 16 + .globl __compcert_i64_umod +__compcert_i64_umod: + b __compcert_i64_udivmod + .type __compcert_i64_umod, @function + .size __compcert_i64_umod, .-__compcert_i64_umod + diff --git a/runtime/powerpc/i64_umulh.s b/runtime/powerpc/i64_umulh.s new file mode 100644 index 00000000..53b72948 --- /dev/null +++ b/runtime/powerpc/i64_umulh.s @@ -0,0 +1,65 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris +# +# Copyright (c) 2016 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Unsigned multiply-high + +# X * Y = 2^64 XH.YH + 2^32 (XH.YL + XL.YH) + XL.YL + + .balign 16 + .globl __compcert_i64_umulh +__compcert_i64_umulh: +# r7:r8:r9 accumulate bits 127:32 of the full product + mulhwu r9, r4, r6 # r9 = high half of XL.YL + mullw r0, r4, r5 # r0 = low half of XL.YH + addc r9, r9, r0 + mulhwu r0, r4, r5 # r0 = high half of XL.YH + addze r8, r0 + mullw r0, r3, r6 # r0 = low half of XH.YL + addc r9, r9, r0 + mulhwu r0, r3, r6 # r0 = high half of XH.YL + adde r8, r8, r0 + li r7, 0 + addze r7, r7 + mullw r0, r3, r5 # r0 = low half of XH.YH + addc r4, r8, r0 + mulhwu r0, r3, r5 # r0 = high half of XH.YH + adde r3, r7, r0 + blr + .type __compcert_i64_umulh, @function + .size __compcert_i64_umulh, .-__compcert_i64_umulh + diff --git a/runtime/powerpc/i64_utod.s b/runtime/powerpc/i64_utod.s new file mode 100644 index 00000000..69de6fdb --- /dev/null +++ b/runtime/powerpc/i64_utod.s @@ -0,0 +1,66 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Conversion from unsigned long to double float + + .balign 16 + .globl __compcert_i64_utod +__compcert_i64_utod: + addi r1, r1, -16 + lis r5, 0x4330 + li r6, 0 + stw r5, 0(r1) + stw r4, 4(r1) # 0(r1) = 2^52 + (double) XL + stw r5, 8(r1) + stw r6, 12(r1) # 8(r1) = 2^52 + lfd f1, 0(r1) + lfd f2, 8(r1) + fsub f1, f1, f2 # f1 is (double) XL + lis r5, 0x4530 + stw r5, 0(r1) # 0(r1) = 2^84 + (double) XH * 2^32 + stw r3, 4(r1) + stw r5, 8(r1) # 8(r1) = 2^84 + lfd f2, 0(r1) + lfd f3, 8(r1) + fsub f2, f2, f3 # f2 is XH * 2^32 as a double + fadd f1, f1, f2 # add both to get result + addi r1, r1, 16 + blr + .type __compcert_i64_utod, @function + .size __compcert_i64_utod, .-__compcert_i64_utod + diff --git a/runtime/powerpc/i64_utof.s b/runtime/powerpc/i64_utof.s new file mode 100644 index 00000000..cdb2f867 --- /dev/null +++ b/runtime/powerpc/i64_utof.s @@ -0,0 +1,64 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Conversion from unsigned long to single float + + .balign 16 + .globl __compcert_i64_utof +__compcert_i64_utof: + mflr r9 + # Check whether X < 2^53 + andis. r0, r3, 0xFFE0 # test bits 53...63 of X + beq 1f + # X is large enough that double rounding can occur. + # Avoid it by nudging X away from the points where double rounding + # occurs (the "round to odd" technique) + rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X + addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF + # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-31 of r0 are 0 + or r4, r4, r0 # correct bit number 12 of X + rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X + # Convert to double, then round to single +1: bl __compcert_i64_utod + mtlr r9 + frsp f1, f1 + blr + .type __compcert_i64_utof, @function + .size __compcert_i64_utof, .-__compcert_i64_utof + diff --git a/runtime/powerpc/vararg.s b/runtime/powerpc/vararg.s new file mode 100644 index 00000000..8d7e62c8 --- /dev/null +++ b/runtime/powerpc/vararg.s @@ -0,0 +1,163 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for variadic functions . IA32 version + +# typedef struct { +# unsigned char ireg; // index of next integer register +# unsigned char freg; // index of next FP register +# char * stk; // pointer to next argument in stack +# struct { +# int iregs[8]; +# double fregs[8]; +# } * regs; // pointer to saved register area +# } va_list[1]; +# +# unsigned int __compcert_va_int32(va_list ap); +# unsigned long long __compcert_va_int64(va_list ap); +# double __compcert_va_float64(va_list ap); + + .text + + .balign 16 + .globl __compcert_va_int32 +__compcert_va_int32: + # r3 = ap = address of va_list structure + lbz r4, 0(r3) # r4 = ap->ireg = next integer register + cmplwi r4, 8 + bge 1f + # Next argument was passed in an integer register + lwz r5, 8(r3) # r5 = ap->regs = base of saved register area + rlwinm r6, r4, 2, 0, 29 # r6 = r4 * 4 + addi r4, r4, 1 # increment ap->ireg + stb r4, 0(r3) + lwzx r3, r5, r6 # load argument in r3 + blr + # Next argument was passed on stack +1: lwz r5, 4(r3) # r5 = ap->stk = next argument passed on stack + addi r5, r5, 4 # advance ap->stk by 4 + stw r5, 4(r3) + lwz r3, -4(r5) # load argument in r3 + blr + .type __compcert_va_int32, @function + .size __compcert_va_int32, .-__compcert_va_int32 + + .balign 16 + .globl __compcert_va_int64 +__compcert_va_int64: + # r3 = ap = address of va_list structure + lbz r4, 0(r3) # r4 = ap->ireg = next integer register + cmplwi r4, 7 + bge 1f + # Next argument was passed in two consecutive integer register + lwz r5, 8(r3) # r5 = ap->regs = base of saved register area + addi r4, r4, 3 # round r4 up to an even number and add 2 + rlwinm r4, r4, 0, 0, 30 + rlwinm r6, r4, 2, 0, 29 # r6 = r4 * 4 + add r5, r5, r6 # r5 = address of argument + 8 + stb r4, 0(r3) # update ap->ireg + lwz r3, -8(r5) # load argument in r3:r4 + lwz r4, -4(r5) + blr + # Next argument was passed on stack +1: lwz r5, 4(r3) # r5 = ap->stk = next argument passed on stack + li r4, 8 + stb r4, 0(r3) # set ap->ireg = 8 so that no ireg is left + addi r5, r5, 15 # round r5 to a multiple of 8 and add 8 + rlwinm r5, r5, 0, 0, 28 + stw r5, 4(r3) # update ap->stk + lwz r3, -8(r5) # load argument in r3:r4 + lwz r4, -4(r5) + blr + .type __compcert_va_int64, @function + .size __compcert_va_int64, .-__compcert_va_int64 + + .balign 16 + .globl __compcert_va_float64 +__compcert_va_float64: + # r3 = ap = address of va_list structure + lbz r4, 1(r3) # r4 = ap->freg = next float register + cmplwi r4, 8 + bge 1f + # Next argument was passed in a FP register + lwz r5, 8(r3) # r5 = ap->regs = base of saved register area + rlwinm r6, r4, 3, 0, 28 # r6 = r4 * 8 + add r5, r5, r6 + lfd f1, 32(r5) # load argument in f1 + addi r4, r4, 1 # increment ap->freg + stb r4, 1(r3) + blr + # Next argument was passed on stack +1: lwz r5, 4(r3) # r5 = ap->stk = next argument passed on stack + addi r5, r5, 15 # round r5 to a multiple of 8 and add 8 + rlwinm r5, r5, 0, 0, 28 + lfd f1, -8(r5) # load argument in f1 + stw r5, 4(r3) # update ap->stk + blr + .type __compcert_va_float64, @function + .size __compcert_va_float64, .-__compcert_va_int64 + + .balign 16 + .globl __compcert_va_composite +__compcert_va_composite: + b __compcert_va_int32 + .type __compcert_va_composite, @function + .size __compcert_va_composite, .-__compcert_va_composite + +# Save integer and FP registers at beginning of vararg function + + .balign 16 + .globl __compcert_va_saveregs +__compcert_va_saveregs: + lwz r11, 0(r1) # r11 point to top of our frame + stwu r3, -96(r11) # register save area is 96 bytes below + stw r4, 4(r11) + stw r5, 8(r11) + stw r6, 12(r11) + stw r7, 16(r11) + stw r8, 20(r11) + stw r9, 24(r11) + stw r10, 28(r11) + bf 6, 1f # don't save FP regs if CR6 bit is clear + stfd f1, 32(r11) + stfd f2, 40(r11) + stfd f3, 48(r11) + stfd f4, 56(r11) + stfd f5, 64(r11) + stfd f6, 72(r11) + stfd f7, 80(r11) + stfd f8, 88(r11) +1: blr + .type __compcert_va_saveregs, @function + .size __compcert_va_saveregs, .-__compcert_va_saveregs -- cgit From 6d3118ad9eec104e8ed0bb86a3f5100d20224fd2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 9 Feb 2020 21:43:51 +0100 Subject: bringing back the ppc64 runtime --- runtime/powerpc64/i64_dtou.s | 66 ++++++++++++++++++ runtime/powerpc64/i64_stof.s | 68 ++++++++++++++++++ runtime/powerpc64/i64_utod.s | 79 +++++++++++++++++++++ runtime/powerpc64/i64_utof.s | 64 +++++++++++++++++ runtime/powerpc64/vararg.s | 163 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 440 insertions(+) create mode 100644 runtime/powerpc64/i64_dtou.s create mode 100644 runtime/powerpc64/i64_stof.s create mode 100644 runtime/powerpc64/i64_utod.s create mode 100644 runtime/powerpc64/i64_utof.s create mode 100644 runtime/powerpc64/vararg.s diff --git a/runtime/powerpc64/i64_dtou.s b/runtime/powerpc64/i64_dtou.s new file mode 100644 index 00000000..e58bcfaf --- /dev/null +++ b/runtime/powerpc64/i64_dtou.s @@ -0,0 +1,66 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Conversion from double float to unsigned long + + .balign 16 + .globl __compcert_i64_dtou +__compcert_i64_dtou: + lis r0, 0x5f00 # 0x5f00_0000 = 2^63 in binary32 format + stwu r0, -16(r1) + lfs f2, 0(r1) # f2 = 2^63 + fcmpu cr0, f1, f2 # crbit 0 is f1 < f2 + bf 0, 1f # branch if f1 >= 2^63 (or f1 is NaN) + fctidz f1, f1 # convert as signed + stfd f1, 0(r1) + lwz r3, 0(r1) + lwz r4, 4(r1) + addi r1, r1, 16 + blr +1: fsub f1, f1, f2 # shift argument down by 2^63 + fctidz f1, f1 # convert as signed + stfd f1, 0(r1) + lwz r3, 0(r1) + lwz r4, 4(r1) + addis r3, r3, 0x8000 # shift result up by 2^63 + addi r1, r1, 16 + blr + .type __compcert_i64_dtou, @function + .size __compcert_i64_dtou, .-__compcert_i64_dtou + + diff --git a/runtime/powerpc64/i64_stof.s b/runtime/powerpc64/i64_stof.s new file mode 100644 index 00000000..779cbc18 --- /dev/null +++ b/runtime/powerpc64/i64_stof.s @@ -0,0 +1,68 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Conversion from signed long to single float + + .balign 16 + .globl __compcert_i64_stof +__compcert_i64_stof: + rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 + # Check whether -2^53 <= X < 2^53 + sradi r5, r4, 53 + addi r5, r5, 1 + cmpldi r5, 2 + blt 1f + # X is large enough that double rounding can occur. + # Avoid it by nudging X away from the points where double rounding + # occurs (the "round to odd" technique) + rldicl r5, r4, 0, 53 # extract bits 0 to 11 of X + addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF + # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-63 of r5 are 0 + or r4, r4, r5 # correct bit number 12 of X + rldicr r4, r4, 0, 52 # set to 0 bits 0 to 11 of X + # Convert to double, then round to single +1: stdu r4, -16(r1) + lfd f1, 0(r1) + fcfid f1, f1 + frsp f1, f1 + addi r1, r1, 16 + blr + .type __compcert_i64_stof, @function + .size __compcert_i64_stof, .-__compcert_i64_stof + diff --git a/runtime/powerpc64/i64_utod.s b/runtime/powerpc64/i64_utod.s new file mode 100644 index 00000000..491ee26b --- /dev/null +++ b/runtime/powerpc64/i64_utod.s @@ -0,0 +1,79 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC 64 version. + + .text + +### Conversion from unsigned long to double float + + .balign 16 + .globl __compcert_i64_utod +__compcert_i64_utod: + rldicl r3, r3, 0, 32 # clear top 32 bits + rldicl r4, r4, 0, 32 # clear top 32 bits + lis r5, 0x4f80 # 0x4f80_0000 = 2^32 in binary32 format + stdu r3, -32(r1) + std r4, 8(r1) + stw r5, 16(r1) + lfd f1, 0(r1) # high 32 bits of argument + lfd f2, 8(r1) # low 32 bits of argument + lfs f3, 16(r1) # 2^32 + fcfid f1, f1 # convert both 32-bit halves to FP (exactly) + fcfid f2, f2 + fmadd f1, f1, f3, f2 # compute hi * 2^32 + lo + addi r1, r1, 32 + blr + .type __compcert_i64_utod, @function + .size __compcert_i64_utod, .-__compcert_i64_utod + +# Alternate implementation using round-to-odd: +# rldimi r4, r3, 32, 0 # reassemble (r3,r4) as a 64-bit integer in r4 +# cmpdi r4, 0 # is r4 >= 2^63 ? +# blt 1f +# stdu r4, -16(r1) # r4 < 2^63: convert as signed +# lfd f1, 0(r1) +# fcfid f1, f1 +# addi r1, r1, 16 +# blr +#1: rldicl r0, r4, 0, 63 # extract low bit of r4 +# srdi r4, r4, 1 +# or r4, r4, r0 # round r4 to 63 bits, using round-to-odd +# stdu r4, -16(r1) # convert to binary64 +# lfd f1, 0(r1) +# fcfid f1, f1 +# fadd f1, f1, f1 # multiply result by 2 +# addi r1, r1, 16 +# blr + \ No newline at end of file diff --git a/runtime/powerpc64/i64_utof.s b/runtime/powerpc64/i64_utof.s new file mode 100644 index 00000000..cdb2f867 --- /dev/null +++ b/runtime/powerpc64/i64_utof.s @@ -0,0 +1,64 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for 64-bit integer arithmetic. PowerPC version. + + .text + +### Conversion from unsigned long to single float + + .balign 16 + .globl __compcert_i64_utof +__compcert_i64_utof: + mflr r9 + # Check whether X < 2^53 + andis. r0, r3, 0xFFE0 # test bits 53...63 of X + beq 1f + # X is large enough that double rounding can occur. + # Avoid it by nudging X away from the points where double rounding + # occurs (the "round to odd" technique) + rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X + addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF + # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-31 of r0 are 0 + or r4, r4, r0 # correct bit number 12 of X + rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X + # Convert to double, then round to single +1: bl __compcert_i64_utod + mtlr r9 + frsp f1, f1 + blr + .type __compcert_i64_utof, @function + .size __compcert_i64_utof, .-__compcert_i64_utof + diff --git a/runtime/powerpc64/vararg.s b/runtime/powerpc64/vararg.s new file mode 100644 index 00000000..8d7e62c8 --- /dev/null +++ b/runtime/powerpc64/vararg.s @@ -0,0 +1,163 @@ +# ***************************************************************** +# +# The Compcert verified compiler +# +# Xavier Leroy, INRIA Paris-Rocquencourt +# +# Copyright (c) 2013 Institut National de Recherche en Informatique et +# en Automatique. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of the nor the +# names of its contributors may be used to endorse or promote products +# derived from this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# ********************************************************************* + +# Helper functions for variadic functions . IA32 version + +# typedef struct { +# unsigned char ireg; // index of next integer register +# unsigned char freg; // index of next FP register +# char * stk; // pointer to next argument in stack +# struct { +# int iregs[8]; +# double fregs[8]; +# } * regs; // pointer to saved register area +# } va_list[1]; +# +# unsigned int __compcert_va_int32(va_list ap); +# unsigned long long __compcert_va_int64(va_list ap); +# double __compcert_va_float64(va_list ap); + + .text + + .balign 16 + .globl __compcert_va_int32 +__compcert_va_int32: + # r3 = ap = address of va_list structure + lbz r4, 0(r3) # r4 = ap->ireg = next integer register + cmplwi r4, 8 + bge 1f + # Next argument was passed in an integer register + lwz r5, 8(r3) # r5 = ap->regs = base of saved register area + rlwinm r6, r4, 2, 0, 29 # r6 = r4 * 4 + addi r4, r4, 1 # increment ap->ireg + stb r4, 0(r3) + lwzx r3, r5, r6 # load argument in r3 + blr + # Next argument was passed on stack +1: lwz r5, 4(r3) # r5 = ap->stk = next argument passed on stack + addi r5, r5, 4 # advance ap->stk by 4 + stw r5, 4(r3) + lwz r3, -4(r5) # load argument in r3 + blr + .type __compcert_va_int32, @function + .size __compcert_va_int32, .-__compcert_va_int32 + + .balign 16 + .globl __compcert_va_int64 +__compcert_va_int64: + # r3 = ap = address of va_list structure + lbz r4, 0(r3) # r4 = ap->ireg = next integer register + cmplwi r4, 7 + bge 1f + # Next argument was passed in two consecutive integer register + lwz r5, 8(r3) # r5 = ap->regs = base of saved register area + addi r4, r4, 3 # round r4 up to an even number and add 2 + rlwinm r4, r4, 0, 0, 30 + rlwinm r6, r4, 2, 0, 29 # r6 = r4 * 4 + add r5, r5, r6 # r5 = address of argument + 8 + stb r4, 0(r3) # update ap->ireg + lwz r3, -8(r5) # load argument in r3:r4 + lwz r4, -4(r5) + blr + # Next argument was passed on stack +1: lwz r5, 4(r3) # r5 = ap->stk = next argument passed on stack + li r4, 8 + stb r4, 0(r3) # set ap->ireg = 8 so that no ireg is left + addi r5, r5, 15 # round r5 to a multiple of 8 and add 8 + rlwinm r5, r5, 0, 0, 28 + stw r5, 4(r3) # update ap->stk + lwz r3, -8(r5) # load argument in r3:r4 + lwz r4, -4(r5) + blr + .type __compcert_va_int64, @function + .size __compcert_va_int64, .-__compcert_va_int64 + + .balign 16 + .globl __compcert_va_float64 +__compcert_va_float64: + # r3 = ap = address of va_list structure + lbz r4, 1(r3) # r4 = ap->freg = next float register + cmplwi r4, 8 + bge 1f + # Next argument was passed in a FP register + lwz r5, 8(r3) # r5 = ap->regs = base of saved register area + rlwinm r6, r4, 3, 0, 28 # r6 = r4 * 8 + add r5, r5, r6 + lfd f1, 32(r5) # load argument in f1 + addi r4, r4, 1 # increment ap->freg + stb r4, 1(r3) + blr + # Next argument was passed on stack +1: lwz r5, 4(r3) # r5 = ap->stk = next argument passed on stack + addi r5, r5, 15 # round r5 to a multiple of 8 and add 8 + rlwinm r5, r5, 0, 0, 28 + lfd f1, -8(r5) # load argument in f1 + stw r5, 4(r3) # update ap->stk + blr + .type __compcert_va_float64, @function + .size __compcert_va_float64, .-__compcert_va_int64 + + .balign 16 + .globl __compcert_va_composite +__compcert_va_composite: + b __compcert_va_int32 + .type __compcert_va_composite, @function + .size __compcert_va_composite, .-__compcert_va_composite + +# Save integer and FP registers at beginning of vararg function + + .balign 16 + .globl __compcert_va_saveregs +__compcert_va_saveregs: + lwz r11, 0(r1) # r11 point to top of our frame + stwu r3, -96(r11) # register save area is 96 bytes below + stw r4, 4(r11) + stw r5, 8(r11) + stw r6, 12(r11) + stw r7, 16(r11) + stw r8, 20(r11) + stw r9, 24(r11) + stw r10, 28(r11) + bf 6, 1f # don't save FP regs if CR6 bit is clear + stfd f1, 32(r11) + stfd f2, 40(r11) + stfd f3, 48(r11) + stfd f4, 56(r11) + stfd f5, 64(r11) + stfd f6, 72(r11) + stfd f7, 80(r11) + stfd f8, 88(r11) +1: blr + .type __compcert_va_saveregs, @function + .size __compcert_va_saveregs, .-__compcert_va_saveregs -- cgit From aec490a064af1cdbcc8ac70a9b5a2c882bea6b55 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 16:26:05 +0100 Subject: Moved some theorems --- mppa_k1c/Asmblock.v | 25 +++++++ mppa_k1c/Asmblockgenproof.v | 13 ---- mppa_k1c/Asmblockgenproof0.v | 139 ++++++++++++++++++++----------------- mppa_k1c/PostpassSchedulingproof.v | 37 ---------- 4 files changed, 101 insertions(+), 113 deletions(-) diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 91e5ac89..cce180ac 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -294,6 +294,31 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := end end. + +Theorem builtin_body_nil: + forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. +Proof. + intros. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. + eapply H1; eauto. +Qed. + +Theorem exec_body_app: + forall l l' rs m rs'' m'', + exec_body (l ++ l') rs m = Next rs'' m'' -> + exists rs' m', + exec_body l rs m = Next rs' m' + /\ exec_body l' rs' m' = Next rs'' m''. +Proof. + induction l. + - intros. simpl in H. repeat eexists. auto. + - intros. rewrite <- app_comm_cons in H. simpl in H. + destruct (exec_basic_instr a rs m) eqn:EXEBI. + + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). + repeat eexists. simpl. rewrite EXEBI. eauto. auto. + + discriminate. +Qed. + (** Position corresponding to a label *) Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e130df45..220ae08b 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1353,19 +1353,6 @@ Proof. rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. Qed. -Lemma exec_body_pc: - forall l rs1 m1 rs2 m2, - exec_body tge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - Lemma exec_body_control: forall b rs1 m1 rs2 m2 rs3 m3 fn, exec_body tge (body b) rs1 m1 = Next rs2 m2 -> diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 07c445e2..d2450a9a 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -752,6 +752,82 @@ Proof. intros. destruct H. auto. Qed. +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Theorem exec_basic_instr_pc: + forall ge b rs1 m1 rs2 m2, + exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i. + all: try (inv H; Simpl). + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) + unfold parexec_load_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + { (* PLoadORRO *) + unfold parexec_load_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) + unfold parexec_store_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) + unfold parexec_store_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. + - destruct rs; try discriminate. inv H1. Simpl. + - destruct rd; try discriminate. inv H1; Simpl. + - reflexivity. +Qed. + +Lemma exec_body_pc: + forall ge l rs1 m1 rs2 m2, + exec_body ge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + Section STRAIGHTLINE. Variable ge: genv. @@ -880,69 +956,6 @@ Qed. (** Linking exec_straight with exec_straight_blocks *) -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -Lemma exec_basic_instr_pc: - forall b rs1 m1 rs2 m2, - exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - intros. destruct b; try destruct i; try destruct i. - all: try (inv H; Simpl). - 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - { (* PLoadQRRO *) - unfold parexec_load_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - { (* PLoadORRO *) - unfold parexec_load_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. - 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - - { (* PStoreQRRO *) - unfold parexec_store_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - { (* PStoreORRO *) - unfold parexec_store_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. - - destruct rs; try discriminate. inv H1. Simpl. - - destruct rd; try discriminate. inv H1; Simpl. - - reflexivity. -Qed. - Lemma exec_straight_pc: forall c c' rs1 m1 rs2 m2, exec_straight c rs1 m1 c' rs2 m2 -> diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 867c10c5..cdf8829f 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -30,43 +30,6 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Remark builtin_body_nil: - forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. -Proof. - intros. destruct bb as [hd bdy ex WF]. simpl in *. - apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. - eapply H1; eauto. -Qed. - -Lemma exec_body_app: - forall l l' ge rs m rs'' m'', - exec_body ge (l ++ l') rs m = Next rs'' m'' -> - exists rs' m', - exec_body ge l rs m = Next rs' m' - /\ exec_body ge l' rs' m' = Next rs'' m''. -Proof. - induction l. - - intros. simpl in H. repeat eexists. auto. - - intros. rewrite <- app_comm_cons in H. simpl in H. - destruct (exec_basic_instr ge a rs m) eqn:EXEBI. - + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). - repeat eexists. simpl. rewrite EXEBI. eauto. auto. - + discriminate. -Qed. - -Lemma exec_body_pc: - forall l ge rs1 m1 rs2 m2, - exec_body ge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - Lemma next_eq: forall (rs rs': regset) m m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. -- cgit From b748b38c8b3a998f018477d7375ae16997318769 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 18:30:07 +0100 Subject: Removing from Asmblockgenproof0 architecture specific definitions --- configure | 2 +- mppa_k1c/Asmblock.v | 13 ++++ mppa_k1c/Asmblockdeps.v | 10 +-- mppa_k1c/Asmblockgenproof.v | 2 +- mppa_k1c/Asmblockgenproof0.v | 124 ++---------------------------------- mppa_k1c/Asmblockgenproof1.v | 2 +- mppa_k1c/Asmblockprops.v | 126 +++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassScheduling.v | 2 +- mppa_k1c/PostpassSchedulingproof.v | 2 +- 9 files changed, 153 insertions(+), 130 deletions(-) create mode 100644 mppa_k1c/Asmblockprops.v diff --git a/configure b/configure index 9d5bfcf9..f13d1af3 100755 --- a/configure +++ b/configure @@ -845,7 +845,7 @@ EXECUTE=k1-cluster --syscall=libstd_scalls.so -- CFLAGS= -D __K1C_COS__ SIMU=k1-cluster -- BACKENDLIB=Machblock.v Machblockgen.v Machblockgenproof.v\\ - Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v Asmvliw.v\\ + Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v Asmvliw.v Asmblockprops.v\\ ForwardSimulationBlock.v PostpassScheduling.v PostpassSchedulingproof.v\\ Asmblockdeps.v DecBoolOps.v Chunks.v Peephole.v ExtValues.v ExtFloats.v\\ AbstractBasicBlocksDef.v SeqSimuTheory.v ImpSimuTest.v Parallelizability.v\\ diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index cce180ac..a05d4726 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -33,6 +33,19 @@ Require Import Conventions. Require Import Errors. Require Export Asmvliw. +(* Notations necessary to hook Asmvliw definitions *) +Notation undef_caller_save_regs := Asmvliw.undef_caller_save_regs. +Notation regset := Asmvliw.regset. +Notation extcall_arg := Asmvliw.extcall_arg. +Notation extcall_arg_pair := Asmvliw.extcall_arg_pair. +Notation extcall_arguments := Asmvliw.extcall_arguments. +Notation set_res := Asmvliw.set_res. +Notation function := Asmvliw.function. +Notation bblocks := Asmvliw.bblocks. +Notation header := Asmvliw.header. +Notation body := Asmvliw.body. +Notation exit := Asmvliw.exit. +Notation correct := Asmvliw.correct. (** * Auxiliary utilies on basic blocks *) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 584f2339..02f9141b 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -7,7 +7,7 @@ Require Import AST. Require Import Asmblock. -Require Import Asmblockgenproof0. +Require Import Asmblockgenproof0 Asmblockprops. Require Import Values. Require Import Globalenvs. Require Import Memory. @@ -1429,7 +1429,7 @@ Lemma bblock_simu_reduce: forall p1 p2 ge fn, Ge = Genv ge fn -> L.bblock_simu Ge (trans_block p1) (trans_block p2) -> - Asmblockgenproof0.bblock_simu ge fn p1 p2. + Asmblockprops.bblock_simu ge fn p1 p2. Proof. unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK. generalize (H2 (trans_state (State rs m))); clear H2. @@ -1787,7 +1787,7 @@ Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. Theorem bblock_simu_test_correct verb p1 p2 : - WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockgenproof0.bblock_simu ge fn p1 p2. + WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockprops.bblock_simu ge fn p1 p2. Proof. wlp_simplify. Qed. @@ -1803,7 +1803,7 @@ Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := | None => false end. -Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. Proof. unfold pure_bblock_simu_test. destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. @@ -1813,7 +1813,7 @@ Qed. Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. -Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). Qed. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 220ae08b..1a427112 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -16,7 +16,7 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops. Require Import Axioms. Module MB := Machblock. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index d2450a9a..940c6563 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -22,16 +22,10 @@ Require Import Asmblockgen. Require Import Conventions1. Require Import Axioms. Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) +Require Import Asmblockprops. Module MB:=Machblock. -Module AB:=Asmvliw. - -Hint Extern 2 (_ <> _) => congruence: asmgen. - -Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := - forall rs m, - exec_bblock ge f bb rs m <> Stuck -> - exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. +Module AB:=Asmblock. Lemma ireg_of_eq: forall r r', ireg_of r = OK r' -> preg_of r = IR r'. @@ -51,53 +45,6 @@ Proof. destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. Qed. -Lemma preg_of_data: - forall r, data_preg (preg_of r) = true. -Proof. - intros. destruct r; reflexivity. -Qed. -Hint Resolve preg_of_data: asmgen. - -Lemma data_diff: - forall r r', - data_preg r = true -> data_preg r' = false -> r <> r'. -Proof. - congruence. -Qed. -Hint Resolve data_diff: asmgen. - -Lemma preg_of_not_SP: - forall r, preg_of r <> SP. -Proof. - intros. unfold preg_of; destruct r; simpl; congruence. -Qed. - -Lemma preg_of_not_PC: - forall r, preg_of r <> PC. -Proof. - intros. apply data_diff; auto with asmgen. -Qed. - -Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. - -Lemma nextblock_pc: - forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). -Proof. - intros. apply Pregmap.gss. -Qed. - -Lemma nextblock_inv: - forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. -Proof. - intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. -Qed. - -Lemma nextblock_inv1: - forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. -Proof. - intros. apply nextblock_inv. red; intro; subst; discriminate. -Qed. - Lemma undef_regs_other: forall r rl rs, (forall r', In r' rl -> r <> r') -> @@ -294,9 +241,9 @@ Qed. Lemma agree_undef_caller_save_regs: forall ms sp rs, agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (Asmvliw.undef_caller_save_regs rs). + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, Asmvliw.undef_caller_save_regs; split. + intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. - unfold proj_sumbool; rewrite dec_eq_true. auto. - auto. - intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). @@ -752,69 +699,6 @@ Proof. intros. destruct H. auto. Qed. -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -Theorem exec_basic_instr_pc: - forall ge b rs1 m1 rs2 m2, - exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - intros. destruct b; try destruct i; try destruct i. - all: try (inv H; Simpl). - 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - { (* PLoadQRRO *) - unfold parexec_load_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - { (* PLoadORRO *) - unfold parexec_load_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. - 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - - { (* PStoreQRRO *) - unfold parexec_store_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - { (* PStoreORRO *) - unfold parexec_store_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. - - destruct rs; try discriminate. inv H1. Simpl. - - destruct rd; try discriminate. inv H1; Simpl. - - reflexivity. -Qed. - Lemma exec_body_pc: forall ge l rs1 m1 rs2 m2, exec_body ge l rs1 m1 = Next rs2 m2 -> diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index c0a05ab3..ecb4629b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -20,7 +20,7 @@ Require Import Coqlib Errors Maps. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op Locations Machblock Conventions. -Require Import Asmblock Asmblockgen Asmblockgenproof0. +Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. Require Import Chunks. (** Decomposition of integer constants. *) diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v new file mode 100644 index 00000000..7f6e33db --- /dev/null +++ b/mppa_k1c/Asmblockprops.v @@ -0,0 +1,126 @@ +(** Common definition and proofs on Asmblock required by various modules *) + +Require Import Coqlib. +Require Import Integers. +Require Import Memory. +Require Import Globalenvs. +Require Import Values. +Require Import Asmblock. + +Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + forall rs m, + exec_bblock ge f bb rs m <> Stuck -> + exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +Lemma preg_of_data: + forall r, data_preg (preg_of r) = true. +Proof. + intros. destruct r; reflexivity. +Qed. +Hint Resolve preg_of_data: asmgen. + +Lemma data_diff: + forall r r', + data_preg r = true -> data_preg r' = false -> r <> r'. +Proof. + congruence. +Qed. +Hint Resolve data_diff: asmgen. + +Lemma preg_of_not_PC: + forall r, preg_of r <> PC. +Proof. + intros. apply data_diff; auto with asmgen. +Qed. + +Lemma preg_of_not_SP: + forall r, preg_of r <> SP. +Proof. + intros. unfold preg_of; destruct r; simpl; congruence. +Qed. + +Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. + + +Lemma nextblock_pc: + forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). +Proof. + intros. apply Pregmap.gss. +Qed. + +Lemma nextblock_inv: + forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. +Proof. + intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. +Qed. + +Lemma nextblock_inv1: + forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. +Proof. + intros. apply nextblock_inv. red; intro; subst; discriminate. +Qed. + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Theorem exec_basic_instr_pc: + forall ge b rs1 m1 rs2 m2, + exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i. + all: try (inv H; Simpl). + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) + unfold parexec_load_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + { (* PLoadORRO *) + unfold parexec_load_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) + unfold parexec_store_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) + unfold parexec_store_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. + - destruct rs; try discriminate. inv H1. Simpl. + - destruct rd; try discriminate. inv H1; Simpl. + - reflexivity. +Qed. \ No newline at end of file diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 8b6de1e2..31180cea 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -12,7 +12,7 @@ Require Import Coqlib Errors AST Integers. Require Import Asmblock Axioms Memory Globalenvs. -Require Import Asmblockdeps Asmblockgenproof0. +Require Import Asmblockdeps Asmblockgenproof0 Asmblockprops. Require Peephole. Local Open Scope error_monad_scope. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index cdf8829f..f1166a38 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -14,7 +14,7 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgenproof0. +Require Import Asmblockgenproof0 Asmblockprops. Require Import PostpassScheduling. Require Import Asmblockgenproof. Require Import Axioms. -- cgit From c9ad4b36bb969439d554784f553b7da01e0ba04b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 18:59:02 +0100 Subject: Moving Asmblockgenproof0 to mppa_k1c/lib/ --- mppa_k1c/Asmblockgenproof0.v | 967 --------------------------------------- mppa_k1c/lib/Asmblockgenproof0.v | 967 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 967 insertions(+), 967 deletions(-) delete mode 100644 mppa_k1c/Asmblockgenproof0.v create mode 100644 mppa_k1c/lib/Asmblockgenproof0.v diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v deleted file mode 100644 index 940c6563..00000000 --- a/mppa_k1c/Asmblockgenproof0.v +++ /dev/null @@ -1,967 +0,0 @@ -(** * "block" version of Asmgenproof0 - - This module is largely adapted from Asmgenproof0.v of the other backends - It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends - It has similar definitions than Asmgenproof0, but adapted to this new structure *) - -Require Import Coqlib. -Require Intv. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Locations. -Require Import Machblock. -Require Import Asmblock. -Require Import Asmblockgen. -Require Import Conventions1. -Require Import Axioms. -Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) -Require Import Asmblockprops. - -Module MB:=Machblock. -Module AB:=Asmblock. - -Lemma ireg_of_eq: - forall r r', ireg_of r = OK r' -> preg_of r = IR r'. -Proof. - unfold ireg_of; intros. destruct (preg_of r); inv H; auto. -Qed. - -Lemma freg_of_eq: - forall r r', freg_of r = OK r' -> preg_of r = IR r'. -Proof. - unfold freg_of; intros. destruct (preg_of r); inv H; auto. -Qed. - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -Proof. - destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. -Qed. - -Lemma undef_regs_other: - forall r rl rs, - (forall r', In r' rl -> r <> r') -> - undef_regs rl rs r = rs r. -Proof. - induction rl; simpl; intros. auto. - rewrite IHrl by auto. rewrite Pregmap.gso; auto. -Qed. - -Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := - match rl with - | nil => True - | r1 :: nil => r <> preg_of r1 - | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl - end. - -Remark preg_notin_charact: - forall r rl, - preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). -Proof. - induction rl; simpl; intros. - tauto. - destruct rl. - simpl. split. intros. intuition congruence. auto. - rewrite IHrl. split. - intros [A B]. intros. destruct H. congruence. auto. - auto. -Qed. - -Lemma undef_regs_other_2: - forall r rl rs, - preg_notin r rl -> - undef_regs (map preg_of rl) rs r = rs r. -Proof. - intros. apply undef_regs_other. intros. - exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. - rewrite preg_notin_charact in H. auto. -Qed. - -(** * Agreement between Mach registers and processor registers *) - -Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { - agree_sp: rs#SP = sp; - agree_sp_def: sp <> Vundef; - agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) -}. - -Lemma preg_val: - forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). -Proof. - intros. destruct H. auto. -Qed. - -Lemma preg_vals: - forall ms sp rs, agree ms sp rs -> - forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). -Proof. - induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, agree ms sp rs -> sp = rs#SP. -Proof. - intros. destruct H; auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r r', - agree ms sp rs -> - ireg_of r = OK r' -> - Val.lessdef (ms r) rs#r'. -Proof. - intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma freg_val: - forall ms sp rs r r', - agree ms sp rs -> - freg_of r = OK r' -> - Val.lessdef (ms r) (rs#r'). -Proof. - intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma agree_exten: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, data_preg r = true -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H0; auto. auto. - intros. rewrite H0; auto. apply preg_of_data. -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. - intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. - rewrite H1. auto. apply preg_of_data. - red; intros; elim n. eapply preg_of_injective; eauto. -Qed. - -Corollary agree_set_mreg_parallel: - forall ms sp rs r v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). -Proof. - intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. -Qed. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - data_preg r = false -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten with rs. auto. - intros. apply Pregmap.gso. congruence. -Qed. - -Lemma agree_nextblock: - forall ms sp rs b, - agree ms sp rs -> agree ms sp (nextblock b rs). -Proof. - intros. unfold nextblock. apply agree_set_other. auto. auto. -Qed. - -Lemma agree_set_pair: - forall sp p v v' ms rs, - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). -Proof. - intros. destruct p; simpl. -- apply agree_set_mreg_parallel; auto. -- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. - apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. -Qed. - -Lemma agree_undef_nondata_regs: - forall ms sp rl rs, - agree ms sp rs -> - (forall r, In r rl -> data_preg r = false) -> - agree ms sp (undef_regs rl rs). -Proof. - induction rl; simpl; intros. auto. - apply IHrl. apply agree_exten with rs; auto. - intros. apply Pregmap.gso. red; intros; subst. - assert (data_preg a = false) by auto. congruence. - intros. apply H0; auto. -Qed. - -Lemma agree_undef_regs: - forall ms sp rl rs rs', - agree ms sp rs -> - (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.undef_regs rl ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite <- agree_sp0. apply H0; auto. - rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. - intros. destruct (In_dec mreg_eq r rl). - rewrite Mach.undef_regs_same; auto. - rewrite Mach.undef_regs_other; auto. rewrite H0; auto. - apply preg_of_data. - rewrite preg_notin_charact. intros; red; intros. elim n. - exploit preg_of_injective; eauto. congruence. -Qed. - -Lemma agree_set_undef_mreg: - forall ms sp rs r v rl rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. -Proof. - intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. - apply agree_undef_regs with rs; auto. - intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). - congruence. auto. - intros. rewrite Pregmap.gso; auto. -Qed. - -Lemma agree_undef_caller_save_regs: - forall ms sp rs, - agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). -Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. -- unfold proj_sumbool; rewrite dec_eq_true. auto. -- auto. -- intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). - destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. -+ apply list_in_map_inv in i. destruct i as (mr & A & B). - assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. - apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. -+ destruct (is_callee_save r) eqn:CS; auto. - elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. -Qed. - -Lemma agree_change_sp: - forall ms sp rs sp', - agree ms sp rs -> sp' <> Vundef -> - agree ms sp' (rs#SP <- sp'). -Proof. - intros. inv H. split; auto. - intros. rewrite Pregmap.gso; auto with asmgen. -Qed. - -(** Connection between Mach and Asm calling conventions for external - functions. *) - -Lemma extcall_arg_match: - forall ms sp rs m m' l v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg ms m sp l v -> - exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. - exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. - unfold Mach.load_stack in H2. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ H) in A. - exists v'; split; auto. - econstructor. eauto. assumption. -Qed. - -Lemma extcall_arg_pair_match: - forall ms sp rs m m' p v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg_pair ms m sp p v -> - exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. -- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. -- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). - exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). - exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. -Qed. - - -Lemma extcall_args_match: - forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall ll vl, - list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> - exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros. - exists (@nil val); split. constructor. constructor. - exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. -Qed. - -Lemma extcall_arguments_match: - forall ms m m' sp rs sg args, - agree ms sp rs -> Mem.extends m m' -> - Mach.extcall_arguments ms m sp sg args -> - exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. -Proof. - unfold Mach.extcall_arguments, AB.extcall_arguments; intros. - eapply extcall_args_match; eauto. -Qed. - -Remark builtin_arg_match: - forall ge (rs: regset) sp m a v, - eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> - eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. -Proof. - induction 1; simpl; eauto with barg. -Qed. - -Lemma builtin_args_match: - forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall al vl, eval_builtin_args ge ms sp m al vl -> - exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' - /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros; simpl. - exists (@nil val); split; constructor. - exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. - intros; eapply preg_val; eauto. - intros (v1' & A & B). - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. -Qed. - -Lemma agree_set_res: - forall res ms sp rs v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). -Proof. - induction res; simpl; intros. -- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. - intros. apply Pregmap.gso; auto. -- auto. -- apply IHres2. apply IHres1. auto. - apply Val.hiword_lessdef; auto. - apply Val.loword_lessdef; auto. -Qed. - -Lemma set_res_other: - forall r res v rs, - data_preg r = false -> - set_res (map_builtin_res preg_of res) v rs r = rs r. -Proof. - induction res; simpl; intros. -- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. -- auto. -- rewrite IHres2, IHres1; auto. -Qed. - -(* inspired from Mach *) - -Lemma find_label_tail: - forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. -Proof. - induction c; simpl; intros. discriminate. - destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. -Qed. - -(* inspired from Asmgenproof0 *) - -(* ... skip ... *) - -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Inductive code_tail: Z -> bblocks -> bblocks -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos bi c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + (size bi)) (bi :: c1) c2. - -Lemma code_tail_pos: - forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. -Proof. - induction 1. omega. generalize (size_positive bi); intros; omega. -Qed. - -Lemma find_bblock_tail: - forall c1 bi c2 pos, - code_tail pos c1 (bi :: c2) -> - find_bblock pos c1 = Some bi. -Proof. - induction c1; simpl; intros. - inversion H. - destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. - destruct (zeq pos 0). subst pos. - inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. - inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. - eauto. -Qed. - - -Local Hint Resolve code_tail_0 code_tail_S. - -Lemma code_tail_next: - forall fn ofs c0, - code_tail ofs fn c0 -> - forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. -Proof. - induction 1; intros. - - subst; eauto. - - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. - omega. -Qed. - -Lemma size_blocks_pos c: 0 <= size_blocks c. -Proof. - induction c as [| a l ]; simpl; try omega. - generalize (size_positive a); omega. -Qed. - -Remark code_tail_positive: - forall fn ofs c, - code_tail ofs fn c -> 0 <= ofs. -Proof. - induction 1; intros; simpl. - - omega. - - generalize (size_positive bi). omega. -Qed. - -Remark code_tail_size: - forall fn ofs c, - code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. -Proof. - induction 1; intros; simpl; try omega. -Qed. - -Remark code_tail_bounds fn ofs c: - code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. -Proof. - intro H; - exploit code_tail_size; eauto. - generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). - omega. -Qed. - -Local Hint Resolve code_tail_next. - -Lemma code_tail_next_int: - forall fn ofs bi c, - size_blocks fn <= Ptrofs.max_unsigned -> - code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> - code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. -Proof. - intros. - exploit code_tail_size; eauto. - simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). - intros. - rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. - - rewrite Ptrofs.unsigned_repr; eauto. - omega. - - rewrite Ptrofs.unsigned_repr; omega. -Qed. - -(** Predictor for return addresses in generated Asm code. - - The [return_address_offset] predicate defined here is used in the - semantics for Mach to determine the return addresses that are - stored in activation records. *) - -(** Consider a Mach function [f] and a sequence [c] of Mach instructions - representing the Mach code that remains to be executed after a - function call returns. The predicate [return_address_offset f c ofs] - holds if [ofs] is the integer offset of the PPC instruction - following the call in the Asm code obtained by translating the - code of [f]. Graphically: -<< - Mach function f |--------- Mcall ---------| - Mach code c | |--------| - | \ \ - | \ \ - | \ \ - Asm code | |--------| - Asm function |------------- Pcall ---------| - - <-------- ofs -------> ->> -*) - -Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := - forall tf tc, - transf_function f = OK tf -> - transl_blocks f c false = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. - -Lemma transl_blocks_tail: - forall f c1 c2, is_tail c1 c2 -> - forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> - exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. -Proof. - induction 1; simpl; intros. - exists tc2; exists ep2; split; auto with coqlib. - monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). - exists tc1; exists ep1; split. auto. - eapply is_tail_trans with x0; eauto with coqlib. -Qed. - -Lemma is_tail_code_tail: - forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. -Proof. - induction 1; eauto. - destruct IHis_tail; eauto. -Qed. - -Section RETADDR_EXISTS. - -Hypothesis transf_function_inv: - forall f tf, transf_function f = OK tf -> - exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). - -Hypothesis transf_function_len: - forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. - - -Lemma return_address_exists: - forall b f c, is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. destruct (transf_function f) as [tf|] eqn:TF. - + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). - exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). - monadInv TR2. - assert (TL3: is_tail x0 (fn_blocks tf)). - { apply is_tail_trans with tc1; auto. - apply is_tail_trans with (x++x0); auto. eapply is_tail_app. - } - exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Ptrofs.repr ofs). red; intros. - rewrite Ptrofs.unsigned_repr. congruence. - exploit code_tail_bounds; eauto. - intros; apply transf_function_len in TF. omega. - + exists Ptrofs.zero; red; intros. congruence. -Qed. - -End RETADDR_EXISTS. - -(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points - within the Asmblock code generated by translating Machblock function [f], - and [tc] is the tail of the generated code at the position corresponding - to the code pointer [pc]. *) - -Inductive transl_code_at_pc (ge: MB.genv): - val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := - transl_code_at_pc_intro: - forall b ofs f c ep tf tc, - Genv.find_funct_ptr ge b = Some(Internal f) -> - transf_function f = Errors.OK tf -> - transl_blocks f c ep = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> - transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. - -Remark code_tail_no_bigger: - forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. -Proof. - induction 1; simpl; omega. -Qed. - -Remark code_tail_unique: - forall fn c pos pos', - code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. -Proof. - induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - f_equal. eauto. -Qed. - -Lemma return_address_offset_correct: - forall ge b ofs fb f c tf tc ofs', - transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> - return_address_offset f c ofs' -> - ofs' = ofs. -Proof. - intros. inv H. red in H0. - exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. - rewrite <- (Ptrofs.repr_unsigned ofs). - rewrite <- (Ptrofs.repr_unsigned ofs'). - congruence. -Qed. - -(** The [find_label] function returns the code tail starting at the - given label. A connection with [code_tail] is then established. *) - -Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos <= pos' <= pos + size_blocks c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - - intros. inv H. exists pos. split; auto. split. - replace (pos - pos) with 0 by omega. constructor. constructor; try omega. - generalize (size_blocks_pos c). generalize (size_positive a). omega. - - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. - exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. - constructor. auto. generalize (size_positive a). omega. -Qed. - -(** Helper lemmas to reason about -- the "code is tail of" property -- correct translation of labels. *) - -Definition tail_nolabel (k c: bblocks) : Prop := - is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. - -Lemma tail_nolabel_refl: - forall c, tail_nolabel c c. -Proof. - intros; split. apply is_tail_refl. auto. -Qed. - -Lemma tail_nolabel_trans: - forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. -Proof. - intros. destruct H; destruct H0; split. - eapply is_tail_trans; eauto. - intros. rewrite H1; auto. -Qed. - -Definition nolabel (b: bblock) := - match (header b) with nil => True | _ => False end. - -Hint Extern 1 (nolabel _) => exact I : labels. - -Lemma tail_nolabel_cons: - forall b c k, - nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). -Proof. - intros. destruct H0. split. - constructor; auto. - intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. - destruct hd as [|l hd]; simpl in *. - - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { apply is_label_correct_false. simpl header. apply in_nil. } - rewrite H2. auto. - - contradiction. -Qed. - -Hint Resolve tail_nolabel_refl: labels. - -Ltac TailNoLabel := - eauto with labels; - match goal with - | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: assertion_failed = OK _ |- _ ] => discriminate - | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel - | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel - | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel - | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel - | _ => idtac - end. - -Remark tail_nolabel_find_label: - forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. -Proof. - intros. destruct H. auto. -Qed. - -Remark tail_nolabel_is_tail: - forall k c, tail_nolabel k c -> is_tail k c. -Proof. - intros. destruct H. auto. -Qed. - -Lemma exec_body_pc: - forall ge l rs1 m1 rs2 m2, - exec_body ge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Section STRAIGHTLINE. - -Variable ge: genv. -Variable fn: function. - -(** Straight-line code is composed of processor instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: list instruction -> regset -> mem -> - list instruction -> regset -> mem -> Prop := - | exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 - | exec_straight_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. - -Inductive exec_control_rel: option control -> bblock -> regset -> mem -> - regset -> mem -> Prop := - | exec_control_rel_intro: - forall rs1 m1 b rs1' ctl rs2 m2, - rs1' = nextblock b rs1 -> - exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> - exec_control_rel ctl b rs1 m1 rs2 m2. - -Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := - | exec_bblock_rel_intro: - forall rs1 m1 b rs2 m2, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - exec_bblock_rel b rs1 m1 rs2 m2. - -Lemma exec_straight_body: - forall c l rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - code_to_basics c = Some l -> - exec_body ge l rs1 m1 = Next rs2 m2. -Proof. - induction c as [|i c]. - - intros until m2. intros EXES CTB. inv EXES. - - intros until m2. intros EXES CTB. inv EXES. - + inv CTB. simpl. rewrite H6. auto. - + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. - rewrite <- H7. simpl. rewrite H1. auto. -Qed. - -Lemma exec_straight_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - exists body, - exec_body ge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. induction 1. - - exists (i1::nil). split; auto. simpl. rewrite H. auto. - - destruct IHexec_straight as (bdy & EXEB & BTC). - exists (i:: bdy). split; simpl. - + rewrite H. auto. - + congruence. -Qed. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - apply exec_straight_step with rs2 m2; auto. -Qed. - -Lemma exec_straight_two: - forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> - exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** Like exec_straight predicate, but on blocks *) - -Inductive exec_straight_blocks: bblocks -> regset -> mem -> - bblocks -> regset -> mem -> Prop := - | exec_straight_blocks_one: - forall b1 c rs1 m1 rs2 m2, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 - | exec_straight_blocks_step: - forall b c rs1 m1 rs2 m2 c' rs3 m3, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> - exec_straight_blocks c rs2 m2 c' rs3 m3 -> - exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_blocks_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> - exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> - exec_straight_blocks c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_blocks_step with rs2 m2; auto. - apply exec_straight_blocks_step with rs2 m2; auto. -Qed. - -(** Linking exec_straight with exec_straight_blocks *) - -Lemma exec_straight_pc: - forall c c' rs1 m1 rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - eapply exec_basic_instr_pc; eauto. - - rewrite (IHc c' rs3 m3 rs2 m2); auto. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma regset_same_assign (rs: regset) r: - rs # r <- (rs r) = rs. -Proof. - apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. -Qed. - -Lemma exec_straight_through_singleinst: - forall a b rs1 m1 rs2 m2 rs2' m2' lb, - bblock_single_inst (PBasic a) = b -> - exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - simpl. rewrite regset_same_assign. auto. - simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. -Qed. - -(** The following lemmas show that straight-line executions - (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) - -Lemma exec_straight_steps_1: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - plus step ge (State rs m) E0 (State rs' m'). -Proof. - induction 1; intros. - apply plus_one. - econstructor; eauto. - eapply find_bblock_tail. eauto. - eapply plus_left'. - econstructor; eauto. - eapply find_bblock_tail. eauto. - apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. - auto. - apply code_tail_next_int; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. -Proof. - induction 1; intros. - exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. - rewrite H0. rewrite H2. auto. - apply code_tail_next_int; auto. - apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. auto. - apply code_tail_next_int; auto. -Qed. - -End STRAIGHTLINE. - -(** * Properties of the Machblock call stack *) - -Section MATCH_STACK. - -Variable ge: MB.genv. - -Inductive match_stack: list MB.stackframe -> Prop := - | match_stack_nil: - match_stack nil - | match_stack_cons: forall fb sp ra c s f tf tc, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge ra fb f c false tf tc -> - sp <> Vundef -> - match_stack s -> - match_stack (Stackframe fb sp ra c :: s). - -Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - auto. -Qed. - -Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - inv H0. congruence. -Qed. - -Lemma lessdef_parent_sp: - forall s v, - match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. -Proof. - intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. -Qed. - -Lemma lessdef_parent_ra: - forall s v, - match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. -Proof. - intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. -Qed. - -End MATCH_STACK. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v new file mode 100644 index 00000000..940c6563 --- /dev/null +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -0,0 +1,967 @@ +(** * "block" version of Asmgenproof0 + + This module is largely adapted from Asmgenproof0.v of the other backends + It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends + It has similar definitions than Asmgenproof0, but adapted to this new structure *) + +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +Require Import Asmblockgen. +Require Import Conventions1. +Require Import Axioms. +Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) +Require Import Asmblockprops. + +Module MB:=Machblock. +Module AB:=Asmblock. + +Lemma ireg_of_eq: + forall r r', ireg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold ireg_of; intros. destruct (preg_of r); inv H; auto. +Qed. + +Lemma freg_of_eq: + forall r r', freg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold freg_of; intros. destruct (preg_of r); inv H; auto. +Qed. + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +Lemma undef_regs_other: + forall r rl rs, + (forall r', In r' rl -> r <> r') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). +Proof. + intros. unfold nextblock. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree ms sp rs -> + (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.undef_regs rl ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite <- agree_sp0. apply H0; auto. + rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. + intros. destruct (In_dec mreg_eq r rl). + rewrite Mach.undef_regs_same; auto. + rewrite Mach.undef_regs_other; auto. rewrite H0; auto. + apply preg_of_data. + rewrite preg_notin_charact. intros; red; intros. elim n. + exploit preg_of_injective; eauto. congruence. +Qed. + +Lemma agree_set_undef_mreg: + forall ms sp rs r v rl rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma agree_undef_caller_save_regs: + forall ms sp rs, + agree ms sp rs -> + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). +Proof. + intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. +- unfold proj_sumbool; rewrite dec_eq_true. auto. +- auto. +- intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. ++ apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. ++ destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + + +Local Hint Resolve code_tail_0 code_tail_S. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +Hypothesis transf_function_len: + forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + + +Lemma return_address_exists: + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. destruct (transf_function f) as [tf|] eqn:TF. + + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). + exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). + monadInv TR2. + assert (TL3: is_tail x0 (fn_blocks tf)). + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +Qed. + +End RETADDR_EXISTS. + +(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points + within the Asmblock code generated by translating Machblock function [f], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +Proof. + intros. destruct H. auto. +Qed. + +Lemma exec_body_pc: + forall ge l rs1 m1 rs2 m2, + exec_body ge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. + +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c l rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +Lemma exec_straight_two: + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +Qed. + +(** Linking exec_straight with exec_straight_blocks *) + +Lemma exec_straight_pc: + forall c c' rs1 m1 rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma regset_same_assign (rs: regset) r: + rs # r <- (rs r) = rs. +Proof. + apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. +Qed. + +Lemma exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. rewrite regset_same_assign. auto. + simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. +Qed. + +(** The following lemmas show that straight-line executions + (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. -- cgit From e882ee6daa01579bf717b43b55091c859ed75661 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 11 Feb 2020 11:28:38 +0100 Subject: Moving some arch specific theorems from PSproof to Asmblockprops --- mppa_k1c/Asmblockprops.v | 219 ++++++++++++++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingproof.v | 218 ------------------------------------ 2 files changed, 218 insertions(+), 219 deletions(-) diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v index 7f6e33db..3c6ba534 100644 --- a/mppa_k1c/Asmblockprops.v +++ b/mppa_k1c/Asmblockprops.v @@ -6,6 +6,7 @@ Require Import Memory. Require Import Globalenvs. Require Import Values. Require Import Asmblock. +Require Import Axioms. Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := forall rs m, @@ -72,6 +73,8 @@ Ltac Simplif := Ltac Simpl := repeat Simplif. +(* For Asmblockgenproof0 *) + Theorem exec_basic_instr_pc: forall ge b rs1 m1 rs2 m2, exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> @@ -123,4 +126,218 @@ Proof. - destruct rs; try discriminate. inv H1. Simpl. - destruct rd; try discriminate. inv H1; Simpl. - reflexivity. -Qed. \ No newline at end of file +Qed. + +(* For PostpassSchedulingproof *) + +Lemma regset_double_set: + forall r1 r2 (rs: regset) v1 v2, + r1 <> r2 -> + (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). +Proof. + intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). + - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. + - destruct (preg_eq r r2). + + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. + + repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma next_eq: + forall (rs rs': regset) m m', + rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + intros; apply f_equal2; auto. +Qed. + +Lemma exec_load_offset_pc_var: + forall trap t rs m rd ra ofs rs' m' v, + exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> + exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_reg_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_reg trap t rs m rd ra ro = Next rs' m' -> + exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_regxs_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> + exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_offset_q_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_q_offset rs m rd ra ofs = Next rs' m' -> + exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. + destruct (gpreg_q_expand rd) as [rd0 rd1]. + (* destruct (ireg_eq rd0 ra); try discriminate. *) + rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + inv H. + destruct (Mem.loadv _ _ _); try discriminate. + inv H1. f_equal. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + reflexivity. +Qed. + +Lemma exec_load_offset_o_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_o_offset rs m rd ra ofs = Next rs' m' -> + exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. + destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. +(* + destruct (ireg_eq rd0 ra); try discriminate. + destruct (ireg_eq rd1 ra); try discriminate. + destruct (ireg_eq rd2 ra); try discriminate. +*) + rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + rewrite (regset_double_set PC rd2) by discriminate. + rewrite (regset_double_set PC rd3) by discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_offset_pc_var: + forall t rs m rd ra ofs rs' m' v, + exec_store_offset t rs m rd ra ofs = Next rs' m' -> + exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. + destruct (eval_offset ofs); try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_q_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_q_offset rs m rd ra ofs = Next rs' m' -> + exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (gpreg_q_expand _) as [s0 s1]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. apply next_eq; auto. +Qed. + +Lemma exec_store_o_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_o_offset rs m rd ra ofs = Next rs' m' -> + exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. + unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. + destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_reg_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_reg t rs m rd ra ro = Next rs' m' -> + exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_regxs_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_regxs t rs m rd ra ro = Next rs' m' -> + exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Theorem exec_basic_instr_pc_var: + forall ge i rs m rs' m' v, + exec_basic_instr ge i rs m = Next rs' m' -> + exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. +Proof. + intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. + - unfold exec_arith_instr in *. destruct i; destruct i. + all: try (exploreInst; inv H; apply next_eq; auto; + apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). +(* + (* Some cases treated seperately because exploreInst destructs too much *) + all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) + - destruct i. + + exploreInst; apply exec_load_offset_pc_var; auto. + + exploreInst; apply exec_load_reg_pc_var; auto. + + exploreInst; apply exec_load_regxs_pc_var; auto. + + apply exec_load_offset_q_pc_var; auto. + + apply exec_load_offset_o_pc_var; auto. + - destruct i. + + exploreInst; apply exec_store_offset_pc_var; auto. + + exploreInst; apply exec_store_reg_pc_var; auto. + + exploreInst; apply exec_store_regxs_pc_var; auto. + + apply exec_store_q_offset_pc_var; auto. + + apply exec_store_o_offset_pc_var; auto. + - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.storev _ _ _ _); try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. + rewrite (regset_double_set GPR32 PC); try discriminate. + rewrite (regset_double_set GPR12 PC); try discriminate. + rewrite (regset_double_set FP PC); try discriminate. reflexivity. + - repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.loadv _ _ _); try discriminate. + destruct (rs GPR12); try discriminate. + destruct (Mem.free _ _ _ _); try discriminate. + inv H. apply next_eq; auto. + rewrite (regset_double_set GPR32 PC). + rewrite (regset_double_set GPR12 PC). reflexivity. + all: discriminate. + - destruct rs0; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - destruct rd; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - inv H. apply next_eq; auto. +Qed. + + diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f1166a38..fbb06c9b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -30,25 +30,6 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Lemma next_eq: - forall (rs rs': regset) m m', - rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - intros; apply f_equal2; auto. -Qed. - -Lemma regset_double_set: - forall r1 r2 (rs: regset) v1 v2, - r1 <> r2 -> - (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). -Proof. - intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). - - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. - - destruct (preg_eq r r2). - + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. - + repeat (rewrite Pregmap.gso; auto). -Qed. - Lemma regset_double_set_id: forall r (rs: regset) v1 v2, (rs # r <- v1 # r <- v2) = (rs # r <- v2). @@ -58,197 +39,6 @@ Proof. - repeat (rewrite Pregmap.gso); auto. Qed. -Lemma exec_load_offset_pc_var: - forall trap t rs m rd ra ofs rs' m' v, - exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> - exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_reg_pc_var: - forall trap t rs m rd ra ro rs' m' v, - exec_load_reg trap t rs m rd ra ro = Next rs' m' -> - exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_regxs_pc_var: - forall trap t rs m rd ra ro rs' m' v, - exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> - exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_offset_q_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_q_offset rs m rd ra ofs = Next rs' m' -> - exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. - destruct (gpreg_q_expand rd) as [rd0 rd1]. - (* destruct (ireg_eq rd0 ra); try discriminate. *) - rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - inv H. - destruct (Mem.loadv _ _ _); try discriminate. - inv H1. f_equal. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - reflexivity. -Qed. - -Lemma exec_load_offset_o_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_o_offset rs m rd ra ofs = Next rs' m' -> - exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. - destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. -(* - destruct (ireg_eq rd0 ra); try discriminate. - destruct (ireg_eq rd1 ra); try discriminate. - destruct (ireg_eq rd2 ra); try discriminate. -*) - rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - rewrite (regset_double_set PC rd2) by discriminate. - rewrite (regset_double_set PC rd3) by discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_offset_pc_var: - forall t rs m rd ra ofs rs' m' v, - exec_store_offset t rs m rd ra ofs = Next rs' m' -> - exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. - destruct (eval_offset ofs); try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_q_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_q_offset rs m rd ra ofs = Next rs' m' -> - exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (gpreg_q_expand _) as [s0 s1]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. apply next_eq; auto. -Qed. - -Lemma exec_store_o_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_o_offset rs m rd ra ofs = Next rs' m' -> - exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. - unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. - destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_reg_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_reg t rs m rd ra ro = Next rs' m' -> - exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_regxs_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_regxs t rs m rd ra ro = Next rs' m' -> - exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_basic_instr_pc_var: - forall ge i rs m rs' m' v, - exec_basic_instr ge i rs m = Next rs' m' -> - exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. -Proof. - intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. - - unfold exec_arith_instr in *. destruct i; destruct i. - all: try (exploreInst; inv H; apply next_eq; auto; - apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). -(* - (* Some cases treated seperately because exploreInst destructs too much *) - all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) - - destruct i. - + exploreInst; apply exec_load_offset_pc_var; auto. - + exploreInst; apply exec_load_reg_pc_var; auto. - + exploreInst; apply exec_load_regxs_pc_var; auto. - + apply exec_load_offset_q_pc_var; auto. - + apply exec_load_offset_o_pc_var; auto. - - destruct i. - + exploreInst; apply exec_store_offset_pc_var; auto. - + exploreInst; apply exec_store_reg_pc_var; auto. - + exploreInst; apply exec_store_regxs_pc_var; auto. - + apply exec_store_q_offset_pc_var; auto. - + apply exec_store_o_offset_pc_var; auto. - - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.storev _ _ _ _); try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. - rewrite (regset_double_set GPR32 PC); try discriminate. - rewrite (regset_double_set GPR12 PC); try discriminate. - rewrite (regset_double_set FP PC); try discriminate. reflexivity. - - repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.loadv _ _ _); try discriminate. - destruct (rs GPR12); try discriminate. - destruct (Mem.free _ _ _ _); try discriminate. - inv H. apply next_eq; auto. - rewrite (regset_double_set GPR32 PC). - rewrite (regset_double_set GPR12 PC). reflexivity. - all: discriminate. - - destruct rs0; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - destruct rd; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - inv H. apply next_eq; auto. -Qed. - Lemma exec_body_pc_var: forall l ge rs m rs' m' v, exec_body ge l rs m = Next rs' m' -> @@ -745,12 +535,8 @@ Qed. End PRESERVATION_ASMBLOCK. - - - Require Import Asmvliw. - Lemma verified_par_checks_alls_bundles lb x: forall bundle, verify_par lb = OK x -> List.In bundle lb -> verify_par_bblock bundle = OK tt. @@ -761,7 +547,6 @@ Proof. destruct x0; auto. Qed. - Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: verified_schedule_nob bb = OK lb -> List.In bundle lb -> verify_par_bblock bundle = OK tt. @@ -883,9 +668,6 @@ Qed. End PRESERVATION_ASMVLIW. - - - Section PRESERVATION. Variables prog tprog: program. -- cgit From 9b881b7928ab7d21e9981133bef5b26e33b6cd9d Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 11 Feb 2020 18:43:24 +0100 Subject: Take the sign into account for int to ptr cast. Casting from an integer constant to pointer on 64 bit architectures did not take the signedness into account and always interpreted the integer as unsigned which causes some incompatibility with libc implementations. --- cfrontend/Cop.v | 4 ++-- cfrontend/Ctyping.v | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index aa73abb0..143e87a3 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -140,8 +140,8 @@ Definition classify_cast (tfrom tto: type) : classify_cast_cases := | Tfloat F64 _, Tfloat F32 _ => cast_case_s2f | Tfloat F32 _, Tfloat F64 _ => cast_case_f2s (* To pointer types *) - | Tpointer _ _, Tint _ _ _ => - if Archi.ptr64 then cast_case_i2l Unsigned else cast_case_pointer + | Tpointer _ _, Tint _ si _ => + if Archi.ptr64 then cast_case_i2l si else cast_case_pointer | Tpointer _ _, Tlong _ _ => if Archi.ptr64 then cast_case_pointer else cast_case_l2i I32 Unsigned | Tpointer _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_pointer diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index b92a9bac..29ea3bf2 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -987,6 +987,7 @@ Proof. classify_cast (Tint i s a) t2 <> cast_case_default). { unfold classify_cast. destruct t2; try congruence. destruct f; congruence. + destruct Archi.ptr64; congruence. } destruct i; auto. Qed. -- cgit From 117a26880e27ae7d8efcb26d194c5ded3be642d6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 12 Feb 2020 16:47:03 +0100 Subject: Added option -ftracelinearize which linearizes based on ifnot branches --- backend/Duplicateaux.ml | 2 +- backend/Linearizeaux.ml | 57 ++++++++++++++++++++++++++++++++++++++++++++++--- driver/Clflags.ml | 1 + driver/Driver.ml | 3 +++ 4 files changed, 59 insertions(+), 4 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index c3340cca..d0b7129e 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -529,7 +529,7 @@ let tail_duplicate code preds ptree trace = in (new_code, new_ptree, !nb_duplicated) let superblockify_traces code preds traces = - let max_nb_duplicated = 2 (* FIXME - should be architecture dependent *) + let max_nb_duplicated = 1 (* FIXME - should be architecture dependent *) in let ptree = make_identity_ptree code in let rec f code ptree = function | [] -> (code, ptree, 0) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 902724e0..a6964233 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -1,4 +1,4 @@ -(* *********************************************************************) + (* *) (* The Compcert verified compiler *) (* *) @@ -12,7 +12,6 @@ open LTL open Maps -open Camlcoq (* Trivial enumeration, in decreasing order of PC *) @@ -29,6 +28,8 @@ let enumerate_aux f reach = (* More clever enumeration that flattens basic blocks *) +open Camlcoq + module IntSet = Set.Make(struct type t = int let compare = compare end) (* Determine join points: reachable nodes that have > 1 predecessor *) @@ -110,5 +111,55 @@ let flatten_blocks blks = (* Build the enumeration *) -let enumerate_aux f reach = +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). + * + * The enumeration below takes advantage of this - preferring to layout nodes + * following the fallthroughs of the Lcond branches + *) + +let get_some = function +| None -> failwith "Did not get some" +| Some thing -> thing + +exception EmptyList + +let rec last_element = function + | [] -> raise EmptyList + | e :: [] -> e + | e' :: e :: l -> last_element (e::l) + +let dfs code entrypoint = + let visited = ref (PTree.map (fun n i -> false) code) in + let rec dfs_list code = function + | [] -> [] + | node :: ln -> + let node_dfs = + if not (get_some @@ PTree.get node !visited) then begin + visited := PTree.set node true !visited; + match PTree.get node code with + | None -> failwith "No such node" + | Some bb -> [node] @ match (last_element bb) with + | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ + | Lbuiltin _ -> assert false + | Ltailcall _ | Lreturn -> [] + | Lbranch n -> dfs_list code [n] + | Lcond (_, _, ifso, ifnot) -> dfs_list code [ifnot; ifso] + | Ljumptable(_, ln) -> dfs_list code ln + end + else [] + in node_dfs @ (dfs_list code ln) + in dfs_list code [entrypoint] + +let enumerate_aux_trace f reach = dfs f.fn_code f.fn_entrypoint + +let enumerate_aux f reach = + if !Clflags.option_ftracelinearize then enumerate_aux_trace f reach + else enumerate_aux_flat f reach diff --git a/driver/Clflags.ml b/driver/Clflags.ml index a195e38b..a4ebee9c 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -29,6 +29,7 @@ let option_fcse = 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 *) +let option_ftracelinearize = ref false let option_fpostpass = ref true let option_fpostpass_sched = ref "list" let option_fifconversion = ref true diff --git a/driver/Driver.ml b/driver/Driver.ml index 3af1a937..70a3739b 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -202,6 +202,8 @@ Processing options: -fduplicate Perform tail duplication to form superblocks on predicted traces -finvertcond Invert conditions based on predicted paths (to prefer fallthrough). Requires -fduplicate to be also activated [on] + -ftracelinearize Linearizes based on the traces identified by duplicate phase + It is recommended to also activate -fduplicate with this pass [off] -fforward-moves Forward moves after CSE -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their @@ -389,6 +391,7 @@ let cmdline_actions = @ f_opt "postpass" option_fpostpass @ f_opt "duplicate" option_fduplicate @ f_opt "invertcond" option_finvertcond + @ f_opt "tracelinearize" option_ftracelinearize @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched @ f_opt "inline" option_finline @ f_opt "inline-functions-called-once" option_finline_functions_called_once -- cgit From 797829058aedff543c1f30b269b8fc8a0be35e36 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 18 Feb 2020 15:38:53 +0100 Subject: Support vertical tabs and treat them as whitespace (#218) Some preprocessors don't remove the vertical tab from the input so we should be able to handle them in the lexer. --- cparser/Lexer.mll | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll index 346477b5..e44a330f 100644 --- a/cparser/Lexer.mll +++ b/cparser/Lexer.mll @@ -177,7 +177,7 @@ let identifier_nondigit = let identifier = identifier_nondigit (identifier_nondigit|digit)* (* Whitespaces *) -let whitespace_char_no_newline = [' ' '\t' '\012' '\r'] +let whitespace_char_no_newline = [' ' '\t' '\011' '\012' '\r'] (* Integer constants *) let nonzero_digit = ['1'-'9'] -- cgit From 305d3d307fd1a83b17052119d75516946ce617b4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 19 Feb 2020 17:28:43 +0100 Subject: First part of Hansen algorithm - build the sequences --- backend/Linearizeaux.ml | 44 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 43 insertions(+), 1 deletion(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index a6964233..28719207 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -122,7 +122,11 @@ let enumerate_aux_flat f reach = * rather than a branch (ifso). * * The enumeration below takes advantage of this - preferring to layout nodes - * following the fallthroughs of the Lcond branches + * 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) *) let get_some = function @@ -136,6 +140,7 @@ let rec last_element = function | e :: [] -> e | e' :: e :: l -> last_element (e::l) +(** old version let dfs code entrypoint = let visited = ref (PTree.map (fun n i -> false) code) in let rec dfs_list code = function @@ -159,6 +164,43 @@ let dfs code entrypoint = in dfs_list code [entrypoint] let enumerate_aux_trace f reach = dfs f.fn_code f.fn_entrypoint +*) + + +let forward_sequences code entry = + let visited = ref (PTree.map (fun n i -> false) code) in + (* returns the list of traversed nodes, and a list of nodes to start traversing next *) + let rec traverse_fallthrough code node = + if not (get_some @@ PTree.get node !visited) then begin + visited := PTree.set node true !visited; + match PTree.get node code with + | None -> failwith "No such node" + | Some bb -> + let ln, rem = match (last_element bb) with + | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ + | Lbuiltin _ -> assert false + | Ltailcall _ | Lreturn -> ([], []) + | Lbranch n -> let ln, rem = traverse_fallthrough code n in (ln, rem) + | Lcond (_, _, ifso, ifnot) -> let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) + | Ljumptable(_, ln) -> match ln with + | [] -> ([], []) + | n :: ln -> let lln, rem = traverse_fallthrough code n in (lln, ln @ rem) + in ([node] @ ln, rem) + end + else ([], []) + in let rec f code = function + | [] -> [] + | node :: ln -> + let fs, rem = traverse_fallthrough code node + in [fs] @ (f code rem) + in (f code [entry]) + +let order_sequences fs = fs + +let enumerate_aux_trace f reach = + let fs = forward_sequences f.fn_code f.fn_entrypoint + in let ofs = order_sequences fs + in List.flatten ofs let enumerate_aux f reach = if !Clflags.option_ftracelinearize then enumerate_aux_trace f reach -- cgit From 840f7e5af8294d121caf1c712b75ba3c13914a54 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 20 Feb 2020 11:25:58 +0100 Subject: WIP --- backend/Linearizeaux.ml | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 28719207..8dccbb4b 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -195,6 +195,32 @@ let forward_sequences code entry = in [fs] @ (f code rem) in (f code [entry]) +let iter_set f s = Seq.iter f (Set.to_seq s) + +let try_merge code fs = + let seqs = ref (Set.of_list fs) in + let oldLength = ref (Set.cardinal !seqs) in + let continue = ref true in + while !continue do + iter_set (fun s -> + iter_set (fun s' -> + if (s == s') then () + else if (can_be_merged s s') then + begin + seqs + end + else () + ) !seqs + ) !seqs + (* FIXME - FIXME - continue *) + + + if !oldLength == List.length !seqs then + continue := false + else + oldLength := List.length !seqs + done + let order_sequences fs = fs let enumerate_aux_trace f reach = -- cgit From 87d8a302892026bc831fd5c310874f2aad6be194 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 20 Feb 2020 11:50:51 +0100 Subject: WIP2 --- backend/Linearizeaux.ml | 40 ++++++++++++++++++++++++---------------- 1 file changed, 24 insertions(+), 16 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 8dccbb4b..d7150989 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -201,25 +201,33 @@ let try_merge code fs = let seqs = ref (Set.of_list fs) in let oldLength = ref (Set.cardinal !seqs) in let continue = ref true in + let found = ref false in while !continue do - iter_set (fun s -> - iter_set (fun s' -> - if (s == s') then () - else if (can_be_merged s s') then - begin - seqs - end - else () - ) !seqs - ) !seqs - (* FIXME - FIXME - continue *) + begin + found := false; + iter_set (fun s -> + if !found then () + else iter_set (fun s' -> + if (!found || s == s') then () + else if (can_be_merged s s') then + begin + seqs := Set.remove s !seqs; + seqs := Set.remove s' !seqs; + seqs := Set.add (get_some (merge s s')) !seqs; + found := true; + end + else () + ) !seqs + ) !seqs; + if !oldLength == List.length !seqs then + continue := false + else + oldLength := List.length !seqs + end + done; + (* FIXME - continue *) - if !oldLength == List.length !seqs then - continue := false - else - oldLength := List.length !seqs - done let order_sequences fs = fs -- cgit From a9eaf4897c825093aba2137ff76e56bfbf1e72d5 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 20 Feb 2020 18:55:34 +0100 Subject: More precise determination of small data accesses (#220) We can get linker errors for addresses of the form "symbol + offset" where "symbol" is in the small data area and "offset" is large enough to overflow the relative displacement from the SDA base register. To avoid this, this commit enriches `C2C.atom_is_small_data`, which is the implementation of `Asm.symbol_is_small_data` in the PPC port, with a check that the offset is within the bounds of the symbol. If it is not, `Asm.symbol_is_small_data` returns `false` and Asmgen produces an absolute addressing instead of a SDA-relative addressing. To implement the check, we record the sizes of symbols in the atom table, just like we already record their alignments. --- cfrontend/C2C.ml | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 9ae7bbd9..293e79f0 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -33,6 +33,7 @@ type inline_status = type atom_info = { a_storage: C.storage; (* storage class *) + a_size: int64 option; (* size in bytes *) a_alignment: int option; (* alignment *) a_sections: Sections.section_name list; (* in which section to put it *) (* 1 section for data, 3 sections (code/lit/jumptbl) for functions *) @@ -72,9 +73,14 @@ let atom_sections a = with Not_found -> [] -let atom_is_small_data a ofs = +let atom_is_small_data a ofs = try - (Hashtbl.find decl_atom a).a_access = Sections.Access_near + let info = Hashtbl.find decl_atom a in + info.a_access = Sections.Access_near + && (match info.a_size with + | None -> false + | Some sz -> + let ofs = camlint64_of_ptrofs ofs in 0L <= ofs && ofs < sz) with Not_found -> false @@ -352,6 +358,7 @@ let name_for_string_literal s = Hashtbl.add decl_atom id { a_storage = C.Storage_static; a_alignment = Some 1; + a_size = Some (Int64.of_int (String.length s + 1)); a_sections = [Sections.for_stringlit()]; a_access = Sections.Access_default; a_inline = No_specifier; @@ -379,9 +386,12 @@ let name_for_wide_string_literal s = incr stringNum; let name = Printf.sprintf "__stringlit_%d" !stringNum in let id = intern_string name in + let wchar_size = Machine.((!config).sizeof_wchar) in Hashtbl.add decl_atom id { a_storage = C.Storage_static; - a_alignment = Some Machine.((!config).sizeof_wchar); + a_alignment = Some wchar_size; + a_size = Some (Int64.(mul (of_int (List.length s + 1)) + (of_int wchar_size))); a_sections = [Sections.for_stringlit()]; a_access = Sections.Access_default; a_inline = No_specifier; @@ -1223,6 +1233,7 @@ let convertFundef loc env fd = Hashtbl.add decl_atom id' { a_storage = fd.fd_storage; a_alignment = None; + a_size = None; a_sections = Sections.for_function env id' fd.fd_attrib; a_access = Sections.Access_default; a_inline = inline; @@ -1309,6 +1320,7 @@ let convertGlobvar loc env (sto, id, ty, optinit) = Hashtbl.add decl_atom id' { a_storage = sto; a_alignment = Some (Z.to_int al); + a_size = Some (Z.to_int64 sz); a_sections = [section]; a_access = access; a_inline = No_specifier; -- cgit From 0271028f40c58068975170476dcaa5aadc21cb7e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 21 Feb 2020 11:44:43 +0100 Subject: Linearizeaux: function try_merge --- backend/Linearizeaux.ml | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index d7150989..44322a46 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -195,11 +195,22 @@ let forward_sequences code entry = in [fs] @ (f code rem) in (f code [entry]) -let iter_set f s = Seq.iter f (Set.to_seq s) +module PInt = struct + type t = P.t + let compare x y = compare (P.to_int x) (P.to_int y) +end + +module PSet = Set.Make(PInt) + +let iter_set f s = Seq.iter f (PSet.to_seq s) + +let can_be_merged s s' = false + +let merge s s' = Some s let try_merge code fs = - let seqs = ref (Set.of_list fs) in - let oldLength = ref (Set.cardinal !seqs) in + let seqs = ref (PSet.of_list fs) in + let oldLength = ref (PSet.cardinal !seqs) in let continue = ref true in let found = ref false in while !continue do @@ -211,23 +222,21 @@ let try_merge code fs = if (!found || s == s') then () else if (can_be_merged s s') then begin - seqs := Set.remove s !seqs; - seqs := Set.remove s' !seqs; - seqs := Set.add (get_some (merge s s')) !seqs; + seqs := PSet.remove s !seqs; + seqs := PSet.remove s' !seqs; + seqs := PSet.add (get_some (merge s s')) !seqs; found := true; end else () ) !seqs ) !seqs; - if !oldLength == List.length !seqs then + if !oldLength == PSet.cardinal !seqs then continue := false else - oldLength := List.length !seqs + oldLength := PSet.cardinal !seqs end done; - (* FIXME - continue *) - - + !seqs let order_sequences fs = fs -- cgit From be0b1872bf2ad36df9b0c7a0ffa63b9e77fa769b Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 18 Feb 2020 16:57:17 +0100 Subject: Refine the type of function results in AST.signature Before it was "option typ". Now it is a proper inductive type that can also express small integer types (8/16-bit unsigned/signed integers). One benefit is that external functions get more precise types that control better their return values. As a consequence, the CompCert C type preservation property now holds unconditionally, without extra typing hypotheses on external functions. --- aarch64/Builtins1.v | 2 +- aarch64/Conventions1.v | 17 +++++---- arm/Builtins1.v | 2 +- arm/Conventions1.v | 26 +++++++------- backend/Allocation.v | 10 +++--- backend/Allocproof.v | 15 ++++---- backend/Asmexpandaux.ml | 2 +- backend/Cminor.v | 20 ++++++++--- backend/Cminortyping.v | 45 ++++++++++++----------- backend/PrintAsmaux.ml | 6 ++-- backend/PrintCminor.ml | 4 +-- backend/RTLgen.v | 16 ++++----- backend/RTLgenspec.v | 12 +++---- backend/RTLtyping.v | 35 +++++++++--------- backend/SplitLong.vp | 14 ++++---- backend/Tailcall.v | 2 +- backend/Tailcallproof.v | 10 +++--- cfrontend/Csem.v | 2 +- cfrontend/Cshmgen.v | 4 +-- cfrontend/Csyntax.v | 2 +- cfrontend/Ctypes.v | 19 ++++++++-- cfrontend/Ctyping.v | 86 ++++++++++++++++++++++++++++---------------- cfrontend/PrintCsyntax.ml | 4 +-- common/AST.v | 79 +++++++++++++++++++++++++++++----------- common/Builtins.v | 2 +- common/Builtins0.v | 64 ++++++++++++++++----------------- common/Events.v | 45 ++++++++++++++--------- common/Memdata.v | 24 ++++++++----- common/Memory.v | 9 +++++ common/Memtype.v | 5 +++ common/PrintAST.ml | 8 +++++ common/Values.v | 33 ++++++++++++++++- coq | 2 +- driver/Interp.ml | 2 +- exportclight/ExportClight.ml | 12 +++++-- powerpc/Asmexpand.ml | 2 +- powerpc/Builtins1.v | 2 +- powerpc/Conventions1.v | 28 +++++++-------- riscV/Builtins1.v | 2 +- riscV/Conventions1.v | 21 ++++++----- x86/Asmexpand.ml | 2 +- x86/Builtins1.v | 4 +-- x86/Conventions1.v | 30 ++++++++-------- 43 files changed, 445 insertions(+), 286 deletions(-) diff --git a/aarch64/Builtins1.v b/aarch64/Builtins1.v index f6e643d2..53c83d7e 100644 --- a/aarch64/Builtins1.v +++ b/aarch64/Builtins1.v @@ -29,5 +29,5 @@ Definition platform_builtin_table : list (string * platform_builtin) := Definition platform_builtin_sig (b: platform_builtin) : signature := match b with end. -Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := match b with end. diff --git a/aarch64/Conventions1.v b/aarch64/Conventions1.v index 5914e8f2..575d058d 100644 --- a/aarch64/Conventions1.v +++ b/aarch64/Conventions1.v @@ -102,10 +102,9 @@ Definition is_float_reg (r: mreg): bool := with one integer result. *) Definition loc_result (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One R0 - | Some (Tint | Tlong | Tany32 | Tany64) => One R0 - | Some (Tfloat | Tsingle) => One F0 + match proj_sig_res s with + | Tint | Tlong | Tany32 | Tany64 => One R0 + | Tfloat | Tsingle => One F0 end. (** The result registers have types compatible with that given in the signature. *) @@ -114,7 +113,7 @@ 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. destruct (sig_res sig) as [[]|]; auto. + intros. unfold loc_result. destruct (proj_sig_res sig); auto. Qed. (** The result locations are caller-save registers *) @@ -124,7 +123,7 @@ Lemma loc_result_caller_save: forall_rpair (fun r => is_callee_save r = false) (loc_result s). Proof. intros. - unfold loc_result. destruct (sig_res s) as [[]|]; simpl; auto. + unfold loc_result. destruct (proj_sig_res s); simpl; auto. Qed. (** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) @@ -134,12 +133,12 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong + 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) as [[]|]; exact I. + intros; unfold loc_result; destruct (proj_sig_res sg); exact I. Qed. (** The location of the result depends only on the result part of the signature *) @@ -147,7 +146,7 @@ Qed. 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. + intros. unfold loc_result, proj_sig_res. rewrite H; auto. Qed. (** ** Location of function arguments *) diff --git a/arm/Builtins1.v b/arm/Builtins1.v index f6e643d2..53c83d7e 100644 --- a/arm/Builtins1.v +++ b/arm/Builtins1.v @@ -29,5 +29,5 @@ Definition platform_builtin_table : list (string * platform_builtin) := Definition platform_builtin_sig (b: platform_builtin) : signature := match b with end. -Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := match b with end. diff --git a/arm/Conventions1.v b/arm/Conventions1.v index c5277e8d..45008bff 100644 --- a/arm/Conventions1.v +++ b/arm/Conventions1.v @@ -104,13 +104,12 @@ Definition is_float_reg (r: mreg): bool := representation with a single LDM instruction. *) 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 F0 - | Some Tlong => if Archi.big_endian - then Twolong R0 R1 - else Twolong R1 R0 + match proj_sig_res s with + | Tint | Tany32 => One R0 + | Tfloat | Tsingle | Tany64 => One F0 + | Tlong => if Archi.big_endian + then Twolong R0 R1 + else Twolong R1 R0 end. (** The result registers have types compatible with that given in the signature. *) @@ -119,7 +118,7 @@ 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. destruct (sig_res sig) as [[]|]; destruct Archi.big_endian; auto. + intros. unfold loc_result. destruct (proj_sig_res sig); destruct Archi.big_endian; auto. Qed. (** The result locations are caller-save registers *) @@ -129,7 +128,7 @@ Lemma loc_result_caller_save: forall_rpair (fun r => is_callee_save r = false) (loc_result s). Proof. intros. - unfold loc_result. destruct (sig_res s) as [[]|]; destruct Archi.big_endian; simpl; auto. + unfold loc_result. destruct (proj_sig_res s); destruct Archi.big_endian; simpl; auto. Qed. (** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) @@ -139,14 +138,13 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong + 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) as [[]|]; destruct Archi.big_endian; auto. - intuition congruence. - intuition congruence. + intros; unfold loc_result; destruct (proj_sig_res sg); auto. + destruct Archi.big_endian; intuition congruence. Qed. (** The location of the result depends only on the result part of the signature *) @@ -154,7 +152,7 @@ Qed. 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. + intros. unfold loc_result, proj_sig_res. rewrite H; auto. Qed. (** ** Location of function arguments *) diff --git a/backend/Allocation.v b/backend/Allocation.v index 13e14530..08e0a4f4 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -734,11 +734,11 @@ Function add_equations_args (rl: list reg) (tyl: list typ) (ll: list (rpair loc) (** [add_equations_res] is similar but is specialized to the case where there is only one pseudo-register. *) -Function add_equations_res (r: reg) (oty: option typ) (p: rpair mreg) (e: eqs) : option eqs := - match p, oty with +Function add_equations_res (r: reg) (ty: typ) (p: rpair mreg) (e: eqs) : option eqs := + match p, ty with | One mr, _ => Some (add_equation (Eq Full r (R mr)) e) - | Twolong mr1 mr2, Some Tlong => + | Twolong mr1 mr2, Tlong => if Archi.ptr64 then None else Some (add_equation (Eq Low r (R mr2)) (add_equation (Eq High r (R mr1)) e)) | _, _ => @@ -1084,7 +1084,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv) | BStailcall sg ros args mv1 ros' => let args' := loc_arguments sg in assertion (tailcall_is_possible sg); - assertion (opt_typ_eq sg.(sig_res) f.(RTL.fn_sig).(sig_res)); + assertion (rettype_eq sg.(sig_res) f.(RTL.fn_sig).(sig_res)); assertion (ros_compatible_tailcall ros'); do e1 <- add_equation_ros ros ros' empty_eqs; do e2 <- add_equations_args args (sig_args sg) args' e1; @@ -1114,7 +1114,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv) track_moves env mv empty_eqs | BSreturn (Some arg) mv => let arg' := loc_result (RTL.fn_sig f) in - do e1 <- add_equations_res arg (sig_res (RTL.fn_sig f)) arg' empty_eqs; + do e1 <- add_equations_res arg (proj_sig_res (RTL.fn_sig f)) arg' empty_eqs; track_moves env mv e1 end. diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 1804f46b..51755912 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -1301,10 +1301,10 @@ Proof. Qed. Lemma add_equations_res_lessdef: - forall r oty l e e' rs ls, - add_equations_res r oty l e = Some e' -> + 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 (match oty with Some ty => ty | None => Tint end) -> + Val.has_type rs#r ty -> Val.lessdef rs#r (Locmap.getpair (map_rpair R l) ls). Proof. intros. functional inversion H; simpl. @@ -1892,7 +1892,7 @@ Qed. Inductive match_stackframes: list RTL.stackframe -> list LTL.stackframe -> signature -> Prop := | match_stackframes_nil: forall sg, - sg.(sig_res) = Some Tint -> + 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 @@ -2425,13 +2425,13 @@ Proof. (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 H13. apply WTRS. + 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. - unfold proj_sig_res. rewrite <- H11; rewrite H13. apply WTRS. + rewrite <- H11, <- H14. apply WTRS. (* internal function *) - monadInv FUN. simpl in *. @@ -2463,7 +2463,8 @@ Proof. 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). - exploit external_call_well_typed; eauto. unfold proj_sig_res; rewrite B. intros WTRES'. + 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). diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml index f5c76925..0530abe4 100644 --- a/backend/Asmexpandaux.ml +++ b/backend/Asmexpandaux.ml @@ -96,7 +96,7 @@ let translate_annot sp preg_to_dwarf annot = | a::_ -> aux a) let builtin_nop = - let signature ={sig_args = []; sig_res = None; sig_cc = cc_default} in + let signature ={sig_args = []; sig_res = Tvoid; sig_cc = cc_default} in let name = coqstring_of_camlstring "__builtin_nop" in Pbuiltin(EF_builtin(name,signature),[],BR_none) diff --git a/backend/Cminor.v b/backend/Cminor.v index ca01ad50..91a4c104 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -676,12 +676,24 @@ Definition outcome_block (out: outcome) : outcome := | out => out end. +(* Definition outcome_result_value - (out: outcome) (retsig: option typ) (vres: val) : Prop := + (out: outcome) (retsig: rettype) (vres: val) : Prop := match out with | Out_normal => vres = Vundef | Out_return None => vres = Vundef - | Out_return (Some v) => retsig <> None /\ vres = v + | Out_return (Some v) => retsig <> Tvoid /\ vres = v + | Out_tailcall_return v => vres = v + | _ => False + end. +*) + +Definition outcome_result_value + (out: outcome) (vres: val) : Prop := + match out with + | Out_normal => vres = Vundef + | Out_return None => vres = Vundef + | Out_return (Some v) => vres = v | Out_tailcall_return v => vres = v | _ => False end. @@ -711,7 +723,7 @@ Inductive eval_funcall: Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> exec_stmt f (Vptr sp Ptrofs.zero) e m1 f.(fn_body) t e2 m2 out -> - outcome_result_value out f.(fn_sig).(sig_res) vres -> + outcome_result_value out vres -> outcome_free_mem out m2 sp f.(fn_stackspace) m3 -> eval_funcall m (Internal f) vargs t m3 vres | eval_funcall_external: @@ -995,7 +1007,7 @@ Proof. subst vres. replace k with (call_cont k') by congruence. apply star_one. apply step_return_0; auto. (* Out_return Some *) - destruct H3. subst vres. + subst vres. replace k with (call_cont k') by congruence. apply star_one. eapply step_return_1; eauto. (* Out_tailcall_return *) diff --git a/backend/Cminortyping.v b/backend/Cminortyping.v index fccbda27..92ec45f2 100644 --- a/backend/Cminortyping.v +++ b/backend/Cminortyping.v @@ -130,7 +130,7 @@ Definition opt_set (e: S.typenv) (optid: option ident) (ty: typ) : res S.typenv | Some id => S.set e id ty end. -Fixpoint type_stmt (tret: option typ) (e: S.typenv) (s: stmt) : res S.typenv := +Fixpoint type_stmt (tret: rettype) (e: S.typenv) (s: stmt) : res S.typenv := match s with | Sskip => OK e | Sassign id a => type_assign e id a @@ -141,7 +141,7 @@ Fixpoint type_stmt (tret: option typ) (e: S.typenv) (s: stmt) : res S.typenv := do e2 <- type_exprlist e1 args sg.(sig_args); opt_set e2 optid (proj_sig_res sg) | Stailcall sg fn args => - assertion (opt_typ_eq sg.(sig_res) tret); + assertion (rettype_eq sg.(sig_res) tret); do e1 <- type_expr e fn Tptr; type_exprlist e1 args sg.(sig_args) | Sbuiltin optid ef args => @@ -163,10 +163,14 @@ Fixpoint type_stmt (tret: option typ) (e: S.typenv) (s: stmt) : res S.typenv := | Sswitch sz a tbl dfl => type_expr e a (if sz then Tlong else Tint) | Sreturn opta => - match opta, tret with - | None, _ => OK e - | Some a, Some t => type_expr e a t - | _, _ => Error (msg "inconsistent return") + match opta with + | None => OK e + | Some a => type_expr e a (proj_rettype tret) +(* + if rettype_eq tret Tvoid + then Error (msg "inconsistent return") + else type_expr e a (proj_rettype tret) +*) end | Slabel lbl s1 => type_stmt tret e s1 @@ -186,7 +190,7 @@ Definition type_function (f: function) : res typenv := Section SPEC. Variable env: ident -> typ. -Variable tret: option typ. +Variable tret: rettype. Inductive wt_expr: expr -> typ -> Prop := | wt_Evar: forall id, @@ -205,9 +209,9 @@ Inductive wt_expr: expr -> typ -> Prop := wt_expr a1 Tptr -> wt_expr (Eload chunk a1) (type_of_chunk chunk). -Definition wt_opt_assign (optid: option ident) (optty: option typ) : Prop := +Definition wt_opt_assign (optid: option ident) (ty: rettype) : Prop := match optid with - | Some id => match optty with Some ty => ty | None => Tint end = env id + | Some id => proj_rettype ty = env id | _ => True end. @@ -251,8 +255,8 @@ Inductive wt_stmt: stmt -> Prop := wt_stmt (Sswitch sz a tbl dfl) | wt_Sreturn_none: wt_stmt (Sreturn None) - | wt_Sreturn_some: forall a t, - tret = Some t -> wt_expr a t -> + | wt_Sreturn_some: forall a, + wt_expr a (proj_rettype tret) -> wt_stmt (Sreturn (Some a)) | wt_Slabel: forall lbl s1, wt_stmt s1 -> @@ -393,7 +397,7 @@ Proof. - constructor; eauto. - constructor. - constructor; eauto using type_expr_sound with ty. -- destruct tret, o; try (monadInv T); econstructor; eauto using type_expr_sound with ty. +- destruct o; try (monadInv T); econstructor; eauto using type_expr_sound with ty. - constructor; eauto. - constructor. Qed. @@ -414,9 +418,9 @@ Definition wt_env (env: typenv) (e: Cminor.env) : Prop := Definition def_env (f: function) (e: Cminor.env) : Prop := forall id, In id f.(fn_params) \/ In id f.(fn_vars) -> exists v, e!id = Some v. -Inductive wt_cont_call: cont -> option typ -> Prop := +Inductive wt_cont_call: cont -> rettype -> Prop := | wt_cont_Kstop: - wt_cont_call Kstop (Some Tint) + wt_cont_call Kstop Tint | wt_cont_Kcall: forall optid f sp e k tret env (WT_FN: wt_function env f) (WT_CONT: wt_cont env f.(fn_sig).(sig_res) k) @@ -425,7 +429,7 @@ Inductive wt_cont_call: cont -> option typ -> Prop := (WT_DEST: wt_opt_assign env optid tret), wt_cont_call (Kcall optid f sp e k) tret -with wt_cont: typenv -> option typ -> cont -> Prop := +with wt_cont: typenv -> rettype -> cont -> Prop := | wt_cont_Kseq: forall env tret s k, wt_stmt env tret s -> wt_cont env tret k -> @@ -451,7 +455,7 @@ Inductive wt_state: state -> Prop := (WT_CONT: wt_cont_call k (funsig f).(sig_res)), wt_state (Callstate f args k m) | wt_return_state: forall v k m tret - (WT_RES: Val.has_type v (match tret with None => Tint | Some t => t end)) + (WT_RES: Val.has_type v (proj_rettype tret)) (WT_CONT: wt_cont_call k tret), wt_state (Returnstate v k m). @@ -651,9 +655,8 @@ Proof. rewrite H8; eapply call_cont_wt; eauto. - inv WT_STMT. exploit external_call_well_typed; eauto. intros TRES. econstructor; eauto using wt_Sskip. - unfold proj_sig_res in TRES; red in H5. - destruct optid. rewrite H5 in TRES. apply wt_env_assign; auto. assumption. - destruct optid. apply def_env_assign; auto. assumption. + destruct optid; auto. apply wt_env_assign; auto. rewrite <- H5; auto. + destruct optid; auto. apply def_env_assign; auto. - inv WT_STMT. econstructor; eauto. econstructor; eauto. - inv WT_STMT. destruct b; econstructor; eauto. - inv WT_STMT. econstructor; eauto. econstructor; eauto. constructor; auto. @@ -664,7 +667,7 @@ Proof. - econstructor; eauto using wt_Sexit. - inv WT_STMT. econstructor; eauto using call_cont_wt. exact I. - inv WT_STMT. econstructor; eauto using call_cont_wt. - rewrite H2. eapply wt_eval_expr; eauto. + eapply wt_eval_expr; eauto. - inv WT_STMT. econstructor; eauto. - inversion WT_FN; subst. assert (WT_CK: wt_cont env (sig_res (fn_sig f)) (call_cont k)). @@ -675,7 +678,7 @@ Proof. constructor; auto. apply wt_env_set_locals. apply wt_env_set_params. rewrite H2; auto. red; intros. apply def_set_locals. destruct H4; auto. left; apply def_set_params; auto. -- exploit external_call_well_typed; eauto. unfold proj_sig_res. simpl in *. intros. +- exploit external_call_well_typed; eauto. intros. econstructor; eauto. - inv WT_CONT. econstructor; eauto using wt_Sskip. red in WT_DEST. diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 8652b2c5..d82e6f84 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -99,7 +99,7 @@ let exists_constants () = let current_function_stacksize = ref 0l let current_function_sig = - ref { sig_args = []; sig_res = None; sig_cc = cc_default } + ref { sig_args = []; sig_res = Tvoid; sig_cc = cc_default } (* Functions for printing of symbol names *) let elf_symbol oc symb = @@ -268,8 +268,8 @@ let re_asm_param_2 = Str.regexp "%\\([QR]?\\)\\([0-9]+\\)" let print_inline_asm print_preg oc txt sg args res = let (operands, ty_operands) = match sg.sig_res with - | None -> (args, sg.sig_args) - | Some tres -> (builtin_arg_of_res res :: args, tres :: sg.sig_args) in + | Tvoid -> (args, sg.sig_args) + | tres -> (builtin_arg_of_res res :: args, proj_rettype tres :: sg.sig_args) in let print_fragment = function | Str.Text s -> output_string oc s diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml index 8c255a65..b77c5645 100644 --- a/backend/PrintCminor.ml +++ b/backend/PrintCminor.ml @@ -193,9 +193,7 @@ let print_sig p sg = List.iter (fun t -> fprintf p "%s ->@ " (name_of_type t)) sg.sig_args; - match sg.sig_res with - | None -> fprintf p "void" - | Some ty -> fprintf p "%s" (name_of_type ty) + fprintf p "%s" (name_of_rettype sg.sig_res) let rec just_skips s = match s with diff --git a/backend/RTLgen.v b/backend/RTLgen.v index 9d7a8506..f7280c9e 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -410,12 +410,11 @@ Fixpoint convert_builtin_args {A: Type} (al: list (builtin_arg expr)) (rl: list a1' :: convert_builtin_args al rl1 end. -Definition convert_builtin_res (map: mapping) (oty: option typ) (r: builtin_res ident) : mon (builtin_res reg) := - match r, oty with - | BR id, _ => do r <- find_var map id; ret (BR r) - | BR_none, None => ret BR_none - | BR_none, Some _ => do r <- new_reg; ret (BR r) - | _, _ => error (Errors.msg "RTLgen: bad builtin_res") +Definition convert_builtin_res (map: mapping) (ty: rettype) (r: builtin_res ident) : mon (builtin_res reg) := + match r with + | BR id => do r <- find_var map id; ret (BR r) + | BR_none => if rettype_eq ty Tvoid then ret BR_none else (do r <- new_reg; ret (BR r)) + | _ => error (Errors.msg "RTLgen: bad builtin_res") end. (** Translation of an expression. [transl_expr map a rd nd] @@ -667,10 +666,7 @@ Fixpoint reserve_labels (s: stmt) (ms: labelmap * state) (** Translation of a CminorSel function. *) Definition ret_reg (sig: signature) (rd: reg) : option reg := - match sig.(sig_res) with - | None => None - | Some ty => Some rd - end. + if rettype_eq sig.(sig_res) Tvoid then None else Some rd. Definition transl_fun (f: CminorSel.function) (ngoto: labelmap): mon (node * list reg) := do (rparams, map1) <- add_vars init_mapping f.(CminorSel.fn_params); diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 17022a7d..72693f63 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -639,8 +639,8 @@ Lemma new_reg_return_ok: map_valid map s1 -> return_reg_ok s2 map (ret_reg sig r). Proof. - intros. unfold ret_reg. destruct (sig_res sig); constructor. - eauto with rtlg. eauto with rtlg. + intros. unfold ret_reg. + destruct (rettype_eq (sig_res sig) Tvoid); constructor; eauto with rtlg. Qed. (** * Relational specification of the translation *) @@ -1224,9 +1224,9 @@ Lemma convert_builtin_res_charact: Proof. destruct res; simpl; intros. - monadInv TR. constructor. unfold find_var in EQ. destruct (map_vars map)!x; inv EQ; auto. -- destruct oty; monadInv TR. -+ constructor. eauto with rtlg. +- destruct (rettype_eq oty Tvoid); monadInv TR. + constructor. ++ constructor. eauto with rtlg. - monadInv TR. Qed. @@ -1350,7 +1350,7 @@ Proof. intros [C D]. eapply tr_function_intro; eauto with rtlg. eapply transl_stmt_charact; eauto with rtlg. - unfold ret_reg. destruct (sig_res (CminorSel.fn_sig f)). - constructor. eauto with rtlg. eauto with rtlg. + unfold ret_reg. destruct (rettype_eq (sig_res (CminorSel.fn_sig f)) Tvoid). constructor. + constructor; eauto with rtlg. Qed. diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 8336d1bf..5b8646ea 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -151,11 +151,12 @@ Inductive wt_instr : instruction -> Prop := list_length_z tbl * 4 <= Int.max_unsigned -> wt_instr (Ijumptable arg tbl) | wt_Ireturn_none: - funct.(fn_sig).(sig_res) = None -> + funct.(fn_sig).(sig_res) = Tvoid -> wt_instr (Ireturn None) | wt_Ireturn_some: forall arg ty, - funct.(fn_sig).(sig_res) = Some ty -> + funct.(fn_sig).(sig_res) <> Tvoid -> + env arg = proj_sig_res funct.(fn_sig) -> env arg = ty -> wt_instr (Ireturn (Some arg)). @@ -298,7 +299,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv := | Itailcall sig ros args => do e1 <- type_ros e ros; do e2 <- S.set_list e1 args sig.(sig_args); - if opt_typ_eq sig.(sig_res) f.(fn_sig).(sig_res) then + if rettype_eq sig.(sig_res) f.(fn_sig).(sig_res) then if tailcall_is_possible sig then OK e2 else Error(msg "tailcall not possible") @@ -323,9 +324,9 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv := then OK e1 else Error(msg "jumptable too big") | Ireturn optres => - match optres, f.(fn_sig).(sig_res) with - | None, None => OK e - | Some r, Some t => S.set e r t + match optres, rettype_eq f.(fn_sig).(sig_res) Tvoid with + | None, left _ => OK e + | Some r, right _ => S.set e r (proj_sig_res f.(fn_sig)) | _, _ => Error(msg "bad return") end end. @@ -468,7 +469,7 @@ Proof. destruct l; try discriminate. destruct l; monadInv EQ0. eauto with ty. destruct (type_of_operation o) as [targs tres] eqn:TYOP. monadInv EQ0. eauto with ty. - (* tailcall *) - destruct (opt_typ_eq (sig_res s) (sig_res (fn_sig f))); try discriminate. + destruct (rettype_eq (sig_res s) (sig_res (fn_sig f))); try discriminate. destruct (tailcall_is_possible s) eqn:TCIP; inv EQ2. eauto with ty. - (* builtin *) @@ -477,7 +478,8 @@ Proof. destruct (zle (list_length_z l * 4) Int.max_unsigned); inv EQ2. eauto with ty. - (* return *) - simpl in H. destruct o as [r|] eqn: RET; destruct (sig_res (fn_sig f)) as [t|] eqn: RES; try discriminate. + simpl in H. + destruct o as [r|] eqn: RET; destruct (rettype_eq (sig_res (fn_sig f)) Tvoid); try discriminate. eauto with ty. inv H; auto with ty. Qed. @@ -519,7 +521,7 @@ Proof. eapply S.set_sound; eauto with ty. eauto with ty. - (* tailcall *) - destruct (opt_typ_eq (sig_res s) (sig_res (fn_sig f))); try discriminate. + destruct (rettype_eq (sig_res s) (sig_res (fn_sig f))); try discriminate. destruct (tailcall_is_possible s) eqn:TCIP; inv EQ2. constructor. eapply type_ros_sound; eauto with ty. @@ -543,8 +545,9 @@ Proof. eapply check_successors_sound; eauto. auto. - (* return *) - simpl in H. destruct o as [r|] eqn: RET; destruct (sig_res (fn_sig f)) as [t|] eqn: RES; try discriminate. - econstructor. eauto. eapply S.set_sound; eauto with ty. + simpl in H. + destruct o as [r|] eqn: RET; destruct (rettype_eq (sig_res (fn_sig f)) Tvoid); try discriminate. + econstructor. auto. eapply S.set_sound; eauto with ty. eauto. inv H. constructor. auto. Qed. @@ -721,9 +724,9 @@ Proof. rewrite check_successor_complete by auto; simpl. apply IHtbl0; intros; auto. - (* return none *) - rewrite H0. exists e; auto. + rewrite H0, dec_eq_true. exists e; auto. - (* return some *) - rewrite H0. apply S.set_complete; auto. + rewrite dec_eq_false by auto. apply S.set_complete; auto. Qed. Lemma type_code_complete: @@ -872,7 +875,7 @@ Qed. Inductive wt_stackframes: list stackframe -> signature -> Prop := | wt_stackframes_nil: forall sg, - sg.(sig_res) = Some Tint -> + sg.(sig_res) = Tint -> wt_stackframes nil sg | wt_stackframes_cons: forall s res f sp pc rs env sg, @@ -964,13 +967,13 @@ Proof. econstructor; eauto. (* Ireturn *) econstructor; eauto. - inv WTI; simpl. auto. unfold proj_sig_res; rewrite H2. auto. + inv WTI; simpl. auto. rewrite <- H3. auto. (* internal function *) simpl in *. inv H5. econstructor; eauto. inv H1. apply wt_init_regs; auto. rewrite wt_params0. auto. (* external function *) - econstructor; eauto. simpl. + econstructor; eauto. eapply external_call_well_typed; eauto. (* return *) inv H1. econstructor; eauto. diff --git a/backend/SplitLong.vp b/backend/SplitLong.vp index de954482..694bb0e2 100644 --- a/backend/SplitLong.vp +++ b/backend/SplitLong.vp @@ -43,13 +43,13 @@ Class helper_functions := mk_helper_functions { i64_smulh: ident; (**r signed multiply high *) }. -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_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. diff --git a/backend/Tailcall.v b/backend/Tailcall.v index 939abeea..b7a62d74 100644 --- a/backend/Tailcall.v +++ b/backend/Tailcall.v @@ -82,7 +82,7 @@ Definition transf_instr (f: function) (pc: node) (instr: instruction) := | Icall sig ros args res s => if is_return niter f s res && tailcall_is_possible sig - && opt_typ_eq sig.(sig_res) f.(fn_sig).(sig_res) + && rettype_eq sig.(sig_res) f.(fn_sig).(sig_res) then Itailcall sig ros args else instr | _ => instr diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 06e314f3..9ec89553 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -157,12 +157,10 @@ Lemma transf_instr_charact: transf_instr_spec f instr (transf_instr f pc instr). Proof. intros. unfold transf_instr. destruct instr; try constructor. - caseEq (is_return niter f n r && tailcall_is_possible s && - opt_typ_eq (sig_res s) (sig_res (fn_sig f))); intros. - destruct (andb_prop _ _ H0). destruct (andb_prop _ _ H1). - eapply transf_instr_tailcall; eauto. - eapply is_return_charact; eauto. - constructor. + destruct (is_return niter f n r && tailcall_is_possible s && + rettype_eq (sig_res s) (sig_res (fn_sig f))) eqn:B. +- InvBooleans. eapply transf_instr_tailcall; eauto. eapply is_return_charact; eauto. +- constructor. Qed. Lemma transf_instr_lookup: diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index a76a14ba..6d2b470f 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -444,7 +444,7 @@ Lemma red_selection: Proof. intros. unfold Eselection. set (t := typ_of_type ty). - set (sg := mksignature (AST.Tint :: t :: t :: nil) (Some t) cc_default). + set (sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default). assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select t))). { unfold sg, t; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 792a73f9..ee135dcd 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -602,7 +602,7 @@ Fixpoint transl_statement (ce: composite_env) (tyret: type) (nbrk ncnt: nat) do tb <- transl_expr ce b; do tcl <- transl_arglist ce cl args; OK(Scall x {| sig_args := typlist_of_arglist cl args; - sig_res := opttyp_of_type res; + sig_res := rettype_of_type res; sig_cc := cconv |} tb tcl) | _ => Error(msg "Cshmgen.transl_stmt(call)") @@ -667,7 +667,7 @@ Definition transl_var (ce: composite_env) (v: ident * type) := Definition signature_of_function (f: Clight.function) := {| sig_args := map typ_of_type (map snd (Clight.fn_params f)); - sig_res := opttyp_of_type (Clight.fn_return f); + sig_res := rettype_of_type (Clight.fn_return f); sig_cc := Clight.fn_callconv f |}. Definition transl_function (ce: composite_env) (f: Clight.function) : res function := diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index c34a5e13..e3e2c1e9 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -106,7 +106,7 @@ Definition Epreincr (id: incr_or_decr) (l: expr) (ty: type) := Definition Eselection (r1 r2 r3: expr) (ty: type) := let t := typ_of_type ty in - let sg := mksignature (AST.Tint :: t :: t :: nil) (Some t) cc_default in + let sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default in Ebuiltin (EF_builtin "__builtin_sel"%string sg) (Tcons type_bool (Tcons ty (Tcons ty Tnil))) (Econs r1 (Econs r2 (Econs r3 Enil))) diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index bfc5daa9..664a60c5 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -732,8 +732,21 @@ Definition typ_of_type (t: type) : AST.typ := | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _ | Tstruct _ _ | Tunion _ _ => AST.Tptr end. -Definition opttyp_of_type (t: type) : option AST.typ := - if type_eq t Tvoid then None else Some (typ_of_type t). +Definition rettype_of_type (t: type) : AST.rettype := + match t with + | Tvoid => AST.Tvoid + | Tint I32 _ _ => AST.Tint + | Tint I8 Signed _ => AST.Tint8signed + | Tint I8 Unsigned _ => AST.Tint8unsigned + | Tint I16 Signed _ => AST.Tint16signed + | Tint I16 Unsigned _ => AST.Tint16unsigned + | Tint IBool _ _ => AST.Tint8unsigned + | Tlong _ _ => AST.Tlong + | Tfloat F32 _ => AST.Tsingle + | Tfloat F64 _ => AST.Tfloat + | Tpointer _ _ => AST.Tptr + | Tarray _ _ _ | Tfunction _ _ _ | Tstruct _ _ | Tunion _ _ => AST.Tvoid + end. Fixpoint typlist_of_typelist (tl: typelist) : list AST.typ := match tl with @@ -742,7 +755,7 @@ Fixpoint typlist_of_typelist (tl: typelist) : list AST.typ := end. Definition signature_of_type (args: typelist) (res: type) (cc: calling_convention): signature := - mksignature (typlist_of_typelist args) (opttyp_of_type res) cc. + mksignature (typlist_of_typelist args) (rettype_of_type res) cc. (** * Construction of the composite environment *) diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index 29ea3bf2..00fcf8ab 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -397,10 +397,10 @@ Inductive wt_rvalue : expr -> Prop := wt_arguments rargs tyargs -> (* This typing rule is specialized to the builtin invocations generated by C2C, which are either __builtin_sel or builtins returning void. *) - (ty = Tvoid /\ sig_res (ef_sig ef) = None) + (ty = Tvoid /\ sig_res (ef_sig ef) = AST.Tvoid) \/ (tyargs = Tcons type_bool (Tcons ty (Tcons ty Tnil)) /\ let t := typ_of_type ty in - let sg := mksignature (AST.Tint :: t :: t :: nil) (Some t) cc_default in + let sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default in ef = EF_builtin "__builtin_sel"%string sg) -> wt_rvalue (Ebuiltin ef tyargs rargs ty) | wt_Eparen: forall r tycast ty, @@ -521,11 +521,20 @@ Fixpoint bind_globdef (e: typenv) (l: list (ident * globdef fundef type)) : type | (id, Gvar v) :: l => bind_globdef (PTree.set id v.(gvar_info) e) l end. +Inductive wt_fundef (ce: composite_env) (e: typenv) : fundef -> Prop := + | wt_fundef_internal: forall f, + wt_function ce e f -> + wt_fundef ce e (Internal f) + | wt_fundef_external: forall ef targs tres cc, + (ef_sig ef).(sig_res) = rettype_of_type tres -> + wt_fundef ce e (External ef targs tres cc). + Inductive wt_program : program -> Prop := | wt_program_intro: forall p, let e := bind_globdef (PTree.empty _) p.(prog_defs) in - (forall id f, In (id, Gfun (Internal f)) p.(prog_defs) -> - wt_function p.(prog_comp_env) e f) -> + (forall id fd, + In (id, Gfun fd) p.(prog_defs) -> + wt_fundef p.(prog_comp_env) e fd) -> wt_program p. Hint Constructors wt_val wt_rvalue wt_lvalue wt_stmt wt_lblstmts: ty. @@ -745,7 +754,7 @@ Definition ebuiltin (ef: external_function) (tyargs: typelist) (args: exprlist) do x1 <- check_rvals args; do x2 <- check_arguments args tyargs; if type_eq tyres Tvoid - && opt_typ_eq (sig_res (ef_sig ef)) None + && AST.rettype_eq (sig_res (ef_sig ef)) AST.Tvoid then OK (Ebuiltin ef tyargs args tyres) else Error (msg "builtin: wrong type decoration"). @@ -915,7 +924,8 @@ Definition retype_function (ce: composite_env) (e: typenv) (f: function) : res f Definition retype_fundef (ce: composite_env) (e: typenv) (fd: fundef) : res fundef := match fd with | Internal f => do f' <- retype_function ce e f; OK (Internal f') - | External id args res cc => OK fd + | External ef args res cc => + assertion (rettype_eq (ef_sig ef).(sig_res) (rettype_of_type res)); OK fd end. Definition typecheck_program (p: program) : res program := @@ -1241,7 +1251,7 @@ Lemma ebuiltin_sound: Proof. intros. monadInv H. destruct (type_eq tyres Tvoid); simpl in EQ2; try discriminate. - destruct (opt_typ_eq (sig_res (ef_sig ef)) None); inv EQ2. + destruct (rettype_eq (sig_res (ef_sig ef)) AST.Tvoid); inv EQ2. econstructor; eauto. eapply check_arguments_sound; eauto. Qed. @@ -1373,6 +1383,14 @@ Proof. intros. monadInv H. constructor; simpl. eapply retype_stmt_sound; eauto. Qed. +Lemma retype_fundef_sound: + forall ce e fd fd', retype_fundef ce e fd = OK fd' -> wt_fundef ce e fd'. +Proof. + intros. destruct fd; monadInv H. +- constructor; eapply retype_function_sound; eauto. +- constructor; auto. +Qed. + Theorem typecheck_program_sound: forall p p', typecheck_program p = OK p' -> wt_program p'. Proof. @@ -1395,11 +1413,11 @@ Proof. inv H1. simpl. auto. } rewrite ENVS. - intros id f. revert MATCH; generalize (prog_defs p) (AST.prog_defs tp). + intros id fd. revert MATCH; generalize (prog_defs p) (AST.prog_defs tp). induction 1; simpl; intros. contradiction. destruct H0; auto. subst b1; inv H. simpl in H1. inv H1. - destruct f1; monadInv H4. eapply retype_function_sound; eauto. + eapply retype_fundef_sound; eauto. Qed. (** * Subject reduction *) @@ -1711,6 +1729,26 @@ Proof. inv H; auto. Qed. +Lemma has_rettype_wt_val: + forall v ty, + Val.has_rettype v (rettype_of_type ty) -> wt_val v ty. +Proof. + unfold rettype_of_type, Val.has_rettype, Val.has_type; destruct ty; intros. +- destruct v; contradiction || constructor. +- destruct i. + + destruct s; destruct v; try contradiction; constructor; red; auto. + + destruct s; destruct v; try contradiction; constructor; red; auto. + + destruct v; try contradiction; constructor; auto. + + destruct v; try contradiction; constructor; red; auto. +- destruct v; try contradiction; constructor; auto. +- destruct f; destruct v; try contradiction; constructor. +- unfold Tptr in *; destruct v; destruct Archi.ptr64 eqn:P64; try contradiction; constructor; auto. +- destruct v; contradiction || constructor. +- destruct v; contradiction || constructor. +- destruct v; contradiction || constructor. +- destruct v; contradiction || constructor. +Qed. + Lemma wt_rred: forall ge tenv a m t a' m', rred ge a m t a' m' -> wt_rvalue ge tenv a -> wt_rvalue ge tenv a'. @@ -1750,7 +1788,7 @@ Proof. - (* builtin *) subst. destruct H7 as [(A & B) | (A & B)]. + subst ty. auto with ty. + simpl in B. set (T := typ_of_type ty) in *. - set (sg := mksignature (AST.Tint :: T :: T :: nil) (Some T) cc_default) in *. + set (sg := mksignature (AST.Tint :: T :: T :: nil) T cc_default) in *. assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select T))). { unfold sg, T; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } @@ -1896,12 +1934,6 @@ Hypothesis WTPROG: wt_program prog. Let ge := globalenv prog. Let gtenv := bind_globdef (PTree.empty _) prog.(prog_defs). -Hypothesis WT_EXTERNAL: - forall id ef args res cc vargs m t vres m', - In (id, Gfun (External ef args res cc)) prog.(prog_defs) -> - external_call ef ge vargs m t vres m' -> - wt_val vres res. - Inductive wt_expr_cont: typenv -> function -> cont -> Prop := | wt_Kdo: forall te f k, wt_stmt_cont te f k -> @@ -2000,12 +2032,6 @@ Proof. induction 1; simpl; auto; econstructor; eauto. Qed. -Definition wt_fundef (fd: fundef) := - match fd with - | Internal f => wt_function ge gtenv f - | External ef targs tres cc => True - end. - Definition fundef_return (fd: fundef) : type := match fd with | Internal f => f.(fn_return) @@ -2013,10 +2039,10 @@ Definition fundef_return (fd: fundef) : type := end. Lemma wt_find_funct: - forall v fd, Genv.find_funct ge v = Some fd -> wt_fundef fd. + forall v fd, Genv.find_funct ge v = Some fd -> wt_fundef ge gtenv fd. Proof. intros. apply Genv.find_funct_prop with (p := prog) (v := v); auto. - intros. inv WTPROG. destruct f; simpl; auto. apply H1 with id; auto. + intros. inv WTPROG. apply H1 with id; auto. Qed. Inductive wt_state: state -> Prop := @@ -2032,7 +2058,7 @@ Inductive wt_state: state -> Prop := wt_state (ExprState f r k e m) | wt_call_state: forall b fd vargs k m (WTK: wt_call_cont k (fundef_return fd)) - (WTFD: wt_fundef fd) + (WTFD: wt_fundef ge gtenv fd) (FIND: Genv.find_funct ge b = Some fd), wt_state (Callstate fd vargs k m) | wt_return_state: forall v k m ty @@ -2089,7 +2115,6 @@ Qed. End WT_FIND_LABEL. - Lemma preservation_estep: forall S t S', estep ge S t S' -> wt_state S -> wt_state S'. Proof. @@ -2164,9 +2189,10 @@ Proof. - inv WTS; eauto with ty. - exploit wt_find_label. eexact WTB. eauto. eapply call_cont_wt'; eauto. intros [A B]. eauto with ty. -- simpl in WTFD; inv WTFD. econstructor; eauto. apply wt_call_cont_stmt_cont; auto. -- exploit (Genv.find_funct_inversion prog); eauto. intros (id & A). - econstructor; eauto. +- inv WTFD. inv H3. econstructor; eauto. apply wt_call_cont_stmt_cont; auto. +- inv WTFD. econstructor; eauto. + apply has_rettype_wt_val. simpl; rewrite <- H1. + eapply external_call_well_typed_gen; eauto. - inv WTK. eauto with ty. Qed. @@ -2181,7 +2207,7 @@ Theorem wt_initial_state: Proof. intros. inv H. econstructor. constructor. apply Genv.find_funct_ptr_prop with (p := prog) (b := b); auto. - intros. inv WTPROG. destruct f0; simpl; auto. apply H4 with id; auto. + intros. inv WTPROG. apply H4 with id; auto. instantiate (1 := (Vptr b Ptrofs.zero)). rewrite Genv.find_funct_find_funct_ptr. auto. Qed. diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index 1c9729c5..03dc5837 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -19,7 +19,7 @@ open Format open Camlcoq open Values open AST -open Ctypes +open! Ctypes open Cop open Csyntax @@ -85,7 +85,7 @@ let name_optid id = let rec name_cdecl id ty = match ty with - | Tvoid -> + | Ctypes.Tvoid -> "void" ^ name_optid id | Ctypes.Tint(sz, sg, a) -> name_inttype sz sg ^ attributes a ^ name_optid id diff --git a/common/AST.v b/common/AST.v index a91138c9..fcbf0b34 100644 --- a/common/AST.v +++ b/common/AST.v @@ -45,9 +45,6 @@ Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}. Proof. decide equality. Defined. Global Opaque typ_eq. -Definition opt_typ_eq: forall (t1 t2: option typ), {t1=t2} + {t1<>t2} - := option_eq typ_eq. - Definition list_typ_eq: forall (l1 l2: list typ), {l1=l2} + {l1<>l2} := list_eq_dec typ_eq. @@ -91,10 +88,34 @@ Fixpoint subtype_list (tyl1 tyl2: list typ) : bool := | _, _ => false end. +(** To describe the values returned by functions, we use the more precise + types below. *) + +Inductive rettype : Type := + | Tret (t: typ) (**r like type [t] *) + | Tint8signed (**r 8-bit signed integer *) + | Tint8unsigned (**r 8-bit unsigned integer *) + | Tint16signed (**r 16-bit signed integer *) + | Tint16unsigned (**r 16-bit unsigned integer *) + | Tvoid. (**r no value returned *) + +Coercion Tret: typ >-> rettype. + +Lemma rettype_eq: forall (t1 t2: rettype), {t1=t2} + {t1<>t2}. +Proof. generalize typ_eq; decide equality. Defined. +Global Opaque rettype_eq. + +Fixpoint proj_rettype (r: rettype) : typ := + match r with + | Tret t => t + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => Tint + | Tvoid => Tint + end. + (** Additionally, function definitions and function calls are annotated by function signatures indicating: - the number and types of arguments; -- the type of the returned value, if any; +- the type of the returned value; - additional information on which calling convention to use. These signatures are used in particular to determine appropriate @@ -117,24 +138,20 @@ Global Opaque calling_convention_eq. Record signature : Type := mksignature { sig_args: list typ; - sig_res: option typ; + sig_res: rettype; sig_cc: calling_convention }. -Definition proj_sig_res (s: signature) : typ := - match s.(sig_res) with - | None => Tint - | Some t => t - end. +Definition proj_sig_res (s: signature) : typ := proj_rettype s.(sig_res). Definition signature_eq: forall (s1 s2: signature), {s1=s2} + {s1<>s2}. Proof. - generalize opt_typ_eq, list_typ_eq, calling_convention_eq; decide equality. + generalize rettype_eq, list_typ_eq, calling_convention_eq; decide equality. Defined. Global Opaque signature_eq. Definition signature_main := - {| sig_args := nil; sig_res := Some Tint; sig_cc := cc_default |}. + {| sig_args := nil; sig_res := Tint; sig_cc := cc_default |}. (** Memory accesses (load and store instructions) are annotated by a ``memory chunk'' indicating the type, size and signedness of the @@ -177,6 +194,28 @@ Definition type_of_chunk (c: memory_chunk) : typ := Lemma type_of_Mptr: type_of_chunk Mptr = Tptr. Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed. +(** Same, as a return type. *) + +Definition rettype_of_chunk (c: memory_chunk) : rettype := + match c with + | Mint8signed => Tint8signed + | Mint8unsigned => Tint8unsigned + | Mint16signed => Tint16signed + | Mint16unsigned => Tint16unsigned + | Mint32 => Tint + | Mint64 => Tlong + | Mfloat32 => Tsingle + | Mfloat64 => Tfloat + | Many32 => Tany32 + | Many64 => Tany64 + end. + +Lemma proj_rettype_of_chunk: + forall chunk, proj_rettype (rettype_of_chunk chunk) = type_of_chunk chunk. +Proof. + destruct chunk; auto. +Qed. + (** The chunk that is appropriate to store and reload a value of the given type, without losing information. *) @@ -477,15 +516,15 @@ Definition ef_sig (ef: external_function): signature := | EF_external name sg => sg | EF_builtin name sg => sg | EF_runtime name sg => sg - | EF_vload chunk => mksignature (Tptr :: nil) (Some (type_of_chunk chunk)) cc_default - | EF_vstore chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) None cc_default - | EF_malloc => mksignature (Tptr :: nil) (Some Tptr) cc_default - | EF_free => mksignature (Tptr :: nil) None cc_default - | EF_memcpy sz al => mksignature (Tptr :: Tptr :: nil) None cc_default - | EF_annot kind text targs => mksignature targs None cc_default - | EF_annot_val kind text targ => mksignature (targ :: nil) (Some targ) cc_default + | EF_vload chunk => mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default + | EF_vstore chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default + | EF_malloc => mksignature (Tptr :: nil) Tptr cc_default + | EF_free => mksignature (Tptr :: nil) Tvoid cc_default + | EF_memcpy sz al => mksignature (Tptr :: Tptr :: nil) Tvoid cc_default + | EF_annot kind text targs => mksignature targs Tvoid cc_default + | 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 None cc_default + | EF_debug kind text targs => mksignature targs Tvoid cc_default end. (** Whether an external function should be inlined by the compiler. *) diff --git a/common/Builtins.v b/common/Builtins.v index c9097e86..476b541e 100644 --- a/common/Builtins.v +++ b/common/Builtins.v @@ -29,7 +29,7 @@ Definition builtin_function_sig (b: builtin_function) : signature := | BI_platform b => platform_builtin_sig b end. -Definition builtin_function_sem (b: builtin_function) : builtin_sem (proj_sig_res (builtin_function_sig b)) := +Definition builtin_function_sem (b: builtin_function) : builtin_sem (sig_res (builtin_function_sig b)) := match b with | BI_standard b => standard_builtin_sem b | BI_platform b => platform_builtin_sem b diff --git a/common/Builtins0.v b/common/Builtins0.v index b78006dd..8da98314 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -26,8 +26,8 @@ Require Import AST Integers Floats Values Memdata. appropriate for the target. *) -Definition val_opt_has_type (ov: option val) (t: typ) : Prop := - match ov with Some v => Val.has_type v t | None => True end. +Definition val_opt_has_rettype (ov: option val) (t: rettype) : Prop := + match ov with Some v => Val.has_rettype v t | None => True end. Definition val_opt_inject (j: meminj) (ov ov': option val) : Prop := match ov, ov' with @@ -42,10 +42,10 @@ Definition val_opt_inject (j: meminj) (ov ov': option val) : Prop := and be compatible with value injections. *) -Record builtin_sem (tret: typ) : Type := mkbuiltin { +Record builtin_sem (tret: rettype) : Type := mkbuiltin { bs_sem :> list val -> option val; bs_well_typed: forall vl, - val_opt_has_type (bs_sem vl) tret; + val_opt_has_rettype (bs_sem vl) tret; bs_inject: forall j vl vl', Val.inject_list j vl vl' -> val_opt_inject j (bs_sem vl) (bs_sem vl') }. @@ -60,8 +60,8 @@ Record builtin_sem (tret: typ) : Type := mkbuiltin { Local Unset Program Cases. Program Definition mkbuiltin_v1t - (tret: typ) (f: val -> val) - (WT: forall v1, Val.has_type (f v1) tret) + (tret: rettype) (f: val -> val) + (WT: forall v1, Val.has_rettype (f v1) tret) (INJ: forall j v1 v1', Val.inject j v1 v1' -> Val.inject j (f v1) (f v1')) := mkbuiltin tret (fun vl => match vl with v1 :: nil => Some (f v1) | _ => None end) _ _. Next Obligation. @@ -72,8 +72,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_v2t - (tret: typ) (f: val -> val -> val) - (WT: forall v1 v2, Val.has_type (f v1 v2) tret) + (tret: rettype) (f: val -> val -> val) + (WT: forall v1 v2, Val.has_rettype (f v1 v2) tret) (INJ: forall j v1 v1' v2 v2', Val.inject j v1 v1' -> Val.inject j v2 v2' -> Val.inject j (f v1 v2) (f v1' v2')) := @@ -86,8 +86,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_v3t - (tret: typ) (f: val -> val -> val -> val) - (WT: forall v1 v2 v3, Val.has_type (f v1 v2 v3) tret) + (tret: rettype) (f: val -> val -> val -> val) + (WT: forall v1 v2 v3, Val.has_rettype (f v1 v2 v3) tret) (INJ: forall j v1 v1' v2 v2' v3 v3', Val.inject j v1 v1' -> Val.inject j v2 v2' -> Val.inject j v3 v3' -> Val.inject j (f v1 v2 v3) (f v1' v2' v3')) := @@ -100,8 +100,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_v1p - (tret: typ) (f: val -> option val) - (WT: forall v1, val_opt_has_type (f v1) tret) + (tret: rettype) (f: val -> option val) + (WT: forall v1, val_opt_has_rettype (f v1) tret) (INJ: forall j v1 v1', Val.inject j v1 v1' -> val_opt_inject j (f v1) (f v1')) := mkbuiltin tret (fun vl => match vl with v1 :: nil => f v1 | _ => None end) _ _. @@ -113,8 +113,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_v2p - (tret: typ) (f: val -> val -> option val) - (WT: forall v1 v2, val_opt_has_type (f v1 v2) tret) + (tret: rettype) (f: val -> val -> option val) + (WT: forall v1 v2, val_opt_has_rettype (f v1 v2) tret) (INJ: forall j v1 v1' v2 v2', Val.inject j v1 v1' -> Val.inject j v2 v2' -> val_opt_inject j (f v1 v2) (f v1' v2')) := @@ -171,7 +171,7 @@ Proof. destruct t; intros; constructor. Qed. -Lemma inj_num_opt_wt: forall t x, val_opt_has_type (option_map (inj_num t) x) t. +Lemma inj_num_opt_wt: forall t x, val_opt_has_rettype (option_map (inj_num t) x) t. Proof. intros. destruct x; simpl. apply inj_num_wt. auto. Qed. @@ -200,13 +200,13 @@ Proof. Qed. Lemma proj_num_opt_wt: - forall tres t k0 k1 v, + forall (tres: typ) t k0 k1 v, k0 = None \/ k0 = Some Vundef -> - (forall x, val_opt_has_type (k1 x) tres) -> - val_opt_has_type (proj_num t k0 v k1) tres. + (forall x, val_opt_has_rettype (k1 x) tres) -> + val_opt_has_rettype (proj_num t k0 v k1) tres. Proof. intros. - assert (val_opt_has_type k0 tres). { destruct H; subst k0; exact I. } + assert (val_opt_has_rettype k0 tres). { destruct H; subst k0; exact I. } destruct t; simpl; destruct v; auto. Qed. @@ -393,33 +393,33 @@ Definition standard_builtin_table : list (string * standard_builtin) := Definition standard_builtin_sig (b: standard_builtin) : signature := match b with | BI_select t => - mksignature (Tint :: t :: t :: nil) (Some t) cc_default + mksignature (Tint :: t :: t :: nil) t cc_default | BI_fabs | BI_fsqrt => - mksignature (Tfloat :: nil) (Some Tfloat) cc_default + mksignature (Tfloat :: nil) Tfloat cc_default | BI_negl => - mksignature (Tlong :: nil) (Some Tlong) cc_default + mksignature (Tlong :: nil) Tlong cc_default | BI_addl | BI_subl | BI_i64_umulh| BI_i64_smulh | BI_i64_sdiv | BI_i64_udiv | BI_i64_smod | BI_i64_umod => - mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default + mksignature (Tlong :: Tlong :: nil) Tlong cc_default | BI_mull => - mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default + mksignature (Tint :: Tint :: nil) Tlong cc_default | BI_i32_bswap => - mksignature (Tint :: nil) (Some Tint) cc_default + mksignature (Tint :: nil) Tint cc_default | BI_i64_bswap => - mksignature (Tlong :: nil) (Some Tlong) cc_default + mksignature (Tlong :: nil) Tlong cc_default | BI_i16_bswap => - mksignature (Tint :: nil) (Some Tint) cc_default + mksignature (Tint :: nil) Tint cc_default | BI_i64_shl | BI_i64_shr | BI_i64_sar => - mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default + mksignature (Tlong :: Tint :: nil) Tlong cc_default | BI_i64_dtos | BI_i64_dtou => - mksignature (Tfloat :: nil) (Some Tlong) cc_default + mksignature (Tfloat :: nil) Tlong cc_default | BI_i64_stod | BI_i64_utod => - mksignature (Tlong :: nil) (Some Tfloat) cc_default + mksignature (Tlong :: nil) Tfloat cc_default | BI_i64_stof | BI_i64_utof => - mksignature (Tlong :: nil) (Some Tsingle) cc_default + mksignature (Tlong :: nil) Tsingle cc_default end. -Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (proj_sig_res (standard_builtin_sig b)) := +Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (sig_res (standard_builtin_sig b)) := match b with | BI_select t => mkbuiltin t diff --git a/common/Events.v b/common/Events.v index 3fb84f49..10e0c232 100644 --- a/common/Events.v +++ b/common/Events.v @@ -623,7 +623,7 @@ Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop := ec_well_typed: forall ge vargs m1 t vres m2, sem ge vargs m1 t vres m2 -> - Val.has_type vres (proj_sig_res sg); + Val.has_rettype vres sg.(sig_res); (** The semantics is invariant under change of global environment that preserves symbols. *) ec_symbols_preserved: @@ -771,12 +771,12 @@ Qed. Lemma volatile_load_ok: forall chunk, extcall_properties (volatile_load_sem chunk) - (mksignature (Tptr :: nil) (Some (type_of_chunk chunk)) cc_default). + (mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default). Proof. intros; constructor; intros. (* well typed *) -- unfold proj_sig_res; simpl. inv H. inv H0. apply Val.load_result_type. - eapply Mem.load_type; eauto. +- inv H. inv H0. apply Val.load_result_rettype. + eapply Mem.load_rettype; eauto. (* symbols *) - inv H0. constructor. eapply volatile_load_preserved; eauto. (* valid blocks *) @@ -922,7 +922,7 @@ Qed. Lemma volatile_store_ok: forall chunk, extcall_properties (volatile_store_sem chunk) - (mksignature (Tptr :: type_of_chunk chunk :: nil) None cc_default). + (mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default). Proof. intros; constructor; intros. (* well typed *) @@ -967,7 +967,7 @@ Inductive extcall_malloc_sem (ge: Senv.t): Lemma extcall_malloc_ok: extcall_properties extcall_malloc_sem - (mksignature (Tptr :: nil) (Some Tptr) cc_default). + (mksignature (Tptr :: nil) Tptr cc_default). Proof. assert (UNCHANGED: forall (P: block -> Z -> Prop) m lo hi v m' b m'', @@ -984,7 +984,7 @@ Proof. } constructor; intros. (* well typed *) -- inv H. unfold proj_sig_res, Tptr; simpl. destruct Archi.ptr64; auto. +- inv H. simpl. unfold Tptr; destruct Archi.ptr64; auto. (* symbols preserved *) - inv H0; econstructor; eauto. (* valid block *) @@ -1053,11 +1053,11 @@ Inductive extcall_free_sem (ge: Senv.t): Lemma extcall_free_ok: extcall_properties extcall_free_sem - (mksignature (Tptr :: nil) None cc_default). + (mksignature (Tptr :: nil) Tvoid cc_default). Proof. constructor; intros. (* well typed *) -- inv H. unfold proj_sig_res. simpl. auto. +- inv H. simpl. auto. (* symbols preserved *) - inv H0; econstructor; eauto. (* valid block *) @@ -1147,11 +1147,11 @@ Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t): Lemma extcall_memcpy_ok: forall sz al, extcall_properties (extcall_memcpy_sem sz al) - (mksignature (Tptr :: Tptr :: nil) None cc_default). + (mksignature (Tptr :: Tptr :: nil) Tvoid cc_default). Proof. intros. constructor. - (* return type *) - intros. inv H. constructor. + intros. inv H. exact I. - (* change of globalenv *) intros. inv H0. econstructor; eauto. - (* valid blocks *) @@ -1258,7 +1258,7 @@ Inductive extcall_annot_sem (text: string) (targs: list typ) (ge: Senv.t): Lemma extcall_annot_ok: forall text targs, extcall_properties (extcall_annot_sem text targs) - (mksignature targs None cc_default). + (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. (* well typed *) @@ -1303,11 +1303,11 @@ Inductive extcall_annot_val_sem (text: string) (targ: typ) (ge: Senv.t): Lemma extcall_annot_val_ok: forall text targ, extcall_properties (extcall_annot_val_sem text targ) - (mksignature (targ :: nil) (Some targ) cc_default). + (mksignature (targ :: nil) targ cc_default). Proof. intros; constructor; intros. (* well typed *) -- inv H. unfold proj_sig_res; simpl. eapply eventval_match_type; eauto. +- inv H. eapply eventval_match_type; eauto. (* symbols *) - destruct H as (A & B & C). inv H0. econstructor; eauto. eapply eventval_match_preserved; eauto. @@ -1347,7 +1347,7 @@ Inductive extcall_debug_sem (ge: Senv.t): Lemma extcall_debug_ok: forall targs, extcall_properties extcall_debug_sem - (mksignature targs None cc_default). + (mksignature targs Tvoid cc_default). Proof. intros; constructor; intros. (* well typed *) @@ -1396,7 +1396,8 @@ Proof. intros. set (bsem := builtin_function_sem bf). constructor; intros. (* well typed *) - inv H. - specialize (bs_well_typed _ bsem vargs). unfold val_opt_has_type, bsem; rewrite H0. + specialize (bs_well_typed _ bsem vargs). + unfold val_opt_has_rettype, bsem; rewrite H0. auto. (* symbols *) - inv H0. econstructor; eauto. @@ -1516,7 +1517,7 @@ Proof. apply extcall_debug_ok. Qed. -Definition external_call_well_typed ef := ec_well_typed (external_call_spec ef). +Definition external_call_well_typed_gen ef := ec_well_typed (external_call_spec ef). Definition external_call_symbols_preserved ef := ec_symbols_preserved (external_call_spec ef). Definition external_call_valid_block ef := ec_valid_block (external_call_spec ef). Definition external_call_max_perm ef := ec_max_perm (external_call_spec ef). @@ -1527,6 +1528,16 @@ Definition external_call_trace_length ef := ec_trace_length (external_call_spec Definition external_call_receptive ef := ec_receptive (external_call_spec ef). Definition external_call_determ ef := ec_determ (external_call_spec ef). +(** Corollary of [external_call_well_typed_gen]. *) + +Lemma external_call_well_typed: + forall ef ge vargs m1 t vres m2, + external_call ef ge vargs m1 t vres m2 -> + Val.has_type vres (proj_sig_res (ef_sig ef)). +Proof. + intros. apply Val.has_proj_rettype. eapply external_call_well_typed_gen; eauto. +Qed. + (** Corollary of [external_call_valid_block]. *) Lemma external_call_nextblock: diff --git a/common/Memdata.v b/common/Memdata.v index 7144d72c..f3016efe 100644 --- a/common/Memdata.v +++ b/common/Memdata.v @@ -547,18 +547,26 @@ Proof. destruct v1; auto. Qed. -Lemma decode_val_type: +Lemma decode_val_rettype: forall chunk cl, - Val.has_type (decode_val chunk cl) (type_of_chunk chunk). + Val.has_rettype (decode_val chunk cl) (rettype_of_chunk chunk). Proof. intros. unfold decode_val. destruct (proj_bytes cl). - destruct chunk; simpl; auto. -Local Opaque Val.load_result. +- destruct chunk; simpl; rewrite ? Int.sign_ext_idem, ? Int.zero_ext_idem by omega; auto. +- Local Opaque Val.load_result. destruct chunk; simpl; (exact I || apply Val.load_result_type || destruct Archi.ptr64; (exact I || apply Val.load_result_type)). Qed. +Lemma decode_val_type: + forall chunk cl, + Val.has_type (decode_val chunk cl) (type_of_chunk chunk). +Proof. + intros. rewrite <- proj_rettype_of_chunk. + apply Val.has_proj_rettype. apply decode_val_rettype. +Qed. + Lemma encode_val_int8_signed_unsigned: forall v, encode_val Mint8signed v = encode_val Mint8unsigned v. Proof. @@ -607,11 +615,9 @@ Lemma decode_val_cast: | _ => True end. Proof. - unfold decode_val; intros; destruct chunk; auto; destruct (proj_bytes l); auto. - unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega. - unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega. - unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega. - unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega. + intros. + assert (A: Val.has_rettype v (rettype_of_chunk chunk)) by apply decode_val_rettype. + destruct chunk; auto; simpl in A; destruct v; try contradiction; simpl; congruence. Qed. (** Pointers cannot be forged. *) diff --git a/common/Memory.v b/common/Memory.v index b68a5049..9f9934c2 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -682,6 +682,15 @@ Proof. apply decode_val_type. Qed. +Theorem load_rettype: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + Val.has_rettype v (rettype_of_chunk chunk). +Proof. + intros. exploit load_result; eauto; intros. rewrite H0. + apply decode_val_rettype. +Qed. + Theorem load_cast: forall m chunk b ofs v, load chunk m b ofs = Some v -> diff --git a/common/Memtype.v b/common/Memtype.v index 53775d8b..ca9c6f1f 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -300,6 +300,11 @@ Axiom load_type: load chunk m b ofs = Some v -> Val.has_type v (type_of_chunk chunk). +Axiom load_rettype: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + Val.has_rettype v (rettype_of_chunk chunk). + (** For a small integer or float type, the value returned by [load] is invariant under the corresponding cast. *) Axiom load_cast: diff --git a/common/PrintAST.ml b/common/PrintAST.ml index e477957a..cf3a17d5 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -27,6 +27,14 @@ let name_of_type = function | Tany32 -> "any32" | Tany64 -> "any64" +let name_of_rettype = function + | Tret t -> name_of_type t + | Tvoid -> "void" + | Tint8signed -> "int8s" + | Tint8unsigned -> "int8u" + | Tint16signed -> "int16s" + | Tint16unsigned -> "int16u" + let name_of_chunk = function | Mint8signed -> "int8s" | Mint8unsigned -> "int8u" diff --git a/common/Values.v b/common/Values.v index de317734..68a2054b 100644 --- a/common/Values.v +++ b/common/Values.v @@ -149,6 +149,23 @@ Proof. auto. Defined. +Definition has_rettype (v: val) (r: rettype) : Prop := + match r, v with + | Tret t, _ => has_type v t + | Tint8signed, Vint n => n = Int.sign_ext 8 n + | Tint8unsigned, Vint n => n = Int.zero_ext 8 n + | Tint16signed, Vint n => n = Int.sign_ext 16 n + | Tint16unsigned, Vint n => n = Int.zero_ext 16 n + | _, Vundef => True + | _, _ => False + end. + +Lemma has_proj_rettype: forall v r, + has_rettype v r -> has_type v (proj_rettype r). +Proof. + destruct r; simpl; intros; auto; destruct v; try contradiction; exact I. +Qed. + (** Truth values. Non-zero integers are treated as [True]. The integer 0 (also used to represent the null pointer) is [False]. Other values are neither true nor false. *) @@ -1003,10 +1020,24 @@ Definition load_result (chunk: memory_chunk) (v: val) := | _, _ => Vundef end. +Lemma load_result_rettype: + forall chunk v, has_rettype (load_result chunk v) (rettype_of_chunk chunk). +Proof. + intros. unfold has_rettype; destruct chunk; destruct v; simpl; auto. +- rewrite Int.sign_ext_idem by omega; auto. +- rewrite Int.zero_ext_idem by omega; auto. +- rewrite Int.sign_ext_idem by omega; auto. +- rewrite Int.zero_ext_idem by omega; auto. +- destruct Archi.ptr64 eqn:SF; simpl; auto. +- destruct Archi.ptr64 eqn:SF; simpl; auto. +- destruct Archi.ptr64 eqn:SF; simpl; auto. +Qed. + Lemma load_result_type: forall chunk v, has_type (load_result chunk v) (type_of_chunk chunk). Proof. - intros. unfold has_type; destruct chunk; destruct v; simpl; auto; destruct Archi.ptr64 eqn:SF; simpl; auto. + intros. rewrite <- proj_rettype_of_chunk. apply has_proj_rettype. + apply load_result_rettype. Qed. Lemma load_result_same: diff --git a/coq b/coq index 0b04a8c7..fcf744fd 100755 --- a/coq +++ b/coq @@ -12,4 +12,4 @@ make -q ${1}o || { done) } -"${COQBIN}coqide" $INCLUDES $1 && make ${1}o +"${COQBIN}coqide" -async-proofs off $INCLUDES $1 && make ${1}o diff --git a/driver/Interp.ml b/driver/Interp.ml index a6841460..3fae70e9 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -20,7 +20,7 @@ open Values open Memory open Globalenvs open Events -open Ctypes +open !Ctypes open Csyntax open Csem diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml index d86e137a..c9d6fced 100644 --- a/exportclight/ExportClight.ml +++ b/exportclight/ExportClight.ml @@ -18,7 +18,7 @@ open Format open Camlcoq open AST -open Ctypes +open! Ctypes open Cop open Clight @@ -221,6 +221,14 @@ let asttype p t = | AST.Tany32 -> "AST.Tany32" | AST.Tany64 -> "AST.Tany64") +let astrettype p = function + | AST.Tret t -> asttype p t + | AST.Tvoid -> fprintf p "AST.Tvoid" + | AST.Tint8signed -> fprintf p "AST.Tint8signed" + | AST.Tint8unsigned -> fprintf p "AST.Tint8unsigned" + | AST.Tint16signed -> fprintf p "AST.Tint16signed" + | AST.Tint16unsigned -> fprintf p "AST.Tint16unsigned" + let name_of_chunk = function | Mint8signed -> "Mint8signed" | Mint8unsigned -> "Mint8unsigned" @@ -236,7 +244,7 @@ let name_of_chunk = function let signatur p sg = fprintf p "@[(mksignature@ %a@ %a@ %a)@]" (print_list asttype) sg.sig_args - (print_option asttype) sg.sig_res + astrettype sg.sig_res callconv sg.sig_cc let assertions = ref ([]: (string * typ list) list) diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index 704b0aba..ce88778c 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -852,7 +852,7 @@ let expand_instruction instr = if variadic then begin emit (Pmflr GPR0); emit (Pbl(intern_string "__compcert_va_saveregs", - {sig_args = []; sig_res = None; sig_cc = cc_default})); + {sig_args = []; sig_res = Tvoid; sig_cc = cc_default})); emit (Pmtlr GPR0) end; current_function_stacksize := sz; diff --git a/powerpc/Builtins1.v b/powerpc/Builtins1.v index f6e643d2..53c83d7e 100644 --- a/powerpc/Builtins1.v +++ b/powerpc/Builtins1.v @@ -29,5 +29,5 @@ Definition platform_builtin_table : list (string * platform_builtin) := Definition platform_builtin_sig (b: platform_builtin) : signature := match b with end. -Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := match b with end. diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v index 1de55c1a..7c1b2750 100644 --- a/powerpc/Conventions1.v +++ b/powerpc/Conventions1.v @@ -117,18 +117,16 @@ Definition dummy_float_reg := F0. (**r Used in [Coloring]. *) We treat a function without result as a function with one integer result. *) Definition loc_result_32 (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One R3 - | Some (Tint | Tany32) => One R3 - | Some (Tfloat | Tsingle | Tany64) => One F1 - | Some Tlong => Twolong R3 R4 + match proj_sig_res s with + | Tint | Tany32 => One R3 + | Tfloat | Tsingle | Tany64 => One F1 + | Tlong => Twolong R3 R4 end. Definition loc_result_64 (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One R3 - | Some (Tint | Tlong | Tany32 | Tany64) => One R3 - | Some (Tfloat | Tsingle) => One F1 + match proj_sig_res s with + | Tint | Tlong | Tany32 | Tany64 => One R3 + | Tfloat | Tsingle => One F1 end. Definition loc_result := @@ -140,8 +138,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, loc_result_32, loc_result_64, mreg_type. - destruct Archi.ptr64 eqn:?; destruct (sig_res sig) as [[]|]; destruct Archi.ppc64; simpl; auto. + intros. unfold loc_result, loc_result_32, loc_result_64, mreg_type. + destruct Archi.ptr64 eqn:?; destruct (proj_sig_res sig); destruct Archi.ppc64; simpl; auto. Qed. (** The result locations are caller-save registers *) @@ -151,7 +149,7 @@ Lemma loc_result_caller_save: forall_rpair (fun r => is_callee_save r = false) (loc_result s). Proof. intros. unfold loc_result, loc_result_32, loc_result_64, is_callee_save; - destruct Archi.ptr64; destruct (sig_res s) as [[]|]; simpl; auto. + destruct Archi.ptr64; destruct (proj_sig_res s); simpl; auto. Qed. (** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) @@ -161,13 +159,13 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong + 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, loc_result_32, loc_result_64, mreg_type; - destruct Archi.ptr64; destruct (sig_res sg) as [[]|]; destruct Archi.ppc64; simpl; auto. + destruct Archi.ptr64; destruct (proj_sig_res sg); destruct Archi.ppc64; simpl; auto. split; auto. congruence. split; auto. congruence. Qed. @@ -177,7 +175,7 @@ Qed. Lemma loc_result_exten: forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. Proof. - intros. unfold loc_result, loc_result_32, loc_result_64. + intros. unfold loc_result, loc_result_32, loc_result_64, proj_sig_res. destruct Archi.ptr64; rewrite H; auto. Qed. diff --git a/riscV/Builtins1.v b/riscV/Builtins1.v index f6e643d2..53c83d7e 100644 --- a/riscV/Builtins1.v +++ b/riscV/Builtins1.v @@ -29,5 +29,5 @@ Definition platform_builtin_table : list (string * platform_builtin) := Definition platform_builtin_sig (b: platform_builtin) : signature := match b with end. -Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := match b with end. diff --git a/riscV/Conventions1.v b/riscV/Conventions1.v index df7ddfd2..09cbbb44 100644 --- a/riscV/Conventions1.v +++ b/riscV/Conventions1.v @@ -115,11 +115,10 @@ Definition is_float_reg (r: mreg) := with one integer result. *) Definition loc_result (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One R10 - | Some (Tint | Tany32) => One R10 - | Some (Tfloat | Tsingle | Tany64) => One F10 - | Some Tlong => if Archi.ptr64 then One R10 else Twolong R11 R10 + match proj_sig_res s with + | Tint | Tany32 => One R10 + | Tfloat | Tsingle | Tany64 => One F10 + | Tlong => if Archi.ptr64 then One R10 else Twolong R11 R10 end. (** The result registers have types compatible with that given in the signature. *) @@ -128,8 +127,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 loc_result, mreg_type; + destruct (proj_sig_res sig); auto; destruct Archi.ptr64; auto. Qed. (** The result locations are caller-save registers *) @@ -139,7 +138,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 (proj_sig_res s); simpl; auto; destruct Archi.ptr64; simpl; auto. Qed. (** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) @@ -149,13 +148,13 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong + 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) as [[]|]; auto. + unfold loc_result; destruct (proj_sig_res sg); auto. unfold mreg_type; destruct Archi.ptr64; auto. split; auto. congruence. Qed. @@ -165,7 +164,7 @@ Qed. 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. + intros. unfold loc_result, proj_sig_res. rewrite H; auto. Qed. (** ** Location of function arguments *) diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index 16426ce3..c82d406e 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -506,7 +506,7 @@ let expand_instruction instr = (* Save the registers *) emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs))); emit (Pcall_s (intern_string "__compcert_va_saveregs", - {sig_args = []; sig_res = None; sig_cc = cc_default})) + {sig_args = []; sig_res = Tvoid; sig_cc = cc_default})) end; (* Stack chaining *) let fullsz = sz + 8 in diff --git a/x86/Builtins1.v b/x86/Builtins1.v index 6103cc4c..f1d60961 100644 --- a/x86/Builtins1.v +++ b/x86/Builtins1.v @@ -33,10 +33,10 @@ 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 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 diff --git a/x86/Conventions1.v b/x86/Conventions1.v index 646c4afb..595cb721 100644 --- a/x86/Conventions1.v +++ b/x86/Conventions1.v @@ -99,22 +99,20 @@ Definition is_float_reg (r: mreg) := function with one integer result. *) Definition loc_result_32 (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One AX - | Some (Tint | Tany32) => One AX - | Some (Tfloat | Tsingle) => One FP0 - | Some Tany64 => One X0 - | Some Tlong => Twolong DX AX + match proj_sig_res s with + | Tint | Tany32 => One AX + | Tfloat | Tsingle => One FP0 + | Tany64 => One X0 + | Tlong => Twolong DX AX end. (** In 64 bit mode, he result value of a function is passed back to the caller in registers [AX] or [X0]. *) Definition loc_result_64 (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One AX - | Some (Tint | Tlong | Tany32 | Tany64) => One AX - | Some (Tfloat | Tsingle) => One X0 + match proj_sig_res s with + | Tint | Tlong | Tany32 | Tany64 => One AX + | Tfloat | Tsingle => One X0 end. Definition loc_result := @@ -126,8 +124,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, loc_result_32, loc_result_64, mreg_type; - destruct Archi.ptr64; destruct (sig_res sig) as [[]|]; auto. + intros. unfold loc_result, loc_result_32, loc_result_64, mreg_type; + destruct Archi.ptr64; destruct (proj_sig_res sig); auto. Qed. (** The result locations are caller-save registers *) @@ -137,7 +135,7 @@ Lemma loc_result_caller_save: forall_rpair (fun r => is_callee_save r = false) (loc_result s). Proof. intros. unfold loc_result, loc_result_32, loc_result_64, is_callee_save; - destruct Archi.ptr64; destruct (sig_res s) as [[]|]; simpl; auto. + destruct Archi.ptr64; destruct (proj_sig_res s); simpl; auto. Qed. (** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) @@ -147,14 +145,14 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong + 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, loc_result_32, loc_result_64, mreg_type; - destruct Archi.ptr64; destruct (sig_res sg) as [[]|]; auto. + destruct Archi.ptr64; destruct (proj_sig_res sg); auto. split; auto. congruence. Qed. @@ -163,7 +161,7 @@ Qed. Lemma loc_result_exten: forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. Proof. - intros. unfold loc_result, loc_result_32, loc_result_64. + intros. unfold loc_result, loc_result_32, loc_result_64, proj_sig_res. destruct Archi.ptr64; rewrite H; auto. Qed. -- cgit From 28f235806aa0918499b2ef162110f513ebe4db30 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 19 Feb 2020 12:50:55 +0100 Subject: Support re-normalization of values returned by function calls Some ABIs leave more flexibility concerning function return values than CompCert expects. For example, the x86 ABI says that a function result of type "char" is returned in register AL, leaving the top 24 bits of register EAX unspecified, while CompCert expects EAX to contain 32 valid bits, namely the zero- or sign-extension of the 8-bit result. This commits adds a general mechanism to insert "re-normalization" conversions on the results of function calls. Currently, it only deals with results of small integer types, and inserts zero- or sign-extensions if so instructed by a platform-dependent function, Convention1.return_value_needs_normalization. The conversions in question are inserted early in the front-end, so that they can be optimized away in the back-end. The semantic preservation proof is still conducted against the CompCert model, where the return values of functions are already normalized. What the proof shows is that the extra conversions have no effect in this case. In future work we could relax the CompCert model, allowing functions to return values that are not normalized. --- aarch64/Conventions1.v | 5 ++ arm/Conventions1.v | 6 +++ cfrontend/Cshmgen.v | 37 +++++++++++-- cfrontend/Cshmgenproof.v | 133 ++++++++++++++++++++++++++++++++++++----------- powerpc/Conventions1.v | 6 +++ riscV/Conventions1.v | 6 +++ x86/Conventions1.v | 14 +++++ 7 files changed, 174 insertions(+), 33 deletions(-) diff --git a/aarch64/Conventions1.v b/aarch64/Conventions1.v index 575d058d..b1b3badd 100644 --- a/aarch64/Conventions1.v +++ b/aarch64/Conventions1.v @@ -377,3 +377,8 @@ Proof. unfold loc_arguments; reflexivity. Qed. +(** ** Normalization of function results *) + +(** No normalization needed. *) + +Definition return_value_needs_normalization (t: rettype) := false. diff --git a/arm/Conventions1.v b/arm/Conventions1.v index 45008bff..7016c1ee 100644 --- a/arm/Conventions1.v +++ b/arm/Conventions1.v @@ -641,3 +641,9 @@ Proof. unfold loc_arguments. destruct Archi.abi; reflexivity. Qed. + +(** ** Normalization of function results *) + +(** No normalization needed. *) + +Definition return_value_needs_normalization (t: rettype) := false. diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index ee135dcd..5bd12d00 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -23,6 +23,7 @@ Require Import Coqlib Maps Errors Integers Floats. Require Import AST Linking. Require Import Ctypes Cop Clight Cminor Csharpminor. +Require Import Conventions1. Local Open Scope string_scope. Local Open Scope error_monad_scope. @@ -558,6 +559,34 @@ Fixpoint typlist_of_arglist (al: list Clight.expr) (tyl: typelist) typ_of_type (default_argument_conversion (typeof a1)) :: typlist_of_arglist a2 Tnil end. +(** Translate a function call. + Depending on the ABI, it may be necessary to normalize the value + returned by casting it to the return type of the function. + For example, in the x86 ABI, a return value of type "char" is + returned in register AL, leaving the top 24 bits of EAX + unspecified. Hence, a cast to type "char" is needed to sign- or + zero-extend the returned integer before using it. *) + +Definition make_normalization (t: type) (a: expr) := + match t with + | Tint IBool _ _ => Eunop Ocast8unsigned a + | Tint I8 Signed _ => Eunop Ocast8signed a + | Tint I8 Unsigned _ => Eunop Ocast8unsigned a + | Tint I16 Signed _ => Eunop Ocast16signed a + | Tint I16 Unsigned _ => Eunop Ocast16unsigned a + | _ => a + end. + +Definition make_funcall (x: option ident) (tres: type) (sg: signature) + (fn: expr) (args: list expr): stmt := + match x, return_value_needs_normalization sg.(sig_res) with + | Some id, true => + Sseq (Scall x sg fn args) + (Sset id (make_normalization tres (Evar id))) + | _, _ => + Scall x sg fn args + end. + (** * Translation of statements *) (** [transl_statement nbrk ncnt s] returns a Csharpminor statement @@ -601,10 +630,10 @@ Fixpoint transl_statement (ce: composite_env) (tyret: type) (nbrk ncnt: nat) | fun_case_f args res cconv => do tb <- transl_expr ce b; do tcl <- transl_arglist ce cl args; - OK(Scall x {| sig_args := typlist_of_arglist cl args; - sig_res := rettype_of_type res; - sig_cc := cconv |} - tb tcl) + let sg := {| sig_args := typlist_of_arglist cl args; + sig_res := rettype_of_type res; + sig_cc := cconv |} in + OK (make_funcall x res sg tb tcl) | _ => Error(msg "Cshmgen.transl_stmt(call)") end | Clight.Sbuiltin x ef tyargs bl => diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 09e31cb2..1ceb8e4d 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -15,7 +15,7 @@ Require Import Coqlib Errors Maps Integers Floats. Require Import AST Linking. Require Import Values Events Memory Globalenvs Smallstep. -Require Import Ctypes Cop Clight Cminor Csharpminor. +Require Import Ctypes Ctyping Cop Clight Cminor Csharpminor. Require Import Cshmgen. (** * Relational specification of the transformation *) @@ -996,6 +996,26 @@ Proof. eapply make_memcpy_correct with (b := b) (v := Vptr b' ofs'); eauto. Qed. +Lemma make_normalization_correct: + forall e le m a v t, + eval_expr ge e le m a v -> + wt_val v t -> + eval_expr ge e le m (make_normalization t a) v. +Proof. + intros. destruct t; simpl; auto. inv H0. +- destruct i; simpl in H3. + + destruct s; econstructor; eauto; simpl; congruence. + + destruct s; econstructor; eauto; simpl; congruence. + + auto. + + econstructor; eauto; simpl; congruence. +- auto. +- destruct i. + + destruct s; econstructor; eauto. + + destruct s; econstructor; eauto. + + auto. + + econstructor; eauto. +Qed. + End CONSTRUCTORS. (** * Basic preservation invariants *) @@ -1360,7 +1380,16 @@ Inductive match_cont: composite_env -> type -> nat -> nat -> Clight.cont -> Csha match_cont cu.(prog_comp_env) (Clight.fn_return f) nbrk' ncnt' k tk -> match_cont ce tyret nbrk ncnt (Clight.Kcall id f e le k) - (Kcall id tf te le tk). + (Kcall id tf te le tk) + | match_Kcall_normalize: forall ce tyret nbrk ncnt nbrk' ncnt' f e k id a tf te le tk cu, + linkorder cu prog -> + transl_function cu.(prog_comp_env) f = OK tf -> + match_env e te -> + match_cont cu.(prog_comp_env) (Clight.fn_return f) nbrk' ncnt' k tk -> + (forall v e le m, wt_val v tyret -> le!id = Some v -> eval_expr tge e le m a v) -> + match_cont ce tyret nbrk ncnt + (Clight.Kcall (Some id) f e le k) + (Kcall (Some id) tf te le (Kseq (Sset id a) tk)). Inductive match_states: Clight.state -> Csharpminor.state -> Prop := | match_state: @@ -1377,14 +1406,15 @@ Inductive match_states: Clight.state -> Csharpminor.state -> Prop := forall fd args k m tfd tk targs tres cconv cu ce (LINK: linkorder cu prog) (TR: match_fundef cu fd tfd) - (MK: match_cont ce Tvoid 0%nat 0%nat k tk) + (MK: match_cont ce tres 0%nat 0%nat k tk) (ISCC: Clight.is_call_cont k) (TY: type_of_fundef fd = Tfunction targs tres cconv), match_states (Clight.Callstate fd args k m) (Callstate tfd args tk m) | match_returnstate: - forall res k m tk ce - (MK: match_cont ce Tvoid 0%nat 0%nat k tk), + forall res tres k m tk ce + (MK: match_cont ce tres 0%nat 0%nat k tk) + (WT: wt_val res tres), match_states (Clight.Returnstate res k m) (Returnstate res tk m). @@ -1442,7 +1472,9 @@ Proof. - (* set *) auto. - (* call *) - simpl in TR. destruct (classify_fun (typeof e)); monadInv TR. auto. + simpl in TR. destruct (classify_fun (typeof e)); monadInv TR. + unfold make_funcall. + destruct o; auto; destruct Conventions1.return_value_needs_normalization; auto. - (* builtin *) auto. - (* seq *) @@ -1500,24 +1532,26 @@ End FIND_LABEL. (** Properties of call continuations *) Lemma match_cont_call_cont: - forall ce' tyret' nbrk' ncnt' ce tyret nbrk ncnt k tk, + forall ce' nbrk' ncnt' ce tyret nbrk ncnt k tk, match_cont ce tyret nbrk ncnt k tk -> - match_cont ce' tyret' nbrk' ncnt' (Clight.call_cont k) (call_cont tk). + match_cont ce' tyret nbrk' ncnt' (Clight.call_cont k) (call_cont tk). Proof. induction 1; simpl; auto. - constructor. - econstructor; eauto. +- apply match_Kstop. +- eapply match_Kcall; eauto. +- eapply match_Kcall_normalize; eauto. Qed. Lemma match_cont_is_call_cont: - forall ce tyret nbrk ncnt k tk ce' tyret' nbrk' ncnt', + forall ce tyret nbrk ncnt k tk ce' nbrk' ncnt', match_cont ce tyret nbrk ncnt k tk -> Clight.is_call_cont k -> - match_cont ce' tyret' nbrk' ncnt' k tk /\ is_call_cont tk. + match_cont ce' tyret nbrk' ncnt' k tk /\ is_call_cont tk. Proof. intros. inv H; simpl in H0; try contradiction; simpl. - split; auto; constructor. - split; auto; econstructor; eauto. + split; auto; apply match_Kstop. + split; auto; eapply match_Kcall; eauto. + split; auto; eapply match_Kcall_normalize; eauto. Qed. (** The simulation proof *) @@ -1549,19 +1583,44 @@ Proof. - (* call *) revert TR. simpl. case_eq (classify_fun (typeof a)); try congruence. - intros targs tres cc CF TR. monadInv TR. inv MTR. + intros targs tres cc CF TR. monadInv TR. exploit functions_translated; eauto. intros (cu' & tfd & FIND & TFD & LINK'). rewrite H in CF. simpl in CF. inv CF. - econstructor; split. - apply plus_one. econstructor; eauto. - eapply transl_expr_correct with (cunit := cu); eauto. - eapply transl_arglist_correct with (cunit := cu); eauto. - erewrite typlist_of_arglist_eq by eauto. - eapply transl_fundef_sig1; eauto. - rewrite H3. auto. - econstructor; eauto. - eapply match_Kcall with (ce := prog_comp_env cu') (cu := cu); eauto. - simpl. auto. + set (sg := {| sig_args := typlist_of_arglist al targs; + sig_res := rettype_of_type tres; + sig_cc := cc |}) in *. + assert (SIG: funsig tfd = sg). + { unfold sg; erewrite typlist_of_arglist_eq by eauto. + eapply transl_fundef_sig1; eauto. rewrite H3; auto. } + assert (EITHER: tk' = tk /\ ts' = Scall optid sg x x0 + \/ exists id, optid = Some id /\ + tk' = tk /\ ts' = Sseq (Scall optid sg x x0) + (Sset id (make_normalization tres (Evar id)))). + { unfold make_funcall in MTR. + destruct optid. destruct Conventions1.return_value_needs_normalization. + inv MTR. right; exists i; auto. + inv MTR; auto. + inv MTR; auto. } + destruct EITHER as [(EK & ES) | (id & EI & EK & ES)]; rewrite EK, ES. + + (* without normalization of return value *) + econstructor; split. + apply plus_one. eapply step_call; eauto. + eapply transl_expr_correct with (cunit := cu); eauto. + eapply transl_arglist_correct with (cunit := cu); eauto. + econstructor; eauto. + eapply match_Kcall with (ce := prog_comp_env cu') (cu := cu); eauto. + exact I. + + (* with normalization of return value *) + subst optid. + econstructor; split. + eapply plus_two. apply step_seq. eapply step_call; eauto. + eapply transl_expr_correct with (cunit := cu); eauto. + eapply transl_arglist_correct with (cunit := cu); eauto. + traceEq. + econstructor; eauto. + eapply match_Kcall_normalize with (ce := prog_comp_env cu') (cu := cu); eauto. + intros. eapply make_normalization_correct; eauto. constructor; eauto. + exact I. - (* builtin *) monadInv TR. inv MTR. @@ -1658,6 +1717,7 @@ Proof. eapply match_env_free_blocks; eauto. eapply match_returnstate with (ce := prog_comp_env cu); eauto. eapply match_cont_call_cont. eauto. + constructor. - (* return some *) monadInv TR. inv MTR. @@ -1667,6 +1727,7 @@ Proof. eapply match_env_free_blocks; eauto. eapply match_returnstate with (ce := prog_comp_env cu); eauto. eapply match_cont_call_cont. eauto. + apply wt_val_casted. eapply cast_val_is_casted; eauto. - (* skip call *) monadInv TR. inv MTR. @@ -1675,6 +1736,7 @@ Proof. apply plus_one. apply step_skip_call. auto. eapply match_env_free_blocks; eauto. eapply match_returnstate with (ce := prog_comp_env cu); eauto. + constructor. - (* switch *) monadInv TR. @@ -1738,20 +1800,33 @@ Proof. simpl. econstructor; eauto. unfold transl_function. rewrite EQ; simpl. rewrite EQ1; simpl. auto. constructor. + replace (fn_return f) with tres. eassumption. + simpl in TY. unfold type_of_function in TY. congruence. - (* external function *) inv TR. exploit match_cont_is_call_cont; eauto. intros [A B]. econstructor; split. - apply plus_one. constructor. eauto. + apply plus_one. constructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. eapply match_returnstate with (ce := ce); eauto. + apply has_rettype_wt_val. + replace (rettype_of_type tres0) with (sig_res (ef_sig ef)). + eapply external_call_well_typed_gen; eauto. + rewrite H5. simpl. simpl in TY. congruence. - (* returnstate *) inv MK. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. simpl; reflexivity. constructor. + + (* without normalization *) + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. simpl; reflexivity. constructor. + + (* with normalization *) + econstructor; split. + eapply plus_three. econstructor. econstructor. constructor. + simpl. apply H13. eauto. apply PTree.gss. + traceEq. + simpl. rewrite PTree.set2. econstructor; eauto. simpl; reflexivity. constructor. Qed. Lemma transl_initial_states: diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v index 7c1b2750..25d9c081 100644 --- a/powerpc/Conventions1.v +++ b/powerpc/Conventions1.v @@ -463,3 +463,9 @@ Lemma loc_arguments_main: Proof. reflexivity. Qed. + +(** ** Normalization of function results *) + +(** No normalization needed. *) + +Definition return_value_needs_normalization (t: rettype) := false. diff --git a/riscV/Conventions1.v b/riscV/Conventions1.v index 09cbbb44..27d09d94 100644 --- a/riscV/Conventions1.v +++ b/riscV/Conventions1.v @@ -438,3 +438,9 @@ Lemma loc_arguments_main: Proof. reflexivity. Qed. + +(** ** Normalization of function results *) + +(** No normalization needed. *) + +Definition return_value_needs_normalization (t: rettype) := false. diff --git a/x86/Conventions1.v b/x86/Conventions1.v index 595cb721..01b15e98 100644 --- a/x86/Conventions1.v +++ b/x86/Conventions1.v @@ -471,3 +471,17 @@ Lemma loc_arguments_main: Proof. unfold loc_arguments; destruct Archi.ptr64; reflexivity. Qed. + +(** ** Normalization of function results *) + +(** In the x86 ABI, a return value of type "char" is returned in + register AL, leaving the top 24 bits of EAX unspecified. + Likewise, a return value of type "short" is returned in register + AH, leaving the top 16 bits of EAX unspecified. Hence, return + values of small integer types need re-normalization after calls. *) + +Definition return_value_needs_normalization (t: rettype) : bool := + match t with + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true + | _ => false + end. -- cgit From 8f8a4135be4786a04b781bdf669e642d8383d91a Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 19 Feb 2020 13:00:49 +0100 Subject: Add interoperability test for functions returning small integer types --- test/regression/Results/interop1 | 8 ++++++++ test/regression/interop1.c | 15 +++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/test/regression/Results/interop1 b/test/regression/Results/interop1 index 990dfe9d..6e32c1cb 100644 --- a/test/regression/Results/interop1 +++ b/test/regression/Results/interop1 @@ -1,4 +1,8 @@ --- CompCert calling native: +si8u: 177 +si8s: -79 +si16u: 64305 +si16s: -1231 s1: { a = 'a' } s2: { a = 'a', b = 'b' } s3: { a = 'a', b = 'b', c = ' c' } @@ -44,6 +48,10 @@ ru6: { a = 55555, b = 666 } ru7: { a = -10001, b = -789, c = 'z' } ru8: { a = 'x', b = 12345 } --- native calling CompCert: +si8u: 177 +si8s: -79 +si16u: 64305 +si16s: -1231 s1: { a = 'a' } s2: { a = 'a', b = 'b' } s3: { a = 'a', b = 'b', c = ' c' } diff --git a/test/regression/interop1.c b/test/regression/interop1.c index a39f449c..6836b89e 100644 --- a/test/regression/interop1.c +++ b/test/regression/interop1.c @@ -195,6 +195,17 @@ RETURN(ru6,U6,init_U6) RETURN(ru7,U7,init_U7) RETURN(ru8,U8,init_U8) +/* Returning small integers */ + +#define SMALLINT(name,ty) \ +extern ty THEM(name)(int); \ +ty US(name)(int x) { return x * x; } + +SMALLINT(si8u, unsigned char) +SMALLINT(si8s, signed char) +SMALLINT(si16u, unsigned short) +SMALLINT(si16s, signed short) + /* Test function, calling the functions compiled by the other compiler */ #define CALLPRINT(name,ty,init) \ @@ -207,6 +218,10 @@ RETURN(ru8,U8,init_U8) extern void THEM(test) (void); void US(test) (void) { + printf("si8u: %d\n", THEM(si8u)(12345)); + printf("si8s: %d\n", THEM(si8s)(12345)); + printf("si16u: %d\n", THEM(si16u)(1234567)); + printf("si16s: %d\n", THEM(si16s)(1234567)); CALLPRINT(s1,S1,init_S1) CALLPRINT(s2,S2,init_S2) CALLPRINT(s3,S3,init_S3) -- cgit From 3bffda879e214345635e575a696e8f184bef0e55 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 20 Feb 2020 09:41:16 +0100 Subject: Cosmetic: in OCaml code, write "open! Module" instead of "open !Module" "open!" is the form used in the examples in the OCaml manual. Based on a quick poll it seems to be the preferred form of the OCaml core dev team. --- backend/Inliningaux.ml | 2 +- backend/PrintCminor.ml | 2 +- cparser/Elab.ml | 2 +- driver/Interp.ml | 4 ++-- riscV/Asmexpand.ml | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/backend/Inliningaux.ml b/backend/Inliningaux.ml index 842e0c93..2e83eb0c 100644 --- a/backend/Inliningaux.ml +++ b/backend/Inliningaux.ml @@ -16,7 +16,7 @@ open FSetAVL open Maps open Op open Ordered -open !RTL +open! RTL module PSet = Make(OrderedPositive) diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml index b77c5645..c9a6d399 100644 --- a/backend/PrintCminor.ml +++ b/backend/PrintCminor.ml @@ -16,7 +16,7 @@ (** Pretty-printer for Cminor *) open Format -open !Camlcoq +open! Camlcoq open Integers open AST open PrintAST diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 3dbb9d45..9aa6761c 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -21,7 +21,7 @@ open Machine open Cabs open C open Diagnostics -open !Cutil +open! Cutil (** * Utility functions *) diff --git a/driver/Interp.ml b/driver/Interp.ml index 3fae70e9..d4286779 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -15,12 +15,12 @@ open Format open Camlcoq open AST -open !Integers +open! Integers open Values open Memory open Globalenvs open Events -open !Ctypes +open! Ctypes open Csyntax open Csem diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 1df63308..d36b6230 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -23,7 +23,7 @@ open Asm open Asmexpandaux open AST open Camlcoq -open !Integers +open! Integers exception Error of string -- cgit From 3bdb983e0b21c8d45e85aff08278475396038f4f Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 20 Feb 2020 19:17:57 +0100 Subject: AArch64: normalize function return values of small integer type According to AAPCS64 (the AArch64 ABI specification), the top bits of the register containing the function result have unspecified value, so we need to sign- or zero-extend the function result before using it, as in the x86 port. --- aarch64/Conventions1.v | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/aarch64/Conventions1.v b/aarch64/Conventions1.v index b1b3badd..14cb199f 100644 --- a/aarch64/Conventions1.v +++ b/aarch64/Conventions1.v @@ -379,6 +379,14 @@ Qed. (** ** Normalization of function results *) -(** No normalization needed. *) - -Definition return_value_needs_normalization (t: rettype) := false. +(** According to the AAPCS64 ABI specification, "padding bits" in the return + value of a function have unpredictable values and must be ignored. + Consequently, we force normalization of return values of small integer + types (8- and 16-bit integers), so that the top bits (the "padding bits") + are proper sign- or zero-extensions of the small integer value. *) + +Definition return_value_needs_normalization (t: rettype) : bool := + match t with + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true + | _ => false + end. -- cgit From 49077ae5aa2f88c843b8fae8cd60aff75a52e5e8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 21 Feb 2020 16:02:03 +0100 Subject: Linearizeaux: can_be_merged --- backend/Linearizeaux.ml | 61 ++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 48 insertions(+), 13 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 44322a46..3ef86344 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -202,38 +202,73 @@ end module PSet = Set.Make(PInt) -let iter_set f s = Seq.iter f (PSet.to_seq s) +module LPInt = struct + type t = P.t list + let rec compare x y = + match x with + | [] -> ( match y with + | [] -> 0 + | _ -> 1 ) + | e :: l -> match y with + | [] -> -1 + | e' :: l' -> + let e_cmp = PInt.compare e e' in + if e_cmp == 0 then compare l l' else e_cmp +end + +module LPSet = Set.Make(LPInt) + +let iter_lpset f s = Seq.iter f (LPSet.to_seq s) + +let first_of = function + | [] -> None + | e :: l -> Some e + +let rec last_of = function + | [] -> None + | e :: l -> (match l with [] -> Some e | e :: l -> last_of l) -let can_be_merged s s' = false +let can_be_merged code s s' = + let last_s = get_some @@ last_of s in + let first_s' = get_some @@ first_of s' in + match get_some @@ PTree.get last_s code with + | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ + | Lbuiltin _ | Ltailcall _ | Lreturn -> false + | Lbranch n -> n == first_s' + | Lcond (_, _, ifso, ifnot) -> ifnot == first_s' + | Ljumptable (_, ln) -> + match ln with + | [] -> false + | n :: ln -> n == first_s' let merge s s' = Some s -let try_merge code fs = - let seqs = ref (PSet.of_list fs) in - let oldLength = ref (PSet.cardinal !seqs) in +let try_merge code (fs: (BinNums.positive list) list) = + let seqs = ref (LPSet.of_list fs) in + let oldLength = ref (LPSet.cardinal !seqs) in let continue = ref true in let found = ref false in while !continue do begin found := false; - iter_set (fun s -> + iter_lpset (fun s -> if !found then () - else iter_set (fun s' -> + else iter_lpset (fun s' -> if (!found || s == s') then () - else if (can_be_merged s s') then + else if (can_be_merged code s s') then begin - seqs := PSet.remove s !seqs; - seqs := PSet.remove s' !seqs; - seqs := PSet.add (get_some (merge s s')) !seqs; + seqs := LPSet.remove s !seqs; + seqs := LPSet.remove s' !seqs; + seqs := LPSet.add (get_some (merge s s')) !seqs; found := true; end else () ) !seqs ) !seqs; - if !oldLength == PSet.cardinal !seqs then + if !oldLength == LPSet.cardinal !seqs then continue := false else - oldLength := PSet.cardinal !seqs + oldLength := LPSet.cardinal !seqs end done; !seqs -- cgit From 08efc2a09b850476e39469791650faf99dd06183 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 24 Feb 2020 13:56:07 +0100 Subject: Platform-independent implementation of Conventions.size_arguments (#222) The "size_arguments" function and its properties can be systematically derived from the "loc_arguments" function and its properties. Before, the RISC-V port used this derivation, and all other ports used hand-written "size_arguments" functions and proofs. This commit moves the definition of "size_arguments" to the platform-independent file backend/Conventions.v, using the systematic derivation, and removes the platform-specific definitions. This reduces code and proof size, and makes it easier to change the calling conventions. --- aarch64/Conventions1.v | 107 ------------------------- arm/Conventions1.v | 206 ------------------------------------------------- backend/Conventions.v | 67 ++++++++++++++++ powerpc/Conventions1.v | 126 ------------------------------ riscV/Conventions1.v | 64 --------------- x86/Asmexpand.ml | 2 +- x86/Conventions1.v | 145 ---------------------------------- 7 files changed, 68 insertions(+), 649 deletions(-) diff --git a/aarch64/Conventions1.v b/aarch64/Conventions1.v index 14cb199f..efda835d 100644 --- a/aarch64/Conventions1.v +++ b/aarch64/Conventions1.v @@ -190,27 +190,6 @@ Fixpoint loc_arguments_rec Definition loc_arguments (s: signature) : list (rpair loc) := loc_arguments_rec s.(sig_args) 0 0 0. -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Fixpoint size_arguments_rec (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | (Tint | Tlong | Tany32 | Tany64) :: tys => - match list_nth_z int_param_regs ir with - | None => size_arguments_rec tys ir fr (ofs + 2) - | Some ireg => size_arguments_rec tys (ir + 1) fr ofs - end - | (Tfloat | Tsingle) :: tys => - match list_nth_z float_param_regs fr with - | None => size_arguments_rec tys ir fr (ofs + 2) - | Some freg => size_arguments_rec tys ir (fr + 1) ofs - end - end. - -Definition size_arguments (s: signature) : Z := - size_arguments_rec s.(sig_args) 0 0 0. - (** Argument locations are either caller-save registers or [Outgoing] stack slots at nonnegative offsets. *) @@ -285,92 +264,6 @@ Qed. Hint Resolve loc_arguments_acceptable: locs. -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark size_arguments_rec_above: - forall tyl ir fr ofs0, - ofs0 <= size_arguments_rec tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - omega. - assert (A: ofs0 <= - match list_nth_z int_param_regs ir with - | Some _ => size_arguments_rec tyl (ir + 1) fr ofs0 - | None => size_arguments_rec tyl ir fr (ofs0 + 2) - end). - { destruct (list_nth_z int_param_regs ir); eauto. - apply Z.le_trans with (ofs0 + 2); auto. omega. } - assert (B: ofs0 <= - match list_nth_z float_param_regs fr with - | Some _ => size_arguments_rec tyl ir (fr + 1) ofs0 - | None => size_arguments_rec tyl ir fr (ofs0 + 2) - end). - { destruct (list_nth_z float_param_regs fr); eauto. - apply Z.le_trans with (ofs0 + 2); auto. omega. } - destruct a; auto. -Qed. - -Lemma size_arguments_above: - forall s, size_arguments s >= 0. -Proof. - intros; unfold size_arguments. apply Z.le_ge. apply size_arguments_rec_above. -Qed. - -Lemma loc_arguments_rec_bounded: - forall ofs ty tyl ir fr ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_rec tyl ir fr ofs0)) -> - ofs + typesize ty <= size_arguments_rec tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. -- contradiction. -- assert (T: forall ty0, typesize ty0 <= 2). - { destruct ty0; simpl; omega. } - assert (A: forall ty0, - In (S Outgoing ofs ty) (regs_of_rpairs - match list_nth_z int_param_regs ir with - | Some ireg => - One (R ireg) :: loc_arguments_rec tyl (ir + 1) fr ofs0 - | None => One (S Outgoing ofs0 ty0) :: loc_arguments_rec tyl ir fr (ofs0 + 2) - end) -> - ofs + typesize ty <= - match list_nth_z int_param_regs ir with - | Some _ => size_arguments_rec tyl (ir + 1) fr ofs0 - | None => size_arguments_rec tyl ir fr (ofs0 + 2) - end). - { intros. destruct (list_nth_z int_param_regs ir); simpl in H0; destruct H0. - - discriminate. - - eapply IHtyl; eauto. - - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_rec_above. - - eapply IHtyl; eauto. } - assert (B: forall ty0, - In (S Outgoing ofs ty) (regs_of_rpairs - match list_nth_z float_param_regs fr with - | Some ireg => - One (R ireg) :: loc_arguments_rec tyl ir (fr + 1) ofs0 - | None => One (S Outgoing ofs0 ty0) :: loc_arguments_rec tyl ir fr (ofs0 + 2) - end) -> - ofs + typesize ty <= - match list_nth_z float_param_regs fr with - | Some _ => size_arguments_rec tyl ir (fr + 1) ofs0 - | None => size_arguments_rec tyl ir fr (ofs0 + 2) - end). - { intros. destruct (list_nth_z float_param_regs fr); simpl in H0; destruct H0. - - discriminate. - - eapply IHtyl; eauto. - - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_rec_above. - - eapply IHtyl; eauto. } - destruct a; eauto. -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. - unfold loc_arguments, size_arguments; intros. - eauto using loc_arguments_rec_bounded. -Qed. - Lemma loc_arguments_main: loc_arguments signature_main = nil. Proof. diff --git a/arm/Conventions1.v b/arm/Conventions1.v index 7016c1ee..fe49a781 100644 --- a/arm/Conventions1.v +++ b/arm/Conventions1.v @@ -269,48 +269,6 @@ Definition loc_arguments (s: signature) : list (rpair loc) := else loc_arguments_hf s.(sig_args) 0 0 0 end. -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Fixpoint size_arguments_hf (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | (Tint|Tany32) :: tys => - if zlt ir 4 - then size_arguments_hf tys (ir + 1) fr ofs - else size_arguments_hf tys ir fr (ofs + 1) - | (Tfloat|Tany64) :: tys => - if zlt fr 8 - then size_arguments_hf tys ir (fr + 1) ofs - else size_arguments_hf tys ir fr (align ofs 2 + 2) - | Tsingle :: tys => - if zlt fr 8 - then size_arguments_hf tys ir (fr + 1) ofs - else size_arguments_hf tys ir fr (ofs + 1) - | Tlong :: tys => - let ir := align ir 2 in - if zlt ir 4 - then size_arguments_hf tys (ir + 2) fr ofs - else size_arguments_hf tys ir fr (align ofs 2 + 2) - end. - -Fixpoint size_arguments_sf (tyl: list typ) (ofs: Z) {struct tyl} : Z := - match tyl with - | nil => Z.max 0 ofs - | (Tint | Tsingle | Tany32) :: tys => size_arguments_sf tys (ofs + 1) - | (Tfloat | Tlong | Tany64) :: tys => size_arguments_sf tys (align ofs 2 + 2) - end. - -Definition size_arguments (s: signature) : Z := - match Archi.abi with - | Archi.Softfloat => - size_arguments_sf s.(sig_args) (-4) - | Archi.Hardfloat => - if s.(sig_cc).(cc_vararg) - then size_arguments_sf s.(sig_args) (-4) - else size_arguments_hf s.(sig_args) 0 0 0 - end. - (** Argument locations are either non-temporary registers or [Outgoing] stack slots at nonnegative offsets. *) @@ -471,170 +429,6 @@ Qed. Hint Resolve loc_arguments_acceptable: locs. -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark size_arguments_hf_above: - forall tyl ir fr ofs0, - ofs0 <= size_arguments_hf tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - omega. - destruct a. - destruct (zlt ir 4); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega. - destruct (zlt fr 8); eauto. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. - set (ir' := align ir 2). - destruct (zlt ir' 4); eauto. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. - destruct (zlt fr 8); eauto. - apply Z.le_trans with (ofs0 + 1); eauto. omega. - destruct (zlt ir 4); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega. - destruct (zlt fr 8); eauto. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. -Qed. - -Remark size_arguments_sf_above: - forall tyl ofs0, - Z.max 0 ofs0 <= size_arguments_sf tyl ofs0. -Proof. - induction tyl; simpl; intros. - omega. - destruct a; (eapply Z.le_trans; [idtac|eauto]). - xomega. - assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega. - assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega. - xomega. - xomega. - assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega. -Qed. - -Lemma size_arguments_above: - forall s, size_arguments s >= 0. -Proof. - intros; unfold size_arguments. apply Z.le_ge. - assert (0 <= size_arguments_sf (sig_args s) (-4)). - { change 0 with (Z.max 0 (-4)). apply size_arguments_sf_above. } - assert (0 <= size_arguments_hf (sig_args s) 0 0 0). - { apply size_arguments_hf_above. } - destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; auto. -Qed. - -Lemma loc_arguments_hf_bounded: - forall ofs ty tyl ir fr ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_hf tyl ir fr ofs0)) -> - ofs + typesize ty <= size_arguments_hf tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - elim H. - destruct a. -- (* int *) - destruct (zlt ir 4); destruct H. - discriminate. - eauto. - inv H. apply size_arguments_hf_above. - eauto. -- (* float *) - destruct (zlt fr 8); destruct H. - discriminate. - eauto. - inv H. apply size_arguments_hf_above. - eauto. -- (* long *) - destruct (zlt (align ir 2) 4). - destruct H. discriminate. destruct H. discriminate. eauto. - destruct Archi.big_endian. - destruct H. inv H. - eapply Z.le_trans. 2: apply size_arguments_hf_above. simpl; omega. - destruct H. inv H. - rewrite <- Z.add_assoc. simpl. apply size_arguments_hf_above. - eauto. - destruct H. inv H. - rewrite <- Z.add_assoc. simpl. apply size_arguments_hf_above. - destruct H. inv H. - eapply Z.le_trans. 2: apply size_arguments_hf_above. simpl; omega. - eauto. -- (* float *) - destruct (zlt fr 8); destruct H. - discriminate. - eauto. - inv H. apply size_arguments_hf_above. - eauto. -- (* any32 *) - destruct (zlt ir 4); destruct H. - discriminate. - eauto. - inv H. apply size_arguments_hf_above. - eauto. -- (* any64 *) - destruct (zlt fr 8); destruct H. - discriminate. - eauto. - inv H. apply size_arguments_hf_above. - eauto. -Qed. - -Lemma loc_arguments_sf_bounded: - forall ofs ty tyl ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_sf tyl ofs0)) -> - Z.max 0 (ofs + typesize ty) <= size_arguments_sf tyl ofs0. -Proof. - induction tyl; simpl; intros. - elim H. - destruct a. -- (* int *) - destruct H. - destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above. - eauto. -- (* float *) - destruct H. - destruct (zlt (align ofs0 2) 0); inv H. apply size_arguments_sf_above. - eauto. -- (* long *) - destruct H. - destruct Archi.big_endian. - destruct (zlt (align ofs0 2) 0); inv H. - eapply Z.le_trans. 2: apply size_arguments_sf_above. simpl; xomega. - destruct (zlt (align ofs0 2) 0); inv H. - rewrite <- Z.add_assoc. simpl. apply size_arguments_sf_above. - destruct H. - destruct Archi.big_endian. - destruct (zlt (align ofs0 2) 0); inv H. - rewrite <- Z.add_assoc. simpl. apply size_arguments_sf_above. - destruct (zlt (align ofs0 2) 0); inv H. - eapply Z.le_trans. 2: apply size_arguments_sf_above. simpl; xomega. - eauto. -- (* float *) - destruct H. - destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above. - eauto. -- (* any32 *) - destruct H. - destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above. - eauto. -- (* any64 *) - destruct H. - destruct (zlt (align ofs0 2) 0); inv H. apply size_arguments_sf_above. - eauto. -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. - unfold loc_arguments, size_arguments; intros. - assert (In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_sf (sig_args s) (-4))) -> - ofs + typesize ty <= size_arguments_sf (sig_args s) (-4)). - { intros. eapply Z.le_trans. 2: eapply loc_arguments_sf_bounded; eauto. xomega. } - assert (In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_hf (sig_args s) 0 0 0)) -> - ofs + typesize ty <= size_arguments_hf (sig_args s) 0 0 0). - { intros. eapply loc_arguments_hf_bounded; eauto. } - destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; eauto. -Qed. - Lemma loc_arguments_main: loc_arguments signature_main = nil. Proof. diff --git a/backend/Conventions.v b/backend/Conventions.v index 6025c6b4..14ffb587 100644 --- a/backend/Conventions.v +++ b/backend/Conventions.v @@ -34,6 +34,73 @@ Proof. apply IHpl; auto. Qed. +(** ** Stack size of function arguments *) + +(** [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. + +(** 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. + (** ** Location of function parameters *) (** A function finds the values of its parameter in the same locations diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v index 25d9c081..1f048694 100644 --- a/powerpc/Conventions1.v +++ b/powerpc/Conventions1.v @@ -236,33 +236,6 @@ Fixpoint loc_arguments_rec Definition loc_arguments (s: signature) : list (rpair loc) := loc_arguments_rec s.(sig_args) 0 0 0. -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Fixpoint size_arguments_rec (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | (Tint | Tany32) :: tys => - match list_nth_z int_param_regs ir with - | None => size_arguments_rec tys ir fr (ofs + 1) - | Some ireg => size_arguments_rec tys (ir + 1) fr ofs - end - | (Tfloat | Tsingle | Tany64) :: tys => - match list_nth_z float_param_regs fr with - | None => size_arguments_rec tys ir fr (align ofs 2 + 2) - | Some freg => size_arguments_rec tys ir (fr + 1) ofs - end - | Tlong :: tys => - let ir := align ir 2 in - match list_nth_z int_param_regs ir, list_nth_z int_param_regs (ir + 1) with - | Some r1, Some r2 => size_arguments_rec tys (ir + 2) fr ofs - | _, _ => size_arguments_rec tys ir fr (align ofs 2 + 2) - end - end. - -Definition size_arguments (s: signature) : Z := - size_arguments_rec s.(sig_args) 0 0 0. - (** Argument locations are either caller-save registers or [Outgoing] stack slots at nonnegative offsets. *) @@ -359,105 +332,6 @@ Qed. Hint Resolve loc_arguments_acceptable: locs. -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark size_arguments_rec_above: - forall tyl ir fr ofs0, - ofs0 <= size_arguments_rec tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - omega. - destruct a. - destruct (list_nth_z int_param_regs ir); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega. - destruct (list_nth_z float_param_regs fr); eauto. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. - set (ir' := align ir 2). - destruct (list_nth_z int_param_regs ir'); eauto. - destruct (list_nth_z int_param_regs (ir' + 1)); eauto. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. - destruct (list_nth_z float_param_regs fr); eauto. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. - destruct (list_nth_z int_param_regs ir); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega. - destruct (list_nth_z float_param_regs fr); eauto. - apply Z.le_trans with (align ofs0 2). apply align_le; omega. - apply Z.le_trans with (align ofs0 2 + 2); auto; omega. -Qed. - -Lemma size_arguments_above: - forall s, size_arguments s >= 0. -Proof. - intros; unfold size_arguments. apply Z.le_ge. - apply size_arguments_rec_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. - assert (forall tyl ir fr ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_rec tyl ir fr ofs0)) -> - ofs + typesize ty <= size_arguments_rec tyl ir fr ofs0). -{ - induction tyl; simpl; intros. - elim H0. - destruct a. -- (* int *) - destruct (list_nth_z int_param_regs ir); destruct H0. - congruence. - eauto. - inv H0. apply size_arguments_rec_above. - eauto. -- (* float *) - destruct (list_nth_z float_param_regs fr); destruct H0. - congruence. - eauto. - inv H0. apply size_arguments_rec_above. eauto. -- (* long *) - set (ir' := align ir 2) in *. - assert (DFL: - In (S Outgoing ofs ty) (regs_of_rpairs - ((if Archi.ptr64 - then One (S Outgoing (align ofs0 2) Tlong) - else Twolong (S Outgoing (align ofs0 2) Tint) - (S Outgoing (align ofs0 2 + 1) Tint)) - :: loc_arguments_rec tyl ir' fr (align ofs0 2 + 2))) -> - ofs + typesize ty <= size_arguments_rec tyl ir' fr (align ofs0 2 + 2)). - { destruct Archi.ptr64; intros IN. - - destruct IN. inv H1. apply size_arguments_rec_above. auto. - - destruct IN. inv H1. transitivity (align ofs0 2 + 2). simpl; omega. apply size_arguments_rec_above. - destruct H1. inv H1. transitivity (align ofs0 2 + 2). simpl; omega. apply size_arguments_rec_above. - auto. } - destruct (list_nth_z int_param_regs ir'); auto. - destruct (list_nth_z int_param_regs (ir' + 1)); auto. - destruct H0. congruence. destruct H0. congruence. eauto. -- (* single *) - destruct (list_nth_z float_param_regs fr); destruct H0. - congruence. - eauto. - inv H0. transitivity (align ofs0 2 + 2). simpl; omega. apply size_arguments_rec_above. - eauto. -- (* any32 *) - destruct (list_nth_z int_param_regs ir); destruct H0. - congruence. - eauto. - inv H0. apply size_arguments_rec_above. - eauto. -- (* any64 *) - destruct (list_nth_z float_param_regs fr); destruct H0. - congruence. - eauto. - inv H0. apply size_arguments_rec_above. eauto. - } - eauto. -Qed. - Lemma loc_arguments_main: loc_arguments signature_main = nil. Proof. diff --git a/riscV/Conventions1.v b/riscV/Conventions1.v index 27d09d94..a705c954 100644 --- a/riscV/Conventions1.v +++ b/riscV/Conventions1.v @@ -265,24 +265,6 @@ Fixpoint loc_arguments_rec (va: bool) 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. *) @@ -387,52 +369,6 @@ 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. diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index c82d406e..b8353046 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -251,7 +251,7 @@ let expand_builtin_va_start_32 r = invalid_arg "Fatal error: va_start used in non-vararg function"; let ofs = Int32.(add (add !PrintAsmaux.current_function_stacksize 4l) - (mul 4l (Z.to_int32 (Conventions1.size_arguments + (mul 4l (Z.to_int32 (Conventions.size_arguments (get_current_function_sig ()))))) in emit (Pleal (RAX, linear_addr RSP (Z.of_uint32 ofs))); emit (Pmovl_mr (linear_addr r _0z, RAX)) diff --git a/x86/Conventions1.v b/x86/Conventions1.v index 01b15e98..fdd94239 100644 --- a/x86/Conventions1.v +++ b/x86/Conventions1.v @@ -220,36 +220,6 @@ Definition loc_arguments (s: signature) : list (rpair loc) := then loc_arguments_64 s.(sig_args) 0 0 0 else loc_arguments_32 s.(sig_args) 0. -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Fixpoint size_arguments_32 - (tyl: list typ) (ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | ty :: tys => size_arguments_32 tys (ofs + typesize ty) - end. - -Fixpoint size_arguments_64 (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | (Tint | Tlong | Tany32 | Tany64) :: tys => - match list_nth_z int_param_regs ir with - | None => size_arguments_64 tys ir fr (ofs + 2) - | Some ireg => size_arguments_64 tys (ir + 1) fr ofs - end - | (Tfloat | Tsingle) :: tys => - match list_nth_z float_param_regs fr with - | None => size_arguments_64 tys ir fr (ofs + 2) - | Some freg => size_arguments_64 tys ir (fr + 1) ofs - end - end. - -Definition size_arguments (s: signature) : Z := - if Archi.ptr64 - then size_arguments_64 s.(sig_args) 0 0 0 - else size_arguments_32 s.(sig_args) 0. - (** Argument locations are either caller-save registers or [Outgoing] stack slots at nonnegative offsets. *) @@ -351,121 +321,6 @@ Qed. Hint Resolve loc_arguments_acceptable: locs. -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark size_arguments_32_above: - forall tyl ofs0, ofs0 <= size_arguments_32 tyl ofs0. -Proof. - induction tyl; simpl; intros. - omega. - apply Z.le_trans with (ofs0 + typesize a); auto. - generalize (typesize_pos a); omega. -Qed. - -Remark size_arguments_64_above: - forall tyl ir fr ofs0, - ofs0 <= size_arguments_64 tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - omega. - assert (A: ofs0 <= - match list_nth_z int_param_regs ir with - | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { destruct (list_nth_z int_param_regs ir); eauto. - apply Z.le_trans with (ofs0 + 2); auto. omega. } - assert (B: ofs0 <= - match list_nth_z float_param_regs fr with - | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { destruct (list_nth_z float_param_regs fr); eauto. - apply Z.le_trans with (ofs0 + 2); auto. omega. } - destruct a; auto. -Qed. - -Lemma size_arguments_above: - forall s, size_arguments s >= 0. -Proof. - intros; unfold size_arguments. apply Z.le_ge. - destruct Archi.ptr64; [apply size_arguments_64_above|apply size_arguments_32_above]. -Qed. - -Lemma loc_arguments_32_bounded: - forall ofs ty tyl ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_32 tyl ofs0)) -> - ofs + typesize ty <= size_arguments_32 tyl ofs0. -Proof. - induction tyl as [ | t l]; simpl; intros x IN. -- contradiction. -- rewrite in_app_iff in IN; destruct IN as [IN|IN]. -+ apply Z.le_trans with (x + typesize t); [|apply size_arguments_32_above]. - Ltac decomp := - match goal with - | [ H: _ \/ _ |- _ ] => destruct H; decomp - | [ H: S _ _ _ = S _ _ _ |- _ ] => inv H - | [ H: False |- _ ] => contradiction - end. - destruct t; simpl in IN; decomp; simpl; omega. -+ apply IHl; auto. -Qed. - -Lemma loc_arguments_64_bounded: - forall ofs ty tyl ir fr ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_64 tyl ir fr ofs0)) -> - ofs + typesize ty <= size_arguments_64 tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - contradiction. - assert (T: forall ty0, typesize ty0 <= 2). - { destruct ty0; simpl; omega. } - assert (A: forall ty0, - In (S Outgoing ofs ty) (regs_of_rpairs - match list_nth_z int_param_regs ir with - | Some ireg => - One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs0 - | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2) - end) -> - ofs + typesize ty <= - match list_nth_z int_param_regs ir with - | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { intros. destruct (list_nth_z int_param_regs ir); simpl in H0; destruct H0. - - discriminate. - - eapply IHtyl; eauto. - - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above. - - eapply IHtyl; eauto. } - assert (B: forall ty0, - In (S Outgoing ofs ty) (regs_of_rpairs - match list_nth_z float_param_regs fr with - | Some ireg => - One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs0 - | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2) - end) -> - ofs + typesize ty <= - match list_nth_z float_param_regs fr with - | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { intros. destruct (list_nth_z float_param_regs fr); simpl in H0; destruct H0. - - discriminate. - - eapply IHtyl; eauto. - - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above. - - eapply IHtyl; eauto. } - destruct a; eauto. -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. - unfold loc_arguments, size_arguments; intros. - destruct Archi.ptr64; eauto using loc_arguments_32_bounded, loc_arguments_64_bounded. -Qed. - Lemma loc_arguments_main: loc_arguments signature_main = nil. Proof. -- cgit From c7adc93617712acdde0ea81649eff11ada7d96b9 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 24 Feb 2020 20:22:45 +0100 Subject: The type of a wide char constant is wchar_t. (#223) See ISO C2011 standard, section 6.4.4.4 para 11. --- cparser/Elab.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 9aa6761c..f60e15a3 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -452,7 +452,8 @@ let elab_constant loc = function let (v, fk) = elab_float_constant f in CFloat(v, fk) | CONST_CHAR(wide, s) -> - CInt(elab_char_constant loc wide s, IInt, "") + let ikind = if wide then wchar_ikind () else IInt in + CInt(elab_char_constant loc wide s, ikind, "") | CONST_STRING(wide, s) -> elab_string_literal loc wide s -- cgit From 5003b8d93c2a20821b776f7f74f5096a308a03cf Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Wed, 26 Feb 2020 16:49:50 +0100 Subject: Update the RISC-V calling conventions (#221) We were implementing the ABI described in the RISC-V Instruction Set Manual, version 2.1. However, this ABI was superseded by the RISC-V ELF psABI specification. This commit changes the calling conventions to better match the ELF psABI specification. This should greatly improve interoperability with code compiled by other RISC-V compilers. One incompatibility remains: when all 8 FP argument registers have been used, further FP arguments should be passed in integer argument registers if available, while this PR passes them on stack. --- riscV/Asmexpand.ml | 36 ++++---- riscV/Conventions1.v | 250 +++++++++++++++++++++++++++------------------------ 2 files changed, 149 insertions(+), 137 deletions(-) diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index d36b6230..7e36abf8 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -63,44 +63,44 @@ let expand_storeind_ptr src base ofs = let int_param_regs = [| X10; X11; X12; X13; X14; X15; X16; X17 |] let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] -let rec fixup_variadic_call pos tyl = - if pos < 8 then +let rec fixup_variadic_call ri rf tyl = + if ri < 8 then match tyl with | [] -> () | (Tint | Tany32) :: tyl -> - fixup_variadic_call (pos + 1) tyl + fixup_variadic_call (ri + 1) rf tyl | Tsingle :: tyl -> - let rs =float_param_regs.(pos) - and rd = int_param_regs.(pos) in + let rs = float_param_regs.(rf) + and rd = int_param_regs.(ri) in emit (Pfmvxs(rd, rs)); - fixup_variadic_call (pos + 1) tyl + fixup_variadic_call (ri + 1) (rf + 1) tyl | Tlong :: tyl -> - let pos' = if Archi.ptr64 then pos + 1 else align pos 2 + 2 in - fixup_variadic_call pos' tyl + let ri' = if Archi.ptr64 then ri + 1 else align ri 2 + 2 in + fixup_variadic_call ri' rf tyl | (Tfloat | Tany64) :: tyl -> if Archi.ptr64 then begin - let rs = float_param_regs.(pos) - and rd = int_param_regs.(pos) in + let rs = float_param_regs.(rf) + and rd = int_param_regs.(ri) in emit (Pfmvxd(rd, rs)); - fixup_variadic_call (pos + 1) tyl + fixup_variadic_call (ri + 1) (rf + 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 + let ri = align ri 2 in + if ri < 8 then begin + let rs = float_param_regs.(rf) + and rd1 = int_param_regs.(ri) + and rd2 = int_param_regs.(ri + 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 + fixup_variadic_call (ri + 2) (rf + 1) tyl end end let fixup_call sg = - if sg.sig_cc.cc_vararg then fixup_variadic_call 0 sg.sig_args + if sg.sig_cc.cc_vararg then fixup_variadic_call 0 0 sg.sig_args (* Handling of annotations *) diff --git a/riscV/Conventions1.v b/riscV/Conventions1.v index a705c954..7f8048f6 100644 --- a/riscV/Conventions1.v +++ b/riscV/Conventions1.v @@ -105,7 +105,9 @@ Definition is_float_reg (r: mreg) := 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. *) + implement the standard RISC-V conventions as found here: + https://github.com/riscv/riscv-elf-psabi-doc/blob/master/riscv-elf.md +*) (** ** Location of function result *) @@ -169,38 +171,32 @@ Qed. (** ** Location of function arguments *) -(** The RISC-V ABI states the following convention for passing arguments +(** The RISC-V ABI states the following conventions 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. +- RV64, not variadic: pass the first 8 integer arguments in + integer registers (a1...a8: int_param_regs), the first 8 FP arguments + in FP registers (fa1...fa8: float_param_regs), and the remaining + arguments on the stack, in 8-byte slots. + +- RV32, not variadic: same, but arguments of 64-bit integer type + are passed in two consecutive integer registers (a(i), a(i+1)) + or in a(8) and on a 32-bit word on the stack. Stack-allocated + arguments are aligned to their natural alignment. + +- RV64, variadic: pass the first 8 arguments in integer registers + (a1...a8), including FP arguments; pass the remaining arguments on + the stack, in 8-byte slots. + +- RV32, variadic: same, but arguments of 64-bit types (integers as well + as floats) are passed in two consecutive aligned integer registers + (a(2i), a(2i+1)). + +The passing of FP arguments to variadic functions in integer registers +doesn't quite fit CompCert's model. We do our best by passing the FP +arguments in registers, as usual, and reserving the corresponding +integer registers, so that fixup code can be introduced in the +Asmexpand pass. *) Definition int_param_regs := @@ -208,62 +204,84 @@ Definition int_param_regs := Definition float_param_regs := F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: F16 :: F17 :: nil. -Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) - (rec: Z -> Z -> list (rpair loc)) := - match list_nth_z regs rn with +Definition int_arg (ri rf ofs: Z) (ty: typ) + (rec: Z -> Z -> Z -> list (rpair loc)) := + match list_nth_z int_param_regs ri with | Some r => - One(R r) :: rec (rn + 1) ofs + One(R r) :: rec (ri + 1) rf 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)) + One(S Outgoing ofs ty) + :: rec ri rf (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) +Definition float_arg (va: bool) (ri rf ofs: Z) (ty: typ) + (rec: Z -> Z -> Z -> list (rpair loc)) := + match list_nth_z float_param_regs rf with + | Some r => + if va then + (let ri' := (* reserve 1 or 2 aligned integer registers *) + if Archi.ptr64 || zeq (typesize ty) 1 then ri + 1 else align ri 2 + 2 in + if zle ri' 8 then + (* we have enough integer registers, put argument in FP reg + and fixup code will put it in one or two integer regs *) + One (R r) :: rec ri' (rf + 1) ofs + else + (* we are out of integer registers, pass argument on stack *) + let ofs := align ofs (typealign ty) in + One(S Outgoing ofs ty) + :: rec ri' rf (ofs + (if Archi.ptr64 then 2 else typesize ty))) + else + One (R r) :: rec ri (rf + 1) ofs + | None => + let ofs := align ofs (typealign ty) in + One(S Outgoing ofs ty) + :: rec ri rf (ofs + (if Archi.ptr64 then 2 else typesize ty)) 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 => +Definition split_long_arg (va: bool) (ri rf ofs: Z) + (rec: Z -> Z -> Z -> list (rpair loc)) := + let ri := if va then align ri 2 else ri in + match list_nth_z int_param_regs ri, list_nth_z int_param_regs (ri + 1) with + | Some r1, Some r2 => + Twolong (R r2) (R r1) :: rec (ri + 2) rf ofs + | Some r1, None => + Twolong (S Outgoing ofs Tint) (R r1) :: rec (ri + 1) rf (ofs + 1) + | None, _ => let ofs := align ofs 2 in - One (S Outgoing ofs ty) :: rec rn (ofs + 2) + Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) :: + rec ri rf (ofs + 2) end. Fixpoint loc_arguments_rec (va: bool) - (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) := + (tyl: list typ) (ri rf ofs: Z) {struct tyl} : list (rpair loc) := match tyl with | nil => nil | (Tint | Tany32) as ty :: tys => - one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) + (* pass in one integer register or on stack *) + int_arg ri rf ofs ty (loc_arguments_rec va tys) | Tsingle as ty :: tys => - one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + (* pass in one FP register or on stack. + If vararg, reserve 1 integer register. *) + float_arg va ri rf 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) + if Archi.ptr64 then + (* pass in one integer register or on stack *) + int_arg ri rf ofs ty (loc_arguments_rec va tys) + else + (* pass in register pair or on stack; align register pair if vararg *) + split_long_arg va ri rf 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) + (* pass in one FP register or on stack. + If vararg, reserve 1 or 2 integer registers. *) + float_arg va ri rf 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. + loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0 0. (** Argument locations are either non-temporary registers or [Outgoing] stack slots at nonnegative offsets. *) @@ -276,15 +294,18 @@ Definition loc_argument_acceptable (l: loc) : Prop := end. Lemma loc_arguments_rec_charact: - forall va tyl rn ofs p, + forall va tyl ri rf ofs p, ofs >= 0 -> - In p (loc_arguments_rec va tyl rn ofs) -> forall_rpair loc_argument_acceptable p. + In p (loc_arguments_rec va tyl ri rf 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). + set (OKF := fun (f: Z -> Z -> Z -> list (rpair loc)) => + forall ri rf ofs, ofs >= 0 -> OK (f ri rf ofs)). + assert (CSI: forall r, In r int_param_regs -> is_callee_save r = false). + { decide_goal. } + assert (CSF: forall r, In r float_param_regs -> is_callee_save r = false). + { decide_goal. } 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). @@ -293,73 +314,64 @@ Proof. { 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. + assert (A: forall ri rf ofs ty f, + OKF f -> ofs >= 0 -> OK (int_arg ri rf ofs ty f)). + { intros until f; intros OF OO; red; unfold int_arg; intros. + destruct (list_nth_z int_param_regs ri) as [r|] eqn:NTH; destruct H. + - subst p; simpl. apply CSI. 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). + assert (B: forall va ri rf ofs ty f, + OKF f -> ofs >= 0 -> OK (float_arg va ri rf ofs ty f)). + { intros until f; intros OF OO; red; unfold float_arg; intros. + destruct (list_nth_z float_param_regs rf) as [r|] eqn:NTH. + - set (ri' := if Archi.ptr64 || zeq (typesize ty) 1 then ri + 1 else align ri 2 + 2) in *. + destruct va; [destruct (zle ri' 8)|idtac]; destruct H. + + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto. + + eapply OF; eauto. + + subst p; repeat split; auto using align_divides, typealign_pos. + + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega. + + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto. + + eapply OF; eauto. + - destruct H. + + subst p; repeat split; auto using align_divides, typealign_pos. + + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega. + } + assert (C: forall va ri rf ofs f, + OKF f -> ofs >= 0 -> OK (split_long_arg va ri rf ofs f)). + { intros until f; intros OF OO; unfold split_long_arg. + set (ri' := if va then align ri 2 else ri). 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. + destruct (list_nth_z int_param_regs ri') as [r1|] eqn:NTH1; + [destruct (list_nth_z int_param_regs (ri'+1)) as [r2|] eqn:NTH2 | idtac]. + - red; simpl; intros; destruct H. + + subst p; split; apply CSI; eauto using list_nth_z_in. + + eapply OF; [idtac|eauto]. omega. + - red; simpl; intros; destruct H. + + subst p; split. split; auto using Z.divide_1_l. apply CSI; eauto using list_nth_z_in. + + eapply OF; [idtac|eauto]. omega. + - red; simpl; intros; destruct H. + + subst p; repeat split; auto using Z.divide_1_l. omega. + + eapply OF; [idtac|eauto]. omega. } - assert (D: OKREGS int_param_regs). - { red. decide_goal. } - assert (E: OKREGS float_param_regs). - { red. decide_goal. } - - cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)). + cut (forall va tyl ri rf ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl ri rf ofs)). unfold OK. eauto. induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. - red; simpl; tauto. - destruct ty1. + (* int *) apply A; auto. -+ (* float *) - destruct (va && negb Archi.ptr64). - apply C; auto. - apply A; auto. ++ (* float *) apply B; auto. + (* long *) destruct Archi.ptr64. apply A; auto. - apply B; auto. -+ (* single *) - apply A; auto. -+ (* any32 *) - apply A; auto. -+ (* any64 *) - destruct (va && negb Archi.ptr64). apply C; auto. - apply A; auto. ++ (* single *) apply B; auto. ++ (* any32 *) apply A; auto. ++ (* any64 *) apply B; auto. Qed. Lemma loc_arguments_acceptable: -- cgit From 222c9047d61961db9c6b19fed5ca49829223fd33 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 27 Feb 2020 05:45:13 +0100 Subject: CSE2 now uses is_trivial_op --- backend/CSE2.v | 2 +- backend/CSE2proof.v | 23 +++++++++++++++++++++-- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 1e3bc3b7..19b633b0 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -525,7 +525,7 @@ Definition transf_instr (fmap : option (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/CSE2proof.v b/backend/CSE2proof.v index 0b92f5e5..eb4268f0 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1401,6 +1401,24 @@ Proof. Qed. Hint Resolve wellformed_mem_mpc : wellformed. +Lemma match_same_option : + forall { A B : Type}, + forall x : option A, + forall y : B, + (match x with Some _ => y | None => y end) = y. +Proof. + destruct x; trivial. +Qed. + +Lemma match_same_bool : + forall { B : Type}, + forall x : bool, + forall y : B, + (if x then y else y) = y. +Proof. + destruct x; trivial. +Qed. + Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> @@ -1428,8 +1446,9 @@ Proof. reflexivity. - (* op *) unfold transf_instr in *. - destruct find_op_in_fmap eqn:FIND_OP. + destruct (if is_trivial_op op then None else find_op_in_fmap (forward_map f) pc op (subst_args (forward_map f) pc args)) eqn:FIND_OP. { + destruct is_trivial_op. discriminate. unfold find_op_in_fmap, fmap_sem', fmap_sem in *. destruct (forward_map f) as [map |] eqn:MAP. 2: discriminate. @@ -1846,4 +1865,4 @@ Proof. exact step_simulation. Qed. -End PRESERVATION. \ No newline at end of file +End PRESERVATION. -- cgit From e66be6e05b190c51b38d628884ef3e015ebf73fd Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 24 Feb 2020 19:59:43 +0100 Subject: Make single arg alignment depend on toolchain. GCC does passes single arguments as singles on the stack but diab and the eabi say single arguments should be passed as double on the stack. This commit changes the alignment of single arguments to 4 for gcc based backends. --- powerpc/Archi.v | 3 +++ powerpc/Conventions1.v | 17 ++++++++++++++--- powerpc/extractionMachdep.v | 3 +++ 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/powerpc/Archi.v b/powerpc/Archi.v index ab348c14..88fff302 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -30,6 +30,9 @@ Definition align_float64 := 8%Z. (** Can we use the 64-bit extensions to the PowerPC architecture? *) Parameter ppc64 : bool. +(** Should singles be passed as single or double *) +Parameter single_passed_as_single : bool. + Definition splitlong := negb ppc64. Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v index 1f048694..5639ff8d 100644 --- a/powerpc/Conventions1.v +++ b/powerpc/Conventions1.v @@ -208,7 +208,16 @@ Fixpoint loc_arguments_rec | Some ireg => One (R ireg) :: loc_arguments_rec tys (ir + 1) fr ofs end - | (Tfloat | Tsingle | Tany64) as ty :: tys => + | Tsingle as ty :: tys => + match list_nth_z float_param_regs fr with + | None => + let ty := if Archi.single_passed_as_single then Tsingle else Tfloat in + let ofs := align ofs (typesize ty) in + One (S Outgoing ofs Tsingle) :: loc_arguments_rec tys ir fr (ofs + (typesize ty)) + | Some freg => + One (R freg) :: loc_arguments_rec tys ir (fr + 1) ofs + end + | (Tfloat | Tany64) as ty :: tys => match list_nth_z float_param_regs fr with | None => let ofs := align ofs 2 in @@ -295,12 +304,14 @@ Opaque list_nth_z. apply align_divides; omega. apply Z.divide_1_l. apply Z.divide_1_l. eapply Y; eauto. omega. - (* single *) + assert (ofs <= align ofs 1) by (apply align_le; omega). assert (ofs <= align ofs 2) by (apply align_le; omega). destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. - subst. split. omega. apply Z.divide_1_l. - eapply Y; eauto. omega. + subst. split. destruct Archi.single_passed_as_single; simpl; omega. + destruct Archi.single_passed_as_single; simpl; apply Z.divide_1_l. + eapply Y; eauto. destruct Archi.single_passed_as_single; simpl; omega. - (* any32 *) destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H. subst. left. eapply list_nth_z_in; eauto. diff --git a/powerpc/extractionMachdep.v b/powerpc/extractionMachdep.v index 7482435f..a3e945bf 100644 --- a/powerpc/extractionMachdep.v +++ b/powerpc/extractionMachdep.v @@ -34,3 +34,6 @@ Extract Constant Archi.ppc64 => | ""e5500"" -> true | _ -> false end". + +(* Choice of passing of single *) +Extract Constant Archi.single_passed_as_single => "Configuration.gnu_toolchain". -- cgit From 78d76b65b417b2724cc54a7e5fc5d434d8fc57b5 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 27 Feb 2020 10:04:43 +0100 Subject: Define IRC.class_of_type for types Tany32, Tany64 Until now the types Tany32 and Tany64 were not used prior to register allocation, so IRC.class_of_type did not need to be defined for those types. However, there are possible uses of stack slots of type Tany32 and Tany64 to specify calling conventions. For this purpose, we need to define class_of_type for Tany32 and Tany64. We follow the informal convention that Tany32 goes in integer registers and Tany64 goes into integer registers if 64-bit wide, or FP registers otherwise. --- backend/IRC.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/backend/IRC.ml b/backend/IRC.ml index 43955897..b359da35 100644 --- a/backend/IRC.ml +++ b/backend/IRC.ml @@ -240,7 +240,8 @@ type graph = { let class_of_type = function | Tint | Tlong -> 0 | Tfloat | Tsingle -> 1 - | Tany32 | Tany64 -> assert false + | Tany32 -> 0 + | Tany64 -> if Archi.ptr64 then 0 else 1 let class_of_reg r = if Conventions1.is_float_reg r then 1 else 0 -- cgit From 9190ca38b3ae098186421a7cc21a087666a6a677 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 27 Feb 2020 10:10:23 +0100 Subject: In strict PPC ABI mode, pass single FP on stack in double FP format The EABI and the SVR4 ABI state that single-precision FP arguments passed on stack are passed as a 64-bit word, extended to double-precision. This commit implements this behavior by using a stack slot of type Tany64. Not only this ensures that the slot is of size and alignment 8 bytes, but it also ensures that it is accessed by stfd and lfd instructions, using single-extended-to-double format. --- powerpc/Conventions1.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v index 5639ff8d..5c9cbd4f 100644 --- a/powerpc/Conventions1.v +++ b/powerpc/Conventions1.v @@ -211,9 +211,9 @@ Fixpoint loc_arguments_rec | Tsingle as ty :: tys => match list_nth_z float_param_regs fr with | None => - let ty := if Archi.single_passed_as_single then Tsingle else Tfloat in + let ty := if Archi.single_passed_as_single then Tsingle else Tany64 in let ofs := align ofs (typesize ty) in - One (S Outgoing ofs Tsingle) :: loc_arguments_rec tys ir fr (ofs + (typesize ty)) + One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + (typesize ty)) | Some freg => One (R freg) :: loc_arguments_rec tys ir (fr + 1) ofs end -- cgit From 35ba7f373963d8a1f0094abd457809d1e3c3cdb4 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 27 Feb 2020 10:15:40 +0100 Subject: Documentation comment for single_passed_as_single --- powerpc/Archi.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/powerpc/Archi.v b/powerpc/Archi.v index 88fff302..10f38391 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -30,7 +30,8 @@ Definition align_float64 := 8%Z. (** Can we use the 64-bit extensions to the PowerPC architecture? *) Parameter ppc64 : bool. -(** Should singles be passed as single or double *) +(** Should single-precision FP arguments passed on stack be passed + as singles or use double FP format. *) Parameter single_passed_as_single : bool. Definition splitlong := negb ppc64. -- cgit From 8587b8310a91702e2635a689e1622a87b7bf8985 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 2 Mar 2020 10:32:07 +0100 Subject: Weaker ec_readonly condition over external calls (#225) Currently we require the memory to be unchanged on readonly locations. This is too strong. For example, current permissions could decrease from readonly to none. This commit weakens the ec_readonly condition to the strict minimum needed to show the correctness of value analysis for const globals. --- backend/ValueAnalysis.v | 5 ++--- common/Events.v | 48 +++++++++++++++++++++++++++++++++--------------- 2 files changed, 35 insertions(+), 18 deletions(-) diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 2b233900..b0ce019c 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -1039,9 +1039,8 @@ Proof. red; simpl; intros. destruct (plt b (Mem.nextblock m)). exploit RO; eauto. intros (R & P & Q). split; auto. - split. apply bmatch_incr with bc; auto. apply bmatch_inv with m; auto. - intros. eapply Mem.loadbytes_unchanged_on_1. eapply external_call_readonly; eauto. - auto. intros; red. apply Q. + split. apply bmatch_incr with bc; auto. apply bmatch_ext with m; auto. + intros. eapply external_call_readonly with (m2 := m'); eauto. intros; red; intros; elim (Q ofs). eapply external_call_max_perm with (m2 := m'); eauto. destruct (j' b); congruence. diff --git a/common/Events.v b/common/Events.v index 10e0c232..4431b0b7 100644 --- a/common/Events.v +++ b/common/Events.v @@ -649,9 +649,12 @@ Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop := (** External call cannot modify memory unless they have [Max, Writable] permissions. *) ec_readonly: - forall ge vargs m1 t vres m2, + forall ge vargs m1 t vres m2 b ofs n bytes, sem ge vargs m1 t vres m2 -> - Mem.unchanged_on (loc_not_writable m1) m1 m2; + Mem.valid_block m1 b -> + Mem.loadbytes m2 b ofs n = Some bytes -> + (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) -> + Mem.loadbytes m1 b ofs n = Some bytes; (** External calls must commute with memory extensions, in the following sense. *) @@ -784,7 +787,7 @@ Proof. (* max perms *) - inv H; auto. (* readonly *) -- inv H. apply Mem.unchanged_on_refl. +- inv H; auto. (* mem extends *) - inv H. inv H1. inv H6. inv H4. exploit volatile_load_extends; eauto. intros [v' [A B]]. @@ -833,14 +836,27 @@ Proof. rewrite C; auto. Qed. +Lemma unchanged_on_readonly: + forall m1 m2 b ofs n bytes, + Mem.unchanged_on (loc_not_writable m1) m1 m2 -> + Mem.valid_block m1 b -> + Mem.loadbytes m2 b ofs n = Some bytes -> + (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) -> + Mem.loadbytes m1 b ofs n = Some bytes. +Proof. + intros. + rewrite <- H1. symmetry. + apply Mem.loadbytes_unchanged_on_1 with (P := loc_not_writable m1); auto. +Qed. + Lemma volatile_store_readonly: forall ge chunk1 m1 b1 ofs1 v t m2, volatile_store ge chunk1 m1 b1 ofs1 v t m2 -> Mem.unchanged_on (loc_not_writable m1) m1 m2. Proof. intros. inv H. - apply Mem.unchanged_on_refl. - eapply Mem.store_unchanged_on; eauto. +- apply Mem.unchanged_on_refl. +- eapply Mem.store_unchanged_on; eauto. exploit Mem.store_valid_access_3; eauto. intros [P Q]. intros. unfold loc_not_writable. red; intros. elim H2. apply Mem.perm_cur_max. apply P. auto. @@ -934,7 +950,7 @@ Proof. (* perms *) - inv H. inv H2. auto. eauto with mem. (* readonly *) -- inv H. eapply volatile_store_readonly; eauto. +- inv H. eapply unchanged_on_readonly; eauto. eapply volatile_store_readonly; eauto. (* mem extends*) - inv H. inv H1. inv H6. inv H7. inv H4. exploit volatile_store_extends; eauto. intros [m2' [A [B C]]]. @@ -994,7 +1010,7 @@ Proof. rewrite dec_eq_false. auto. apply Mem.valid_not_valid_diff with m1; eauto with mem. (* readonly *) -- inv H. eapply UNCHANGED; eauto. +- inv H. eapply unchanged_on_readonly; eauto. (* mem extends *) - inv H. inv H1. inv H7. assert (SZ: v2 = Vptrofs sz). @@ -1065,8 +1081,9 @@ Proof. (* perms *) - inv H. eapply Mem.perm_free_3; eauto. (* readonly *) -- inv H. eapply Mem.free_unchanged_on; eauto. - intros. red; intros. elim H3. +- inv H. eapply unchanged_on_readonly; eauto. + eapply Mem.free_unchanged_on; eauto. + intros. red; intros. elim H6. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.free_range_perm; eauto. (* mem extends *) @@ -1159,8 +1176,9 @@ Proof. - (* perms *) intros. inv H. eapply Mem.perm_storebytes_2; eauto. - (* readonly *) - intros. inv H. eapply Mem.storebytes_unchanged_on; eauto. - intros; red; intros. elim H8. + intros. inv H. eapply unchanged_on_readonly; eauto. + eapply Mem.storebytes_unchanged_on; eauto. + intros; red; intros. elim H11. apply Mem.perm_cur_max. eapply Mem.storebytes_range_perm; eauto. - (* extensions *) intros. inv H. @@ -1271,7 +1289,7 @@ Proof. (* perms *) - inv H; auto. (* readonly *) -- inv H. apply Mem.unchanged_on_refl. +- inv H; auto. (* mem extends *) - inv H. exists Vundef; exists m1'; intuition. @@ -1316,7 +1334,7 @@ Proof. (* perms *) - inv H; auto. (* readonly *) -- inv H. apply Mem.unchanged_on_refl. +- inv H; auto. (* mem extends *) - inv H. inv H1. inv H6. exists v2; exists m1'; intuition. @@ -1359,7 +1377,7 @@ Proof. (* perms *) - inv H; auto. (* readonly *) -- inv H. apply Mem.unchanged_on_refl. +- inv H; auto. (* mem extends *) - inv H. exists Vundef; exists m1'; intuition. @@ -1406,7 +1424,7 @@ Proof. (* perms *) - inv H; auto. (* readonly *) -- inv H. apply Mem.unchanged_on_refl. +- inv H; auto. (* mem extends *) - inv H. fold bsem in H2. apply val_inject_list_lessdef in H1. specialize (bs_inject _ bsem _ _ _ H1). -- cgit From f8d3d265f6ef967acf6eea017cb472809096a135 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 2 Mar 2020 10:41:11 +0100 Subject: Define the semantics of `free(NULL)` (#226) According to ISO C, `free(NULL)` is correct and does nothing. This commit updates accordingly the formal semantics of the `free` external function and the reference interpreter. Closes: #334 --- cfrontend/Cexec.v | 73 +++++++++++++++++++++++++++++++++---------------------- common/Events.v | 44 ++++++++++++++++++++++----------- 2 files changed, 74 insertions(+), 43 deletions(-) diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index 2942080b..b08c3ad7 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -460,6 +460,14 @@ Definition do_ef_free check (zlt 0 (Ptrofs.unsigned sz)); do m' <- Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz); Some(w, E0, Vundef, m') + | Vint n :: nil => + if Int.eq_dec n Int.zero && negb Archi.ptr64 + then Some(w, E0, Vundef, m) + else None + | Vlong n :: nil => + if Int64.eq_dec n Int64.zero && Archi.ptr64 + then Some(w, E0, Vundef, m) + else None | _ => None end. @@ -544,45 +552,51 @@ Proof with try congruence. - eapply do_external_function_sound; eauto. } destruct ef; simpl. -(* EF_external *) +- (* EF_external *) eapply do_external_function_sound; eauto. -(* EF_builtin *) +- (* EF_builtin *) eapply BF_EX; eauto. -(* EF_runtime *) +- (* EF_runtime *) eapply BF_EX; eauto. -(* EF_vload *) +- (* EF_vload *) unfold do_ef_volatile_load. destruct vargs... destruct v... destruct vargs... mydestr. destruct p as [[w'' t''] v]; mydestr. exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto. - auto. -(* EF_vstore *) +- (* EF_vstore *) unfold do_ef_volatile_store. destruct vargs... destruct v... destruct vargs... destruct vargs... mydestr. destruct p as [[w'' t''] m'']. mydestr. exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto. - auto. -(* EF_malloc *) +- (* EF_malloc *) unfold do_ef_malloc. destruct vargs... destruct vargs... mydestr. destruct (Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned i)) as [m1 b] eqn:?. mydestr. split. apply SIZE in Heqo. subst v. econstructor; eauto. constructor. -(* EF_free *) - unfold do_ef_free. destruct vargs... destruct v... destruct vargs... - mydestr. split. apply SIZE in Heqo0. econstructor; eauto. congruence. omega. constructor. -(* EF_memcpy *) +- (* EF_free *) + unfold do_ef_free. destruct vargs... destruct v... ++ destruct vargs... mydestr; InvBooleans; subst i. + replace (Vint Int.zero) with Vnullptr. split; constructor. + apply negb_true_iff in H0. unfold Vnullptr; rewrite H0; auto. ++ destruct vargs... mydestr; InvBooleans; subst i. + replace (Vlong Int64.zero) with Vnullptr. split; constructor. + unfold Vnullptr; rewrite H0; auto. ++ destruct vargs... mydestr. + split. apply SIZE in Heqo0. econstructor; eauto. congruence. omega. + constructor. +- (* EF_memcpy *) unfold do_ef_memcpy. destruct vargs... destruct v... destruct vargs... destruct v... destruct vargs... mydestr. apply Decidable_sound in Heqb1. red in Heqb1. split. econstructor; eauto; tauto. constructor. -(* EF_annot *) +- (* EF_annot *) unfold do_ef_annot. mydestr. split. constructor. apply list_eventval_of_val_sound; auto. econstructor. constructor; eauto. constructor. -(* EF_annot_val *) +- (* EF_annot_val *) unfold do_ef_annot_val. destruct vargs... destruct vargs... mydestr. split. constructor. apply eventval_of_val_sound; auto. econstructor. constructor; eauto. constructor. -(* EF_inline_asm *) +- (* EF_inline_asm *) eapply do_inline_assembly_sound; eauto. -(* EF_debug *) +- (* EF_debug *) unfold do_ef_debug. mydestr. split; constructor. Qed. @@ -605,37 +619,38 @@ Proof. - eapply do_external_function_complete; eauto. } destruct ef; simpl in *. -(* EF_external *) +- (* EF_external *) eapply do_external_function_complete; eauto. -(* EF_builtin *) +- (* EF_builtin *) eapply BF_EX; eauto. -(* EF_runtime *) +- (* EF_runtime *) eapply BF_EX; eauto. -(* EF_vload *) +- (* EF_vload *) inv H; unfold do_ef_volatile_load. exploit do_volatile_load_complete; eauto. intros EQ; rewrite EQ; auto. -(* EF_vstore *) +- (* EF_vstore *) inv H; unfold do_ef_volatile_store. exploit do_volatile_store_complete; eauto. intros EQ; rewrite EQ; auto. -(* EF_malloc *) +- (* EF_malloc *) inv H; unfold do_ef_malloc. inv H0. erewrite SIZE by eauto. rewrite H1, H2. auto. -(* EF_free *) +- (* EF_free *) inv H; unfold do_ef_free. - inv H0. rewrite H1. erewrite SIZE by eauto. rewrite zlt_true. rewrite H3. auto. omega. -(* EF_memcpy *) ++ inv H0. rewrite H1. erewrite SIZE by eauto. rewrite zlt_true. rewrite H3. auto. omega. ++ inv H0. unfold Vnullptr; destruct Archi.ptr64; auto. +- (* EF_memcpy *) inv H; unfold do_ef_memcpy. inv H0. rewrite Decidable_complete. rewrite H7; rewrite H8; auto. red. tauto. -(* EF_annot *) +- (* EF_annot *) inv H; unfold do_ef_annot. inv H0. inv H6. inv H4. rewrite (list_eventval_of_val_complete _ _ _ H1). auto. -(* EF_annot_val *) +- (* EF_annot_val *) inv H; unfold do_ef_annot_val. inv H0. inv H6. inv H4. rewrite (eventval_of_val_complete _ _ _ H1). auto. -(* EF_inline_asm *) +- (* EF_inline_asm *) eapply do_inline_assembly_complete; eauto. -(* EF_debug *) +- (* EF_debug *) inv H. inv H0. reflexivity. Qed. diff --git a/common/Events.v b/common/Events.v index 4431b0b7..022adaef 100644 --- a/common/Events.v +++ b/common/Events.v @@ -1061,11 +1061,13 @@ Qed. Inductive extcall_free_sem (ge: Senv.t): list val -> mem -> trace -> val -> mem -> Prop := - | extcall_free_sem_intro: forall b lo sz m m', + | extcall_free_sem_ptr: forall b lo sz m m', Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) = Some (Vptrofs sz) -> Ptrofs.unsigned sz > 0 -> Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) = Some m' -> - extcall_free_sem ge (Vptr b lo :: nil) m E0 Vundef m'. + extcall_free_sem ge (Vptr b lo :: nil) m E0 Vundef m' + | extcall_free_sem_null: forall m, + extcall_free_sem ge (Vnullptr :: nil) m E0 Vundef m. Lemma extcall_free_ok: extcall_properties extcall_free_sem @@ -1073,27 +1075,29 @@ Lemma extcall_free_ok: Proof. constructor; intros. (* well typed *) -- inv H. simpl. auto. +- inv H; simpl; auto. (* symbols preserved *) - inv H0; econstructor; eauto. (* valid block *) -- inv H. eauto with mem. +- inv H; eauto with mem. (* perms *) -- inv H. eapply Mem.perm_free_3; eauto. +- inv H; eauto using Mem.perm_free_3. (* readonly *) -- inv H. eapply unchanged_on_readonly; eauto. - eapply Mem.free_unchanged_on; eauto. +- eapply unchanged_on_readonly; eauto. inv H. ++ eapply Mem.free_unchanged_on; eauto. intros. red; intros. elim H6. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.free_range_perm; eauto. ++ apply Mem.unchanged_on_refl. (* mem extends *) -- inv H. inv H1. inv H8. inv H6. +- inv H. ++ inv H1. inv H8. inv H6. exploit Mem.load_extends; eauto. intros [v' [A B]]. assert (v' = Vptrofs sz). { unfold Vptrofs in *; destruct Archi.ptr64; inv B; auto. } subst v'. exploit Mem.free_parallel_extends; eauto. intros [m2' [C D]]. - exists Vundef; exists m2'; intuition. + exists Vundef; exists m2'; intuition auto. econstructor; eauto. eapply Mem.free_unchanged_on; eauto. unfold loc_out_of_bounds; intros. @@ -1101,8 +1105,14 @@ Proof. { apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.free_range_perm. eexact H4. eauto. } tauto. ++ inv H1. inv H5. replace v2 with Vnullptr. + exists Vundef; exists m1'; intuition auto. + constructor. + apply Mem.unchanged_on_refl. + unfold Vnullptr in *; destruct Archi.ptr64; inv H3; auto. (* mem inject *) -- inv H0. inv H2. inv H7. inv H9. +- inv H0. ++ inv H2. inv H7. inv H9. exploit Mem.load_inject; eauto. intros [v' [A B]]. assert (v' = Vptrofs sz). { unfold Vptrofs in *; destruct Archi.ptr64; inv B; auto. } @@ -1116,7 +1126,7 @@ Proof. intro EQ. exploit Mem.free_parallel_inject; eauto. intros (m2' & C & D). exists f, Vundef, m2'; split. - apply extcall_free_sem_intro with (sz := sz) (m' := m2'). + apply extcall_free_sem_ptr with (sz := sz) (m' := m2'). rewrite EQ. rewrite <- A. f_equal. omega. auto. auto. rewrite ! EQ. rewrite <- C. f_equal; omega. @@ -1129,14 +1139,19 @@ Proof. apply P. omega. split. auto. red; intros. congruence. ++ inv H2. inv H6. replace v' with Vnullptr. + exists f, Vundef, m1'; intuition auto using Mem.unchanged_on_refl. + constructor. + red; intros; congruence. + unfold Vnullptr in *; destruct Archi.ptr64; inv H4; auto. (* trace length *) - inv H; simpl; omega. (* receptive *) -- assert (t1 = t2). inv H; inv H0; auto. subst t2. +- assert (t1 = t2) by (inv H; inv H0; auto). subst t2. exists vres1; exists m1; auto. (* determ *) -- inv H; inv H0. - assert (EQ1: Vptrofs sz0 = Vptrofs sz) by congruence. +- inv H; inv H0; try (unfold Vnullptr in *; discriminate). ++ assert (EQ1: Vptrofs sz0 = Vptrofs sz) by congruence. assert (EQ2: sz0 = sz). { unfold Vptrofs in EQ1; destruct Archi.ptr64 eqn:SF. rewrite <- (Ptrofs.of_int64_to_int64 SF sz0), <- (Ptrofs.of_int64_to_int64 SF sz). congruence. @@ -1144,6 +1159,7 @@ Proof. } subst sz0. split. constructor. intuition congruence. ++ split. constructor. intuition auto. Qed. (** ** Semantics of [memcpy] operations. *) -- cgit From 94558ecb3e48261f12c644045d40c7d0784415e0 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 2 Mar 2020 11:39:06 +0100 Subject: Define the semantics of `free(NULL)`, continued The proof script for Events.excall_free_ok was incomplete if Archi.ptr64 is unknown (as in the RISC-V case). --- common/Events.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common/Events.v b/common/Events.v index 022adaef..28bb992a 100644 --- a/common/Events.v +++ b/common/Events.v @@ -1150,7 +1150,7 @@ Proof. - assert (t1 = t2) by (inv H; inv H0; auto). subst t2. exists vres1; exists m1; auto. (* determ *) -- inv H; inv H0; try (unfold Vnullptr in *; discriminate). +- inv H; inv H0; try (unfold Vnullptr in *; destruct Archi.ptr64; discriminate). + assert (EQ1: Vptrofs sz0 = Vptrofs sz) by congruence. assert (EQ2: sz0 = sz). { unfold Vptrofs in EQ1; destruct Archi.ptr64 eqn:SF. -- cgit From 6af8f4275f7f9572d4d0783818cbfb85357807c6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Mar 2020 13:17:54 +0100 Subject: loadv_storev_same --- common/Memory.v | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/common/Memory.v b/common/Memory.v index b68a5049..89b920b3 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -1169,6 +1169,24 @@ Local Hint Resolve store_valid_block_1 store_valid_block_2: mem. Local Hint Resolve store_valid_access_1 store_valid_access_2 store_valid_access_3: mem. + +Section STOREV. +Variable chunk: memory_chunk. +Variable m1: mem. +Variables addr v: val. +Variable m2: mem. +Hypothesis STORE: storev chunk m1 addr v = Some m2. + + +Theorem loadv_storev_same: + loadv chunk m2 addr = Some (Val.load_result chunk v). +Proof. + destruct addr; simpl in *; try discriminate. + eapply load_store_same. + eassumption. +Qed. +End STOREV. + Lemma load_store_overlap: forall chunk m1 b ofs v m2 chunk' ofs' v', store chunk m1 b ofs v = Some m2 -> -- cgit From fbfbc3c4cbe250a40513e5dabcd6930b39043ea3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Mar 2020 18:14:23 +0100 Subject: playing with offsets --- backend/CSE2proof.v | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 82fa8a28..4dd8b054 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -14,6 +14,7 @@ Require Import Globalenvs Values. Require Import Linking Values Memory Globalenvs Events Smallstep. Require Import Registers Op RTL. Require Import CSE2. +Require Import Lia. Lemma args_unaffected: forall rs : regset, @@ -697,6 +698,71 @@ Proof. Qed. End SAME_MEMORY. +Section MEMORY_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + Variable base : val. + Variable ofsw ofsr : Z. + + Hypothesis RANGEW : 0 <= ofsw <= 18446744073709551608. + Hypothesis RANGER : 0 <= ofsr <= 18446744073709551608. + + Lemma size_chunk_bounded : + forall chunk, 0 <= size_chunk chunk <= 8. + Proof. + destruct chunk; simpl; lia. + Qed. + + Hypothesis no_overlap: + ofsw + size_chunk chunkw <= ofsr + \/ ofsr + size_chunk chunkr <= ofsw. + + Variable addrw addrr valw valr : val. + + Hypothesis ADDRW : eval_addressing genv sp + (Aindexed ofsw) (base :: nil) = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aindexed ofsr) (base :: nil) = Some addrr. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. + + Theorem load_store_away : + Mem.loadv chunkr m2 addrr = Some valr. + Proof. + pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. + pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. + + destruct addrr ; simpl in * ; try discriminate. + unfold eval_addressing in *. + destruct Archi.ptr64 eqn:PTR64. + { + unfold eval_addressing64 in *. + inv ADDRW. + destruct base; simpl in *; try discriminate. + rewrite PTR64 in *. + inv ADDRR. + rewrite <- READ. + eapply Mem.load_store_other. + exact STORE. + right. + destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int64 (Int64.repr ofsr))) as [OFSR | OFSR]; + rewrite OFSR. + all: destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int64 (Int64.repr ofsw))) as [OFSW | OFSW]; + rewrite OFSW. + all: unfold Ptrofs.of_int64. + all: repeat rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; lia). + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia). + all: change Ptrofs.modulus with 18446744073709551616. + all: intuition lia. + } + { + destruct base; simpl in *; try discriminate. + } + Qed. +End MEMORY_WRITE. + Lemma kill_mem_sound : forall m m' : mem, forall rel : RELATION.t, @@ -1305,4 +1371,4 @@ Proof. exact step_simulation. Qed. -End PRESERVATION. \ No newline at end of file +End PRESERVATION. -- cgit From c11b19619e82377be9c43e926d66086124637044 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 2 Mar 2020 18:59:02 +0100 Subject: Update the RISC-V calling conventions, continued (#227) Double FP arguments passed on stack were incorrectly aligned: they must be 8-aligned but were 4-aligned only. This was due to the use of `Location.typealign`, which is the minimal hardware-supported alignment for a given type, namely 1 word for type Tfloat. To get the correct alignments, `Location.typesize` must be used instead. --- riscV/Conventions1.v | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/riscV/Conventions1.v b/riscV/Conventions1.v index 7f8048f6..17326139 100644 --- a/riscV/Conventions1.v +++ b/riscV/Conventions1.v @@ -210,7 +210,7 @@ Definition int_arg (ri rf ofs: Z) (ty: typ) | Some r => One(R r) :: rec (ri + 1) rf ofs | None => - let ofs := align ofs (typealign ty) in + let ofs := align ofs (typesize ty) in One(S Outgoing ofs ty) :: rec ri rf (ofs + (if Archi.ptr64 then 2 else typesize ty)) end. @@ -228,13 +228,13 @@ Definition float_arg (va: bool) (ri rf ofs: Z) (ty: typ) One (R r) :: rec ri' (rf + 1) ofs else (* we are out of integer registers, pass argument on stack *) - let ofs := align ofs (typealign ty) in + let ofs := align ofs (typesize ty) in One(S Outgoing ofs ty) :: rec ri' rf (ofs + (if Archi.ptr64 then 2 else typesize ty))) else One (R r) :: rec ri (rf + 1) ofs | None => - let ofs := align ofs (typealign ty) in + let ofs := align ofs (typesize ty) in One(S Outgoing ofs ty) :: rec ri rf (ofs + (if Archi.ptr64 then 2 else typesize ty)) end. @@ -306,10 +306,13 @@ Proof. { decide_goal. } assert (CSF: forall r, In r float_param_regs -> is_callee_save r = false). { decide_goal. } - assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typealign ty) >= 0). + assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typesize ty) >= 0). { intros. - assert (ofs <= align ofs (typealign ty)) by (apply align_le; apply typealign_pos). + assert (ofs <= align ofs (typesize ty)) by (apply align_le; apply typesize_pos). omega. } + assert (ALD: forall ofs ty, ofs >= 0 -> (typealign ty | align ofs (typesize ty))). + { intros. eapply Z.divide_trans. apply typealign_typesize. + apply align_divides. apply typesize_pos. } 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). @@ -332,12 +335,12 @@ Proof. destruct va; [destruct (zle ri' 8)|idtac]; destruct H. + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto. + eapply OF; eauto. - + subst p; repeat split; auto using align_divides, typealign_pos. + + subst p; repeat split; auto. + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega. + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto. + eapply OF; eauto. - destruct H. - + subst p; repeat split; auto using align_divides, typealign_pos. + + subst p; repeat split; auto. + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega. } assert (C: forall va ri rf ofs f, -- cgit From 036fc22224c8d171a90b608f6146e742a51e0a25 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Mar 2020 19:10:35 +0100 Subject: works on x86 x86_64 --- backend/CSE2proof.v | 76 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 47 insertions(+), 29 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 4dd8b054..55ec653c 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -704,12 +704,18 @@ Section MEMORY_WRITE. Variable base : val. Variable ofsw ofsr : Z. + Definition max_chunk_size := 8. + (* Hypothesis RANGEW : 0 <= ofsw <= 18446744073709551608. Hypothesis RANGER : 0 <= ofsr <= 18446744073709551608. - + *) + Hypothesis RANGEW : 0 <= ofsw <= Ptrofs.modulus - max_chunk_size. + Hypothesis RANGER : 0 <= ofsr <= Ptrofs.modulus - max_chunk_size. + Lemma size_chunk_bounded : - forall chunk, 0 <= size_chunk chunk <= 8. + forall chunk, 0 <= size_chunk chunk <= max_chunk_size. Proof. + unfold max_chunk_size. destruct chunk; simpl; lia. Qed. @@ -731,35 +737,47 @@ Section MEMORY_WRITE. Proof. pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. - + unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. + try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. + try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. destruct addrr ; simpl in * ; try discriminate. unfold eval_addressing in *. - destruct Archi.ptr64 eqn:PTR64. - { - unfold eval_addressing64 in *. - inv ADDRW. - destruct base; simpl in *; try discriminate. - rewrite PTR64 in *. - inv ADDRR. - rewrite <- READ. - eapply Mem.load_store_other. - exact STORE. - right. - destruct (Ptrofs.unsigned_add_either i0 - (Ptrofs.of_int64 (Int64.repr ofsr))) as [OFSR | OFSR]; - rewrite OFSR. - all: destruct (Ptrofs.unsigned_add_either i0 - (Ptrofs.of_int64 (Int64.repr ofsw))) as [OFSW | OFSW]; - rewrite OFSW. - all: unfold Ptrofs.of_int64. - all: repeat rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; lia). - all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia). - all: change Ptrofs.modulus with 18446744073709551616. - all: intuition lia. - } - { - destruct base; simpl in *; try discriminate. - } + destruct Archi.ptr64 eqn:PTR64; destruct base; simpl in *; try discriminate. + rewrite PTR64 in *. + + inv ADDRR. + inv ADDRW. + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int (Int.repr ofsr))) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int64 (Int64.repr ofsr))) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int (Int.repr ofsw))) as [OFSW | OFSW]; + rewrite OFSW). + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int64 (Int64.repr ofsw))) as [OFSW | OFSW]; + rewrite OFSW). + + all: unfold Ptrofs.of_int64. + all: unfold Ptrofs.of_int. + + + all: repeat rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; lia). + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia). + all: repeat rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; lia). + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia). + + all: try change Ptrofs.modulus with 4294967296. + all: try change Ptrofs.modulus with 18446744073709551616. + + all: intuition lia. Qed. End MEMORY_WRITE. -- cgit From f7ea436ac282b6a4a8ddb2281b6e1d86eee46286 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Mar 2020 19:50:21 +0100 Subject: swap predicate --- backend/CSE2.v | 8 ++++++++ backend/CSE2proof.v | 32 +++++++++++++++++++------------- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index b7665097..a03e02a4 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -266,6 +266,14 @@ Definition kill_reg (dst : reg) (rel : RELATION.t) := PTree.filter1 (fun x => negb (kill_sym_val dst x)) (PTree.remove dst rel). +Definition max_chunk_size := 8. + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - max_chunk_size)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - max_chunk_size)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + Definition kill_sym_val_mem (sv: sym_val) := match sv with | SMove _ => false diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 55ec653c..6d5496fd 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -704,14 +704,6 @@ Section MEMORY_WRITE. Variable base : val. Variable ofsw ofsr : Z. - Definition max_chunk_size := 8. - (* - Hypothesis RANGEW : 0 <= ofsw <= 18446744073709551608. - Hypothesis RANGER : 0 <= ofsr <= 18446744073709551608. - *) - Hypothesis RANGEW : 0 <= ofsw <= Ptrofs.modulus - max_chunk_size. - Hypothesis RANGER : 0 <= ofsr <= Ptrofs.modulus - max_chunk_size. - Lemma size_chunk_bounded : forall chunk, 0 <= size_chunk chunk <= max_chunk_size. Proof. @@ -719,10 +711,6 @@ Section MEMORY_WRITE. destruct chunk; simpl; lia. Qed. - Hypothesis no_overlap: - ofsw + size_chunk chunkw <= ofsr - \/ ofsr + size_chunk chunkr <= ofsw. - Variable addrw addrr valw valr : val. Hypothesis ADDRW : eval_addressing genv sp @@ -732,9 +720,15 @@ Section MEMORY_WRITE. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. - Theorem load_store_away : + Lemma load_store_away1 : + forall RANGEW : 0 <= ofsw <= Ptrofs.modulus - max_chunk_size, + forall RANGER : 0 <= ofsr <= Ptrofs.modulus - max_chunk_size, + forall SWAPPABLE : ofsw + size_chunk chunkw <= ofsr + \/ ofsr + size_chunk chunkr <= ofsw, Mem.loadv chunkr m2 addrr = Some valr. Proof. + intros. + pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. @@ -779,6 +773,18 @@ Section MEMORY_WRITE. all: intuition lia. Qed. + + Theorem load_store_away : + can_swap_accesses_ofs ofsr chunkr ofsw chunkw = true -> + Mem.loadv chunkr m2 addrr = Some valr. + 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; intuition. + Qed. End MEMORY_WRITE. Lemma kill_mem_sound : -- cgit From cf56eea4e093f25a5c01ccac5ede2a69b568af7a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Mar 2020 20:16:16 +0100 Subject: load_store_away --- backend/CSE2proof.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 6d5496fd..c6bb00dd 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -783,7 +783,8 @@ Section MEMORY_WRITE. 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; intuition. + apply load_store_away1. + all: tauto. Qed. End MEMORY_WRITE. -- cgit From 3601929b68ced3777c05cd2861847a111603abee Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Mar 2020 21:34:35 +0100 Subject: kill_store1_sound --- backend/CSE2proof.v | 44 +++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 41 insertions(+), 3 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index c6bb00dd..3c42f6e1 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -811,6 +811,44 @@ Proof. } Qed. +Lemma kill_store1_sound : + forall m m' : mem, + forall rel : RELATION.t, + forall chunk addr args a v rs, + (eval_addressing genv sp addr (rs ## args)) = Some a -> + (Mem.storev chunk m a v) = Some m' -> + sem_rel m rel rs -> sem_rel m' (kill_store1 chunk addr args rel) rs. +Proof. + unfold sem_rel, sem_reg. + intros until rs. + intros ADDR STORE SEM x. + pose proof (SEM x) as SEMx. + unfold kill_store1. + rewrite PTree.gfilter1. + destruct (rel ! x) as [ sv | ]. + 2: reflexivity. + destruct sv; simpl in *; trivial. + { + destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial. + rewrite SEMx. + apply op_depends_on_memory_correct; auto. + } + destruct addr; destruct addr0; simpl; trivial. + destruct args as [ | base [ | ]]; simpl; trivial. + destruct args0 as [ | base0 [ | ]]; simpl; trivial. + destruct (peq base base0); simpl; trivial. + subst base0. + destruct (can_swap_accesses_ofs z0 chunk0 z chunk) eqn:SWAP; simpl; trivial. + simpl in *. + destruct (eval_addressing genv sp (Aindexed z0) (rs # base :: nil)) eqn:ADDR0; simpl; trivial. + symmetry. + eapply load_store_away. + exact ADDR. + exact ADDR0. + exact STORE. + congruence. + assumption. +Qed. End SOUNDNESS. Definition match_prog (p tp: RTL.program) := @@ -1193,9 +1231,9 @@ Proof. unfold fmap_sem', fmap_sem in *. 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_mem mpc)); trivial. + apply sem_rel_b_ge with (rb2 := Some (kill_store chunk addr args mpc)); trivial. { - replace (Some (kill_mem mpc)) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (kill_store chunk addr args 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. @@ -1207,7 +1245,7 @@ Proof. rewrite H. reflexivity. } - apply (kill_mem_sound' sp m). + apply (kill_store_sound' sp m). assumption. (* call *) -- cgit From 93bf7e0925b1c11e1874ae5f651970db2bd9823d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Mar 2020 21:55:54 +0100 Subject: kill_store_sound --- backend/CSE2proof.v | 35 +++++++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 3c42f6e1..cd9f5f46 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -502,6 +502,20 @@ Proof. destruct s; congruence. Qed. + +Lemma forward_move_rs: + forall rel arg rs, + sem_rel rel rs -> + rs # (forward_move rel arg) = rs # arg. +Proof. + unfold forward_move, sem_rel, sem_reg, sem_sym_val in *. + intros until rs. + intro REL. + pose proof (REL arg) as RELarg. + destruct (rel ! arg); trivial. + destruct s; congruence. +Qed. + Lemma oper_sound : forall rel : RELATION.t, forall op : operation, @@ -811,19 +825,19 @@ Proof. } Qed. -Lemma kill_store1_sound : +Lemma kill_store_sound : forall m m' : mem, forall rel : RELATION.t, forall chunk addr args a v rs, (eval_addressing genv sp addr (rs ## args)) = Some a -> (Mem.storev chunk m a v) = Some m' -> - sem_rel m rel rs -> sem_rel m' (kill_store1 chunk addr args rel) rs. + sem_rel m rel rs -> sem_rel m' (kill_store chunk addr args rel) rs. Proof. unfold sem_rel, sem_reg. intros until rs. intros ADDR STORE SEM x. pose proof (SEM x) as SEMx. - unfold kill_store1. + unfold kill_store, kill_store1. rewrite PTree.gfilter1. destruct (rel ! x) as [ sv | ]. 2: reflexivity. @@ -836,18 +850,19 @@ Proof. destruct addr; destruct addr0; simpl; trivial. destruct args as [ | base [ | ]]; simpl; trivial. destruct args0 as [ | base0 [ | ]]; simpl; trivial. - destruct (peq base base0); simpl; trivial. + destruct (peq (forward_move rel base) base0); simpl; trivial. subst base0. destruct (can_swap_accesses_ofs z0 chunk0 z chunk) eqn:SWAP; simpl; trivial. simpl in *. - destruct (eval_addressing genv sp (Aindexed z0) (rs # base :: nil)) eqn:ADDR0; simpl; trivial. + erewrite forward_move_rs in * by exact SEM. + destruct (eval_addressing genv sp (Aindexed z0) ((rs # base) :: nil)) eqn:ADDR0; simpl; trivial. symmetry. eapply load_store_away. - exact ADDR. - exact ADDR0. - exact STORE. - congruence. - assumption. + - exact ADDR. + - exact ADDR0. + - exact STORE. + - congruence. + - assumption. Qed. End SOUNDNESS. -- cgit From a398b5750ceeeab90a44b2e1d34fe6d5ff8b1f08 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 06:13:05 +0100 Subject: with indexed/indexed alias analysis for x86 --- backend/CSE2.v | 26 ++++++++++++++++++++++++-- backend/CSE2proof.v | 4 ++-- test/cse2/indexed_addr.c | 6 ++++++ 3 files changed, 32 insertions(+), 4 deletions(-) create mode 100644 test/cse2/indexed_addr.c diff --git a/backend/CSE2.v b/backend/CSE2.v index a03e02a4..f5ff8748 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -281,16 +281,38 @@ Definition kill_sym_val_mem (sv: sym_val) := | SLoad _ _ _ => true end. +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 ofs' chunk' ofs chunk) + else true + | _, _, _, _ => true + end. + +Definition kill_sym_val_store chunk addr args (sv: sym_val) := + match sv with + | SMove _ => false + | SOp op _ => op_depends_on_memory op + | SLoad chunk' addr' args' => may_overlap chunk addr args chunk' addr' args' + end. + Definition kill_mem (rel : RELATION.t) := PTree.filter1 (fun x => negb (kill_sym_val_mem x)) rel. - Definition forward_move (rel : RELATION.t) (x : reg) : reg := match rel ! x with | Some (SMove org) => org | _ => x end. +Definition kill_store1 chunk addr args rel := + PTree.filter1 (fun x => negb (kill_sym_val_store chunk addr args x)) rel. + +Definition kill_store chunk addr args rel := + kill_store1 chunk addr (List.map (forward_move rel) args) rel. + Definition move (src dst : reg) (rel : RELATION.t) := PTree.set dst (SMove (forward_move rel src)) (kill_reg dst rel). @@ -403,7 +425,7 @@ Definition apply_instr instr (rel : RELATION.t) : RB.t := | Inop _ | Icond _ _ _ _ | Ijumptable _ _ => Some rel - | Istore _ _ _ _ _ => Some (kill_mem rel) + | Istore chunk addr args _ _ => Some (kill_store chunk addr args rel) | Iop op args dst _ => Some (gen_oper op dst args rel) | Iload chunk addr args dst _ => Some (load chunk addr dst args rel) | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel)) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index cd9f5f46..e65d9194 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -951,6 +951,7 @@ Definition fmap_sem' := fmap_sem fundef unit ge. Definition subst_arg_ok' := subst_arg_ok fundef unit ge. Definition subst_args_ok' := subst_args_ok fundef unit ge. Definition kill_mem_sound' := kill_mem_sound fundef unit ge. +Definition kill_store_sound' := kill_store_sound fundef unit ge. Lemma sem_rel_b_ge: forall rb1 rb2 : RB.t, @@ -1260,8 +1261,7 @@ Proof. rewrite H. reflexivity. } - apply (kill_store_sound' sp m). - assumption. + eapply (kill_store_sound' sp m); eassumption. (* call *) - econstructor; split. diff --git a/test/cse2/indexed_addr.c b/test/cse2/indexed_addr.c new file mode 100644 index 00000000..30a7c571 --- /dev/null +++ b/test/cse2/indexed_addr.c @@ -0,0 +1,6 @@ +void foo(int *t) { + if (t[0] > 4) { + t[1] ++; + t[0] --; + } +} -- cgit From c4f88ed5581ffb71e7ed5824c7503e8ce08165df Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 08:58:01 +0100 Subject: globals alias analysis for x86 --- backend/CSE2.v | 2 ++ backend/CSE2proof.v | 67 +++++++++++++++++++++++++++++++++++++++++++++-------- test/cse2/globals.c | 8 +++++++ 3 files changed, 67 insertions(+), 10 deletions(-) create mode 100644 test/cse2/globals.c diff --git a/backend/CSE2.v b/backend/CSE2.v index f5ff8748..5b0556aa 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -288,6 +288,8 @@ Definition may_overlap chunk addr args chunk' addr' args' := if peq base base' then negb (can_swap_accesses_ofs ofs' chunk' ofs chunk) else true + | (Aglobal symb ofs), (Aglobal symb' ofs'), + nil, nil => peq symb symb' | _, _, _, _ => true end. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index e65d9194..ada0eb00 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -716,7 +716,6 @@ Section MEMORY_WRITE. Variable m m2 : mem. Variable chunkw chunkr : memory_chunk. Variable base : val. - Variable ofsw ofsr : Z. Lemma size_chunk_bounded : forall chunk, 0 <= size_chunk chunk <= max_chunk_size. @@ -726,13 +725,15 @@ Section MEMORY_WRITE. Qed. Variable addrw addrr valw valr : val. - + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. + + Section INDEXED_AWAY. + Variable ofsw ofsr : Z. Hypothesis ADDRW : eval_addressing genv sp (Aindexed ofsw) (base :: nil) = Some addrw. Hypothesis ADDRR : eval_addressing genv sp (Aindexed ofsr) (base :: nil) = Some addrr. - Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. Lemma load_store_away1 : forall RANGEW : 0 <= ofsw <= Ptrofs.modulus - max_chunk_size, @@ -800,6 +801,47 @@ Section MEMORY_WRITE. apply load_store_away1. all: tauto. Qed. + End INDEXED_AWAY. + + Section DIFFERENT_GLOBALS. + Variable ofsw ofsr : ptrofs. + Hypothesis symw symr : ident. + Hypothesis ADDRW : eval_addressing genv sp + (Aglobal symw ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aglobal symr ofsr) nil = Some addrr. + + Lemma load_store_diff_globals : + symw <> symr -> + Mem.loadv chunkr m2 addrr = Some valr. + Proof. + intros. + unfold eval_addressing in *. + destruct Archi.ptr64 eqn:PTR64; simpl in *. + rewrite PTR64 in *. + 2: simpl in *; discriminate. + unfold Genv.symbol_address in *. + unfold Genv.find_symbol in *. + destruct ((Genv.genv_symb genv) ! symw) as [bw |] eqn:SYMW; inv ADDRW. + 2: simpl in STORE; discriminate. + destruct ((Genv.genv_symb genv) ! symr) as [br |] eqn:SYMR; inv ADDRR. + 2: simpl in READ; discriminate. + assert (br <> bw). + { + intro EQ. + subst br. + assert (symr = symw). + { + eapply Genv.genv_vars_inj; eauto. + } + congruence. + } + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := bw). + - exact STORE. + - left. assumption. + Qed. + End DIFFERENT_GLOBALS. End MEMORY_WRITE. Lemma kill_mem_sound : @@ -848,6 +890,7 @@ Proof. apply op_depends_on_memory_correct; auto. } destruct addr; destruct addr0; simpl; trivial. + { (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]; simpl; trivial. destruct args0 as [ | base0 [ | ]]; simpl; trivial. destruct (peq (forward_move rel base) base0); simpl; trivial. @@ -857,12 +900,16 @@ Proof. erewrite forward_move_rs in * by exact SEM. destruct (eval_addressing genv sp (Aindexed z0) ((rs # base) :: nil)) eqn:ADDR0; simpl; trivial. symmetry. - eapply load_store_away. - - exact ADDR. - - exact ADDR0. - - exact STORE. - - congruence. - - assumption. + eapply load_store_away; eauto. + } + { (* Aglobal / Aglobal *) + destruct args; destruct args0; simpl; trivial. + destruct (peq i i1); simpl; trivial. + simpl in *. + destruct (eval_addressing genv sp (Aglobal i1 i2) nil) eqn:ADDR1; simpl; trivial. + symmetry. + eapply load_store_diff_globals; eauto. + } Qed. End SOUNDNESS. diff --git a/test/cse2/globals.c b/test/cse2/globals.c new file mode 100644 index 00000000..c6dd59cd --- /dev/null +++ b/test/cse2/globals.c @@ -0,0 +1,8 @@ +int glob1, glob2; + +void toto() { + if (glob1 > 4) { + glob2 ++; + glob1 --; + } +} -- cgit From af7afc0a388986a94f21d2657cc13b823d456781 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 09:39:03 +0100 Subject: offsets in globals for x86 --- backend/CSE2.v | 5 +++- backend/CSE2proof.v | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 82 insertions(+), 2 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 5b0556aa..9c45b476 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -289,7 +289,10 @@ Definition may_overlap chunk addr args chunk' addr' args' := then negb (can_swap_accesses_ofs ofs' chunk' ofs chunk) else true | (Aglobal symb ofs), (Aglobal symb' ofs'), - nil, nil => peq symb symb' + nil, nil => + if peq symb symb' + then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + else false | _, _, _, _ => true end. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index ada0eb00..5acffc71 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -842,6 +842,74 @@ Section MEMORY_WRITE. - left. assumption. Qed. End DIFFERENT_GLOBALS. + + Section SAME_GLOBALS. + Variable ofsw ofsr : ptrofs. + Hypothesis sym : ident. + Hypothesis ADDRW : eval_addressing genv sp + (Aglobal sym ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aglobal sym ofsr) nil = Some addrr. + + Lemma load_store_glob_away1 : + forall RANGEW : 0 <= (Ptrofs.unsigned ofsw) <= Ptrofs.modulus - max_chunk_size, + forall RANGER : 0 <= (Ptrofs.unsigned ofsr) <= Ptrofs.modulus - max_chunk_size, + 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 = Some valr. + Proof. + intros. + + pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. + pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. + unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. + try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. + try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. + unfold eval_addressing, eval_addressing32, eval_addressing64 in *. + destruct Archi.ptr64 eqn:PTR64. + + { + unfold Genv.symbol_address in *. + inv ADDRR. + inv ADDRW. + destruct (Genv.find_symbol genv sym). + 2: discriminate. + + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + tauto. + } + + { + unfold Genv.symbol_address in *. + inv ADDRR. + inv ADDRW. + destruct (Genv.find_symbol genv sym). + 2: discriminate. + + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + tauto. + } + Qed. + + Lemma load_store_glob_away : + (can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw) = true -> + Mem.loadv chunkr m2 addrr = Some valr. + 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_glob_away1. + all: tauto. + Qed. + End SAME_GLOBALS. End MEMORY_WRITE. Lemma kill_mem_sound : @@ -904,7 +972,16 @@ Proof. } { (* Aglobal / Aglobal *) destruct args; destruct args0; simpl; trivial. - destruct (peq i i1); simpl; trivial. + destruct (peq i i1). + { + subst i1. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i2) chunk0 + (Ptrofs.unsigned i0) chunk) eqn:SWAP; simpl; trivial. + simpl in *. + destruct (eval_addressing genv sp (Aglobal i i2) nil) eqn:ADDR1; simpl; trivial. + symmetry. + eapply load_store_glob_away; eauto. + } simpl in *. destruct (eval_addressing genv sp (Aglobal i1 i2) nil) eqn:ADDR1; simpl; trivial. symmetry. -- cgit From b11cbccf7eb4a6696c5285cb0bcde57dd0c0447e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 10:41:33 +0100 Subject: starting to move x86 stuff to x86 --- backend/CSE2proof.v | 202 +----------------------------------------------- x86/CSE2depsproof.v | 215 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 216 insertions(+), 201 deletions(-) create mode 100644 x86/CSE2depsproof.v diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 5acffc71..eeb9442f 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -13,7 +13,7 @@ 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. +Require Import CSE2 CSE2depsproof. Require Import Lia. Lemma args_unaffected: @@ -712,206 +712,6 @@ Proof. Qed. End SAME_MEMORY. -Section MEMORY_WRITE. - Variable m m2 : mem. - Variable chunkw chunkr : memory_chunk. - Variable base : val. - - Lemma size_chunk_bounded : - forall chunk, 0 <= size_chunk chunk <= max_chunk_size. - Proof. - unfold max_chunk_size. - destruct chunk; simpl; lia. - Qed. - - Variable addrw addrr valw valr : val. - Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. - - Section INDEXED_AWAY. - Variable ofsw ofsr : Z. - 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 <= ofsw <= Ptrofs.modulus - max_chunk_size, - forall RANGER : 0 <= ofsr <= Ptrofs.modulus - max_chunk_size, - forall SWAPPABLE : ofsw + size_chunk chunkw <= ofsr - \/ ofsr + size_chunk chunkr <= ofsw, - Mem.loadv chunkr m2 addrr = Some valr. - Proof. - intros. - - pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. - pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. - unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. - try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. - try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. - destruct addrr ; simpl in * ; try discriminate. - unfold eval_addressing in *. - destruct Archi.ptr64 eqn:PTR64; destruct base; simpl in *; try discriminate. - rewrite PTR64 in *. - - inv ADDRR. - inv ADDRW. - rewrite <- READ. - eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). - exact STORE. - right. - - all: try (destruct (Ptrofs.unsigned_add_either i0 - (Ptrofs.of_int (Int.repr ofsr))) as [OFSR | OFSR]; - rewrite OFSR). - all: try (destruct (Ptrofs.unsigned_add_either i0 - (Ptrofs.of_int64 (Int64.repr ofsr))) as [OFSR | OFSR]; - rewrite OFSR). - all: try (destruct (Ptrofs.unsigned_add_either i0 - (Ptrofs.of_int (Int.repr ofsw))) as [OFSW | OFSW]; - rewrite OFSW). - all: try (destruct (Ptrofs.unsigned_add_either i0 - (Ptrofs.of_int64 (Int64.repr ofsw))) as [OFSW | OFSW]; - rewrite OFSW). - - all: unfold Ptrofs.of_int64. - all: unfold Ptrofs.of_int. - - - all: repeat rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; lia). - all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia). - all: repeat rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; lia). - all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia). - - all: try change Ptrofs.modulus with 4294967296. - all: try change Ptrofs.modulus with 18446744073709551616. - - all: intuition lia. - Qed. - - Theorem load_store_away : - can_swap_accesses_ofs ofsr chunkr ofsw chunkw = true -> - Mem.loadv chunkr m2 addrr = Some valr. - 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. - - Section DIFFERENT_GLOBALS. - Variable ofsw ofsr : ptrofs. - Hypothesis symw symr : ident. - Hypothesis ADDRW : eval_addressing genv sp - (Aglobal symw ofsw) nil = Some addrw. - Hypothesis ADDRR : eval_addressing genv sp - (Aglobal symr ofsr) nil = Some addrr. - - Lemma load_store_diff_globals : - symw <> symr -> - Mem.loadv chunkr m2 addrr = Some valr. - Proof. - intros. - unfold eval_addressing in *. - destruct Archi.ptr64 eqn:PTR64; simpl in *. - rewrite PTR64 in *. - 2: simpl in *; discriminate. - unfold Genv.symbol_address in *. - unfold Genv.find_symbol in *. - destruct ((Genv.genv_symb genv) ! symw) as [bw |] eqn:SYMW; inv ADDRW. - 2: simpl in STORE; discriminate. - destruct ((Genv.genv_symb genv) ! symr) as [br |] eqn:SYMR; inv ADDRR. - 2: simpl in READ; discriminate. - assert (br <> bw). - { - intro EQ. - subst br. - assert (symr = symw). - { - eapply Genv.genv_vars_inj; eauto. - } - congruence. - } - rewrite <- READ. - eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := bw). - - exact STORE. - - left. assumption. - Qed. - End DIFFERENT_GLOBALS. - - Section SAME_GLOBALS. - Variable ofsw ofsr : ptrofs. - Hypothesis sym : ident. - Hypothesis ADDRW : eval_addressing genv sp - (Aglobal sym ofsw) nil = Some addrw. - Hypothesis ADDRR : eval_addressing genv sp - (Aglobal sym ofsr) nil = Some addrr. - - Lemma load_store_glob_away1 : - forall RANGEW : 0 <= (Ptrofs.unsigned ofsw) <= Ptrofs.modulus - max_chunk_size, - forall RANGER : 0 <= (Ptrofs.unsigned ofsr) <= Ptrofs.modulus - max_chunk_size, - 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 = Some valr. - Proof. - intros. - - pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. - pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. - unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. - try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. - try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. - unfold eval_addressing, eval_addressing32, eval_addressing64 in *. - destruct Archi.ptr64 eqn:PTR64. - - { - unfold Genv.symbol_address in *. - inv ADDRR. - inv ADDRW. - destruct (Genv.find_symbol genv sym). - 2: discriminate. - - rewrite <- READ. - eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). - exact STORE. - right. - tauto. - } - - { - unfold Genv.symbol_address in *. - inv ADDRR. - inv ADDRW. - destruct (Genv.find_symbol genv sym). - 2: discriminate. - - rewrite <- READ. - eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). - exact STORE. - right. - tauto. - } - Qed. - - Lemma load_store_glob_away : - (can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw) = true -> - Mem.loadv chunkr m2 addrr = Some valr. - 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_glob_away1. - all: tauto. - Qed. - End SAME_GLOBALS. -End MEMORY_WRITE. - Lemma kill_mem_sound : forall m m' : mem, forall rel : RELATION.t, diff --git a/x86/CSE2depsproof.v b/x86/CSE2depsproof.v new file mode 100644 index 00000000..f4eace6f --- /dev/null +++ b/x86/CSE2depsproof.v @@ -0,0 +1,215 @@ +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. +Require Import Lia. + +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. + + Lemma size_chunk_bounded : + forall chunk, 0 <= size_chunk chunk <= max_chunk_size. + Proof. + unfold max_chunk_size. + destruct chunk; simpl; lia. + Qed. + + Variable addrw addrr valw valr : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. + + Section INDEXED_AWAY. + Variable ofsw ofsr : Z. + 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 <= ofsw <= Ptrofs.modulus - max_chunk_size, + forall RANGER : 0 <= ofsr <= Ptrofs.modulus - max_chunk_size, + forall SWAPPABLE : ofsw + size_chunk chunkw <= ofsr + \/ ofsr + size_chunk chunkr <= ofsw, + Mem.loadv chunkr m2 addrr = Some valr. + Proof. + intros. + + pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. + pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. + unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. + try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. + try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. + destruct addrr ; simpl in * ; try discriminate. + unfold eval_addressing in *. + destruct Archi.ptr64 eqn:PTR64; destruct base; simpl in *; try discriminate. + rewrite PTR64 in *. + + inv ADDRR. + inv ADDRW. + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int (Int.repr ofsr))) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int64 (Int64.repr ofsr))) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int (Int.repr ofsw))) as [OFSW | OFSW]; + rewrite OFSW). + all: try (destruct (Ptrofs.unsigned_add_either i0 + (Ptrofs.of_int64 (Int64.repr ofsw))) as [OFSW | OFSW]; + rewrite OFSW). + + all: unfold Ptrofs.of_int64. + all: unfold Ptrofs.of_int. + + + all: repeat rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; lia). + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia). + all: repeat rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; lia). + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia). + + all: try change Ptrofs.modulus with 4294967296. + all: try change Ptrofs.modulus with 18446744073709551616. + + all: intuition lia. + Qed. + + Theorem load_store_away : + can_swap_accesses_ofs ofsr chunkr ofsw chunkw = true -> + Mem.loadv chunkr m2 addrr = Some valr. + 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. + + Section DIFFERENT_GLOBALS. + Variable ofsw ofsr : ptrofs. + Hypothesis symw symr : ident. + Hypothesis ADDRW : eval_addressing genv sp + (Aglobal symw ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aglobal symr ofsr) nil = Some addrr. + + Lemma load_store_diff_globals : + symw <> symr -> + Mem.loadv chunkr m2 addrr = Some valr. + Proof. + intros. + unfold eval_addressing in *. + destruct Archi.ptr64 eqn:PTR64; simpl in *. + rewrite PTR64 in *. + 2: simpl in *; discriminate. + unfold Genv.symbol_address in *. + unfold Genv.find_symbol in *. + destruct ((Genv.genv_symb genv) ! symw) as [bw |] eqn:SYMW; inv ADDRW. + 2: simpl in STORE; discriminate. + destruct ((Genv.genv_symb genv) ! symr) as [br |] eqn:SYMR; inv ADDRR. + 2: simpl in READ; discriminate. + assert (br <> bw). + { + intro EQ. + subst br. + assert (symr = symw). + { + eapply Genv.genv_vars_inj; eauto. + } + congruence. + } + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := bw). + - exact STORE. + - left. assumption. + Qed. + End DIFFERENT_GLOBALS. + + Section SAME_GLOBALS. + Variable ofsw ofsr : ptrofs. + Hypothesis sym : ident. + Hypothesis ADDRW : eval_addressing genv sp + (Aglobal sym ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aglobal sym ofsr) nil = Some addrr. + + Lemma load_store_glob_away1 : + forall RANGEW : 0 <= (Ptrofs.unsigned ofsw) <= Ptrofs.modulus - max_chunk_size, + forall RANGER : 0 <= (Ptrofs.unsigned ofsr) <= Ptrofs.modulus - max_chunk_size, + 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 = Some valr. + Proof. + intros. + + pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. + pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. + unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. + try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. + try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. + unfold eval_addressing, eval_addressing32, eval_addressing64 in *. + destruct Archi.ptr64 eqn:PTR64. + + { + unfold Genv.symbol_address in *. + inv ADDRR. + inv ADDRW. + destruct (Genv.find_symbol genv sym). + 2: discriminate. + + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + tauto. + } + + { + unfold Genv.symbol_address in *. + inv ADDRR. + inv ADDRW. + destruct (Genv.find_symbol genv sym). + 2: discriminate. + + rewrite <- READ. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + tauto. + } + Qed. + + Lemma load_store_glob_away : + (can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw) = true -> + Mem.loadv chunkr m2 addrr = Some valr. + 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_glob_away1. + all: tauto. + Qed. + End SAME_GLOBALS. +End MEMORY_WRITE. +End SOUNDNESS. -- cgit From 44811b4917b69e9a33efe5ab75ceb3b01f6594fc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 11:21:27 +0100 Subject: may_overlap_sound --- backend/CSE2proof.v | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index eeb9442f..206dbf30 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -735,6 +735,44 @@ Proof. } Qed. +Lemma may_overlap_sound: + forall m m' : mem, + forall chunk addr args chunk' addr' args' v a a' vl 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') = Some vl -> + (Mem.loadv chunk' m' a') = Some vl. +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE LOAD. + 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 z0 chunk' z chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away; eassumption. + } + { (* Aglobal / Aglobal *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + simpl in *. + destruct (peq i i1). + { + subst i1. + rewrite negb_false_iff in OVERLAP. + eapply load_store_glob_away; eassumption. + } + eapply load_store_diff_globals; eassumption. + } +Qed. + Lemma kill_store_sound : forall m m' : mem, forall rel : RELATION.t, -- cgit From 3fc937ddc8f82525081bca67818ca87f448f618e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 11:27:59 +0100 Subject: modularize proof --- backend/CSE2proof.v | 39 ++++++++++----------------------------- 1 file changed, 10 insertions(+), 29 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 206dbf30..90179f82 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -795,36 +795,17 @@ Proof. rewrite SEMx. apply op_depends_on_memory_correct; auto. } - destruct addr; destruct addr0; simpl; trivial. - { (* Aindexed / Aindexed *) - destruct args as [ | base [ | ]]; simpl; trivial. - destruct args0 as [ | base0 [ | ]]; simpl; trivial. - destruct (peq (forward_move rel base) base0); simpl; trivial. - subst base0. - destruct (can_swap_accesses_ofs z0 chunk0 z chunk) eqn:SWAP; simpl; trivial. - simpl in *. - erewrite forward_move_rs in * by exact SEM. - destruct (eval_addressing genv sp (Aindexed z0) ((rs # base) :: nil)) eqn:ADDR0; simpl; trivial. + destruct may_overlap eqn:OVERLAP; simpl; trivial. + destruct (eval_addressing genv sp addr0 rs ## args0) eqn:ADDR0. symmetry. - eapply load_store_away; eauto. - } - { (* Aglobal / Aglobal *) - destruct args; destruct args0; simpl; trivial. - destruct (peq i i1). - { - subst i1. - destruct (can_swap_accesses_ofs (Ptrofs.unsigned i2) chunk0 - (Ptrofs.unsigned i0) chunk) eqn:SWAP; simpl; trivial. - simpl in *. - destruct (eval_addressing genv sp (Aglobal i i2) nil) eqn:ADDR1; simpl; trivial. - symmetry. - eapply load_store_glob_away; eauto. - } - simpl in *. - destruct (eval_addressing genv sp (Aglobal i1 i2) nil) eqn:ADDR1; simpl; trivial. - symmetry. - eapply load_store_diff_globals; eauto. - } + eapply may_overlap_sound with (args := (map (forward_move rel) args)). + erewrite forward_move_map by eassumption. + exact ADDR. + exact ADDR0. + exact OVERLAP. + exact STORE. + symmetry; assumption. + assumption. Qed. End SOUNDNESS. -- cgit From 577d3dbeb54aaf23db19dddf149c48764e20c58d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 11:30:23 +0100 Subject: moved away x86-dependent parts --- backend/CSE2proof.v | 38 -------------------------------------- x86/CSE2depsproof.v | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+), 38 deletions(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 90179f82..8cc87275 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -734,44 +734,6 @@ Proof. apply op_depends_on_memory_correct; auto. } Qed. - -Lemma may_overlap_sound: - forall m m' : mem, - forall chunk addr args chunk' addr' args' v a a' vl 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') = Some vl -> - (Mem.loadv chunk' m' a') = Some vl. -Proof. - intros until rs. - intros ADDR ADDR' OVERLAP STORE LOAD. - 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 z0 chunk' z chunk) eqn:SWAP. - 2: discriminate. - simpl in *. - eapply load_store_away; eassumption. - } - { (* Aglobal / Aglobal *) - destruct args. 2: discriminate. - destruct args'. 2: discriminate. - simpl in *. - destruct (peq i i1). - { - subst i1. - rewrite negb_false_iff in OVERLAP. - eapply load_store_glob_away; eassumption. - } - eapply load_store_diff_globals; eassumption. - } -Qed. Lemma kill_store_sound : forall m m' : mem, diff --git a/x86/CSE2depsproof.v b/x86/CSE2depsproof.v index f4eace6f..84b22c69 100644 --- a/x86/CSE2depsproof.v +++ b/x86/CSE2depsproof.v @@ -213,3 +213,49 @@ Section MEMORY_WRITE. End SAME_GLOBALS. 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' vl 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') = Some vl -> + (Mem.loadv chunk' m' a') = Some vl. +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE LOAD. + 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 z0 chunk' z chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away; eassumption. + } + { (* Aglobal / Aglobal *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + simpl in *. + destruct (peq i i1). + { + subst i1. + rewrite negb_false_iff in OVERLAP. + eapply load_store_glob_away; eassumption. + } + eapply load_store_diff_globals; eassumption. + } +Qed. + +End SOUNDNESS. -- cgit From 74efac13484e4767f793cf9ccc94835825ca30ba Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 12:27:58 +0100 Subject: CSE2 alias analysis for Risc-V --- backend/CSE2.v | 25 +--------- backend/CSE2proof.v | 2 +- backend/ValueDomain.v | 5 -- common/Memdata.v | 7 +++ riscV/CSE2deps.v | 20 ++++++++ riscV/CSE2depsproof.v | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 158 insertions(+), 30 deletions(-) create mode 100644 riscV/CSE2deps.v create mode 100644 riscV/CSE2depsproof.v diff --git a/backend/CSE2.v b/backend/CSE2.v index 9c45b476..8142ee5d 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -6,7 +6,7 @@ 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 Memory Registers Op RTL Maps CSE2deps. (* Static analysis *) @@ -265,14 +265,6 @@ Definition kill_sym_val (dst : reg) (sv : sym_val) := Definition kill_reg (dst : reg) (rel : RELATION.t) := PTree.filter1 (fun x => negb (kill_sym_val dst x)) (PTree.remove dst rel). - -Definition max_chunk_size := 8. - -Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := - (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - max_chunk_size)) - && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - max_chunk_size)) - && ((ofsw + size_chunk chunkw <=? ofsr) || - (ofsr + size_chunk chunkr <=? ofsw)). Definition kill_sym_val_mem (sv: sym_val) := match sv with @@ -281,21 +273,6 @@ Definition kill_sym_val_mem (sv: sym_val) := | SLoad _ _ _ => true end. -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 ofs' chunk' ofs chunk) - else true - | (Aglobal symb ofs), (Aglobal symb' ofs'), - nil, nil => - if peq symb symb' - then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) - else false - | _, _, _, _ => true - end. - Definition kill_sym_val_store chunk addr args (sv: sym_val) := match sv with | SMove _ => false diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 8cc87275..09490c4d 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -13,7 +13,7 @@ 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 CSE2depsproof. +Require Import CSE2 CSE2deps CSE2depsproof. Require Import Lia. Lemma args_unaffected: diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index c132ce7c..779e7bb9 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -3502,11 +3502,6 @@ Proof. - omegaContradiction. Qed. -Lemma max_size_chunk: forall chunk, size_chunk chunk <= 8. -Proof. - destruct chunk; simpl; omega. -Qed. - Remark inval_before_contents: forall i c chunk' av' j, (inval_before i (i - 7) c)##j = Some (ACval chunk' av') -> diff --git a/common/Memdata.v b/common/Memdata.v index f3016efe..a09b90f5 100644 --- a/common/Memdata.v +++ b/common/Memdata.v @@ -44,6 +44,13 @@ Definition size_chunk (chunk: memory_chunk) : Z := | Many64 => 8 end. +Definition largest_size_chunk := 8. + +Lemma max_size_chunk: forall chunk, size_chunk chunk <= 8. +Proof. + destruct chunk; simpl; omega. +Qed. + Lemma size_chunk_pos: forall chunk, size_chunk chunk > 0. Proof. diff --git a/riscV/CSE2deps.v b/riscV/CSE2deps.v new file mode 100644 index 00000000..8ab9242a --- /dev/null +++ b/riscV/CSE2deps.v @@ -0,0 +1,20 @@ +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. diff --git a/riscV/CSE2depsproof.v b/riscV/CSE2depsproof.v new file mode 100644 index 00000000..ee500965 --- /dev/null +++ b/riscV/CSE2depsproof.v @@ -0,0 +1,129 @@ +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 valr : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. + + 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 = Some valr. + 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. + rewrite <- READ. + 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 = Some valr. + 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' vl 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') = Some vl -> + (Mem.loadv chunk' m' a') = Some vl. +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE LOAD. + destruct addr; destruct addr'; try discriminate. + { (* Aindexed / Aindexed *) + destruct args as [ | base [ | ]]. 1,3: discriminate. + destruct args' as [ | base' [ | ]]. 1,3: discriminate. + simpl in OVERLAP. + destruct (peq base base'). 2: discriminate. + subst base'. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. -- cgit From 4096e8c1b1e3d4fcdb44e81844d65a74f881aa47 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 13:33:54 +0100 Subject: better 32/64-bit handling --- x86/CSE2deps.v | 24 ++++++++++++++++++++++++ x86/CSE2depsproof.v | 53 +++++++++++++++++++++++++++-------------------------- 2 files changed, 51 insertions(+), 26 deletions(-) create mode 100644 x86/CSE2deps.v diff --git a/x86/CSE2deps.v b/x86/CSE2deps.v new file mode 100644 index 00000000..f4d9e254 --- /dev/null +++ b/x86/CSE2deps.v @@ -0,0 +1,24 @@ +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 ofs' chunk' ofs chunk) + else true + | (Aglobal symb ofs), (Aglobal symb' ofs'), nil, nil => + if peq symb symb' + then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + else false + | _, _, _, _ => true + end. diff --git a/x86/CSE2depsproof.v b/x86/CSE2depsproof.v index 84b22c69..37e16dfe 100644 --- a/x86/CSE2depsproof.v +++ b/x86/CSE2depsproof.v @@ -5,7 +5,7 @@ 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. +Require Import CSE2 CSE2deps. Require Import Lia. Section SOUNDNESS. @@ -17,13 +17,6 @@ Section MEMORY_WRITE. Variable m m2 : mem. Variable chunkw chunkr : memory_chunk. Variable base : val. - - Lemma size_chunk_bounded : - forall chunk, 0 <= size_chunk chunk <= max_chunk_size. - Proof. - unfold max_chunk_size. - destruct chunk; simpl; lia. - Qed. Variable addrw addrr valw valr : val. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. @@ -37,19 +30,18 @@ Section MEMORY_WRITE. (Aindexed ofsr) (base :: nil) = Some addrr. Lemma load_store_away1 : - forall RANGEW : 0 <= ofsw <= Ptrofs.modulus - max_chunk_size, - forall RANGER : 0 <= ofsr <= Ptrofs.modulus - max_chunk_size, + forall RANGEW : 0 <= ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= ofsr <= Ptrofs.modulus - largest_size_chunk, forall SWAPPABLE : ofsw + size_chunk chunkw <= ofsr \/ ofsr + size_chunk chunkr <= ofsw, Mem.loadv chunkr m2 addrr = Some valr. Proof. intros. - pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. - pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. - unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. - try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. - try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + try change (Ptrofs.modulus - largest_size_chunk) with 4294967288 in *. + try change (Ptrofs.modulus - largest_size_chunk) with 18446744073709551608 in *. destruct addrr ; simpl in * ; try discriminate. unfold eval_addressing in *. destruct Archi.ptr64 eqn:PTR64; destruct base; simpl in *; try discriminate. @@ -111,16 +103,25 @@ Section MEMORY_WRITE. (Aglobal symw ofsw) nil = Some addrw. Hypothesis ADDRR : eval_addressing genv sp (Aglobal symr ofsr) nil = Some addrr. - + + Lemma ptr64_cases: + forall {T : Type}, + forall b : bool, + forall x y : T, + (if b then (if b then x else y) else (if b then y else x)) = x. + Proof. + destruct b; reflexivity. + Qed. + Lemma load_store_diff_globals : symw <> symr -> Mem.loadv chunkr m2 addrr = Some valr. Proof. intros. unfold eval_addressing in *. - destruct Archi.ptr64 eqn:PTR64; simpl in *. - rewrite PTR64 in *. - 2: simpl in *; discriminate. + simpl in *. + rewrite ptr64_cases in ADDRR. + rewrite ptr64_cases in ADDRW. unfold Genv.symbol_address in *. unfold Genv.find_symbol in *. destruct ((Genv.genv_symb genv) ! symw) as [bw |] eqn:SYMW; inv ADDRW. @@ -153,19 +154,19 @@ Section MEMORY_WRITE. (Aglobal sym ofsr) nil = Some addrr. Lemma load_store_glob_away1 : - forall RANGEW : 0 <= (Ptrofs.unsigned ofsw) <= Ptrofs.modulus - max_chunk_size, - forall RANGER : 0 <= (Ptrofs.unsigned ofsr) <= Ptrofs.modulus - max_chunk_size, + 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 = Some valr. Proof. intros. - pose proof (size_chunk_bounded chunkr) as size_chunkr_bounded. - pose proof (size_chunk_bounded chunkw) as size_chunkw_bounded. - unfold max_chunk_size in size_chunkr_bounded, size_chunkw_bounded. - try change (Ptrofs.modulus - max_chunk_size) with 4294967288 in *. - try change (Ptrofs.modulus - max_chunk_size) with 18446744073709551608 in *. + 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 size_chunkr_bounded, size_chunkw_bounded. + try change (Ptrofs.modulus - largest_size_chunk) with 4294967288 in *. + try change (Ptrofs.modulus - largest_size_chunk) with 18446744073709551608 in *. unfold eval_addressing, eval_addressing32, eval_addressing64 in *. destruct Archi.ptr64 eqn:PTR64. -- cgit From 091e00ed16d4189c27a05ad7056eab47bd29f5b7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 14:39:31 +0100 Subject: CSE2 for ARM --- arm/CSE2depsproof.v | 132 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 132 insertions(+) create mode 100644 arm/CSE2depsproof.v diff --git a/arm/CSE2depsproof.v b/arm/CSE2depsproof.v new file mode 100644 index 00000000..2112a230 --- /dev/null +++ b/arm/CSE2depsproof.v @@ -0,0 +1,132 @@ +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 = 32%nat. +Proof. + unfold Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. + trivial. +Qed. + +Lemma ptrofs_modulus : + Ptrofs.modulus = 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 valr : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. + + Section INDEXED_AWAY. + Variable ofsw ofsr : int. + 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 <= Int.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Int.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Int.unsigned ofsw + size_chunk chunkw <= Int.unsigned ofsr + \/ Int.unsigned ofsr + size_chunk chunkr <= Int.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Some valr. + 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. + rewrite <- READ. + 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 (Ptrofs.of_int ofsr)) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsw)) as [OFSW | OFSW]; + rewrite OFSW). + + all: try rewrite ptrofs_modulus in *. + + all: unfold Ptrofs.of_int. + + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia). + all: intuition lia. + Qed. + + Theorem load_store_away : + can_swap_accesses_ofs (Int.unsigned ofsr) chunkr (Int.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Some valr. + 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' vl 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') = Some vl -> + (Mem.loadv chunk' m' a') = Some vl. +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE LOAD. + 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 (Int.unsigned i0) chunk' (Int.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. -- cgit From a2b5e7c85dbbc6a27d941dcd931b36c4aa747fb5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 14:57:20 +0100 Subject: aarch64 --- aarch64/CSE2deps.v | 20 ++++++++ aarch64/CSE2depsproof.v | 130 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 150 insertions(+) create mode 100644 aarch64/CSE2deps.v create mode 100644 aarch64/CSE2depsproof.v diff --git a/aarch64/CSE2deps.v b/aarch64/CSE2deps.v new file mode 100644 index 00000000..90b514a2 --- /dev/null +++ b/aarch64/CSE2deps.v @@ -0,0 +1,20 @@ +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Int64.unsigned ofs') chunk' (Int64.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. diff --git a/aarch64/CSE2depsproof.v b/aarch64/CSE2depsproof.v new file mode 100644 index 00000000..e20824e3 --- /dev/null +++ b/aarch64/CSE2depsproof.v @@ -0,0 +1,130 @@ +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 = 64%nat. +Proof. + unfold Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. + trivial. +Qed. + +Lemma ptrofs_modulus : + Ptrofs.modulus = 18446744073709551616. +Proof. + 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 valr : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. + + Section INDEXED_AWAY. + Variable ofsw ofsr : int64. + 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 <= Int64.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Int64.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Int64.unsigned ofsw + size_chunk chunkw <= Int64.unsigned ofsr + \/ Int64.unsigned ofsr + size_chunk chunkr <= Int64.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Some valr. + 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. + rewrite <- READ. + destruct base; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: unfold Ptrofs.of_int64. + + all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.repr (Int64.unsigned ofsr))) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.repr (Int64.unsigned ofsw))) as [OFSW | OFSW]; + rewrite OFSW). + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia). + + all: try rewrite ptrofs_modulus in *. + + 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 = Some valr. + 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' vl 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') = Some vl -> + (Mem.loadv chunk' m' a') = Some vl. +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE LOAD. + destruct addr; destruct addr'; try discriminate. + { (* Aindexed / Aindexed *) + destruct args as [ | base [ | ]]. 1,3: discriminate. + destruct args' as [ | base' [ | ]]. 1,3: discriminate. + simpl in OVERLAP. + destruct (peq base base'). 2: discriminate. + subst base'. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. -- cgit From 63c878610c5ef531731f5d9f83570f19c8c1acbc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 15:08:43 +0100 Subject: CSE2 for powerpc --- powerpc/CSE2deps.v | 20 ++++++++ powerpc/CSE2depsproof.v | 132 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 152 insertions(+) create mode 100644 powerpc/CSE2deps.v create mode 100644 powerpc/CSE2depsproof.v diff --git a/powerpc/CSE2deps.v b/powerpc/CSE2deps.v new file mode 100644 index 00000000..9db51bbb --- /dev/null +++ b/powerpc/CSE2deps.v @@ -0,0 +1,20 @@ +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Int.unsigned ofs') chunk' (Int.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. diff --git a/powerpc/CSE2depsproof.v b/powerpc/CSE2depsproof.v new file mode 100644 index 00000000..2112a230 --- /dev/null +++ b/powerpc/CSE2depsproof.v @@ -0,0 +1,132 @@ +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 = 32%nat. +Proof. + unfold Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. + trivial. +Qed. + +Lemma ptrofs_modulus : + Ptrofs.modulus = 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 valr : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. + + Section INDEXED_AWAY. + Variable ofsw ofsr : int. + 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 <= Int.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Int.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Int.unsigned ofsw + size_chunk chunkw <= Int.unsigned ofsr + \/ Int.unsigned ofsr + size_chunk chunkr <= Int.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Some valr. + 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. + rewrite <- READ. + 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 (Ptrofs.of_int ofsr)) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsw)) as [OFSW | OFSW]; + rewrite OFSW). + + all: try rewrite ptrofs_modulus in *. + + all: unfold Ptrofs.of_int. + + all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia). + all: intuition lia. + Qed. + + Theorem load_store_away : + can_swap_accesses_ofs (Int.unsigned ofsr) chunkr (Int.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Some valr. + 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' vl 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') = Some vl -> + (Mem.loadv chunk' m' a') = Some vl. +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE LOAD. + 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 (Int.unsigned i0) chunk' (Int.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. -- cgit From 3b640f041be480b82f1b3a1f695ed8a57193bf28 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 15:28:27 +0100 Subject: CSE2 with alias analysis --- arm/CSE2deps.v | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 arm/CSE2deps.v diff --git a/arm/CSE2deps.v b/arm/CSE2deps.v new file mode 100644 index 00000000..9db51bbb --- /dev/null +++ b/arm/CSE2deps.v @@ -0,0 +1,20 @@ +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Int.unsigned ofs') chunk' (Int.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. -- cgit From d14c78013f654ca586681136ba291f1487f1b586 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 17:23:01 +0100 Subject: adjust for x86 --- x86/CSE2depsproof.v | 79 ++++++++++++++++++++++++----------------------------- 1 file changed, 35 insertions(+), 44 deletions(-) diff --git a/x86/CSE2depsproof.v b/x86/CSE2depsproof.v index 37e16dfe..1e913254 100644 --- a/x86/CSE2depsproof.v +++ b/x86/CSE2depsproof.v @@ -18,9 +18,8 @@ Section MEMORY_WRITE. Variable chunkw chunkr : memory_chunk. Variable base : val. - Variable addrw addrr valw valr : val. + Variable addrw addrr valw : val. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. Section INDEXED_AWAY. Variable ofsw ofsr : Z. @@ -34,7 +33,7 @@ Section MEMORY_WRITE. forall RANGER : 0 <= ofsr <= Ptrofs.modulus - largest_size_chunk, forall SWAPPABLE : ofsw + size_chunk chunkw <= ofsr \/ ofsr + size_chunk chunkr <= ofsw, - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intros. @@ -42,14 +41,13 @@ Section MEMORY_WRITE. pose proof (max_size_chunk chunkw) as size_chunkw_bounded. try change (Ptrofs.modulus - largest_size_chunk) with 4294967288 in *. try change (Ptrofs.modulus - largest_size_chunk) with 18446744073709551608 in *. - destruct addrr ; simpl in * ; try discriminate. - unfold eval_addressing in *. + destruct addrr ; simpl in * ; trivial. + unfold eval_addressing, eval_addressing32, eval_addressing64 in *. destruct Archi.ptr64 eqn:PTR64; destruct base; simpl in *; try discriminate. rewrite PTR64 in *. inv ADDRR. inv ADDRW. - rewrite <- READ. eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). exact STORE. right. @@ -84,7 +82,7 @@ Section MEMORY_WRITE. Theorem load_store_away : can_swap_accesses_ofs ofsr chunkr ofsw chunkw = true -> - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intro SWAP. unfold can_swap_accesses_ofs in SWAP. @@ -113,9 +111,20 @@ Section MEMORY_WRITE. destruct b; reflexivity. Qed. + (* not needed + Lemma bool_cases_same: + forall {T : Type}, + forall b : bool, + forall x : T, + (if b then x else x) = x. + Proof. + destruct b; reflexivity. + Qed. + *) + Lemma load_store_diff_globals : symw <> symr -> - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intros. unfold eval_addressing in *. @@ -127,7 +136,7 @@ Section MEMORY_WRITE. destruct ((Genv.genv_symb genv) ! symw) as [bw |] eqn:SYMW; inv ADDRW. 2: simpl in STORE; discriminate. destruct ((Genv.genv_symb genv) ! symr) as [br |] eqn:SYMR; inv ADDRR. - 2: simpl in READ; discriminate. + 2: reflexivity. assert (br <> bw). { intro EQ. @@ -138,7 +147,6 @@ Section MEMORY_WRITE. } congruence. } - rewrite <- READ. eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := bw). - exact STORE. - left. assumption. @@ -158,7 +166,7 @@ Section MEMORY_WRITE. 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 = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intros. @@ -168,40 +176,24 @@ Section MEMORY_WRITE. try change (Ptrofs.modulus - largest_size_chunk) with 4294967288 in *. try change (Ptrofs.modulus - largest_size_chunk) with 18446744073709551608 in *. unfold eval_addressing, eval_addressing32, eval_addressing64 in *. - destruct Archi.ptr64 eqn:PTR64. - - { - unfold Genv.symbol_address in *. - inv ADDRR. - inv ADDRW. - destruct (Genv.find_symbol genv sym). - 2: discriminate. - - rewrite <- READ. - eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). - exact STORE. - right. - tauto. - } - { - unfold Genv.symbol_address in *. - inv ADDRR. - inv ADDRW. - destruct (Genv.find_symbol genv sym). - 2: discriminate. - - rewrite <- READ. - eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). - exact STORE. - right. - tauto. - } + rewrite ptr64_cases in ADDRR. + rewrite ptr64_cases in ADDRW. + unfold Genv.symbol_address in *. + inv ADDRR. + inv ADDRW. + destruct (Genv.find_symbol genv sym). + 2: discriminate. + + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + tauto. Qed. Lemma load_store_glob_away : (can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw) = true -> - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intro SWAP. unfold can_swap_accesses_ofs in SWAP. @@ -223,16 +215,15 @@ Section SOUNDNESS. Lemma may_overlap_sound: forall m m' : mem, - forall chunk addr args chunk' addr' args' v a a' vl rs, + 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') = Some vl -> - (Mem.loadv chunk' m' a') = Some vl. + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). Proof. intros until rs. - intros ADDR ADDR' OVERLAP STORE LOAD. + intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. { (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. -- cgit From ab15e9d17f999637ae16b2913b3c6f4f71f79e37 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 17:36:30 +0100 Subject: fix for risc-V --- riscV/CSE2depsproof.v | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/riscV/CSE2depsproof.v b/riscV/CSE2depsproof.v index ee500965..2ed12658 100644 --- a/riscV/CSE2depsproof.v +++ b/riscV/CSE2depsproof.v @@ -36,7 +36,6 @@ Section MEMORY_WRITE. Variable addrw addrr valw valr : val. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. Section INDEXED_AWAY. Variable ofsw ofsr : ptrofs. @@ -49,8 +48,9 @@ Section MEMORY_WRITE. 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 = Some valr. + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. intros. @@ -62,7 +62,6 @@ Section MEMORY_WRITE. simpl in *. inv ADDRR. inv ADDRW. - rewrite <- READ. destruct base; try discriminate. eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). exact STORE. @@ -80,7 +79,7 @@ Section MEMORY_WRITE. Theorem load_store_away : can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intro SWAP. unfold can_swap_accesses_ofs in SWAP. @@ -102,16 +101,15 @@ Section SOUNDNESS. Lemma may_overlap_sound: forall m m' : mem, - forall chunk addr args chunk' addr' args' v a a' vl rs, + 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') = Some vl -> - (Mem.loadv chunk' m' a') = Some vl. + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). Proof. intros until rs. - intros ADDR ADDR' OVERLAP STORE LOAD. + intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. { (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. -- cgit From 10cb118e1201268b993973852499d38ce6b8d890 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 17:44:04 +0100 Subject: ported for ppc --- powerpc/CSE2depsproof.v | 39 +++++++++++++++++---------------------- 1 file changed, 17 insertions(+), 22 deletions(-) diff --git a/powerpc/CSE2depsproof.v b/powerpc/CSE2depsproof.v index 2112a230..a047b02a 100644 --- a/powerpc/CSE2depsproof.v +++ b/powerpc/CSE2depsproof.v @@ -9,7 +9,7 @@ Require Import CSE2 CSE2deps. Require Import Lia. Lemma ptrofs_size : - Ptrofs.wordsize = 32%nat. + Ptrofs.wordsize = if Archi.ptr64 then 64%nat else 32%nat. Proof. unfold Ptrofs.wordsize. unfold Wordsize_Ptrofs.wordsize. @@ -17,7 +17,7 @@ Proof. Qed. Lemma ptrofs_modulus : - Ptrofs.modulus = 4294967296. + Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296. Proof. unfold Ptrofs.modulus. rewrite ptrofs_size. @@ -34,23 +34,22 @@ Section MEMORY_WRITE. Variable chunkw chunkr : memory_chunk. Variable base : val. - Variable addrw addrr valw valr : val. + Variable addrw addrr valw : val. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. Section INDEXED_AWAY. - Variable ofsw ofsr : int. + 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 <= Int.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, - forall RANGER : 0 <= Int.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, - forall SWAPPABLE : Int.unsigned ofsw + size_chunk chunkw <= Int.unsigned ofsr - \/ Int.unsigned ofsr + size_chunk chunkr <= Int.unsigned ofsw, - Mem.loadv chunkr m2 addrr = Some valr. + 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. @@ -62,28 +61,25 @@ Section MEMORY_WRITE. simpl in *. inv ADDRR. inv ADDRW. - rewrite <- READ. 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 (Ptrofs.of_int ofsr)) as [OFSR | OFSR]; + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; rewrite OFSR). - all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsw)) as [OFSW | OFSW]; + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; rewrite OFSW). all: try rewrite ptrofs_modulus in *. - - all: unfold Ptrofs.of_int. all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia). all: intuition lia. Qed. Theorem load_store_away : - can_swap_accesses_ofs (Int.unsigned ofsr) chunkr (Int.unsigned ofsw) chunkw = true -> - Mem.loadv chunkr m2 addrr = Some valr. + 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. @@ -105,16 +101,15 @@ Section SOUNDNESS. Lemma may_overlap_sound: forall m m' : mem, - forall chunk addr args chunk' addr' args' v a a' vl rs, + 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') = Some vl -> - (Mem.loadv chunk' m' a') = Some vl. + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). Proof. intros until rs. - intros ADDR ADDR' OVERLAP STORE LOAD. + intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. { (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. @@ -122,7 +117,7 @@ Proof. simpl in OVERLAP. destruct (peq base base'). 2: discriminate. subst base'. - destruct (can_swap_accesses_ofs (Int.unsigned i0) chunk' (Int.unsigned i) chunk) eqn:SWAP. + 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. -- cgit From f503e4287bc76150fd3ec5be8c076bf734361493 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 17:56:53 +0100 Subject: ported to arm --- arm/CSE2depsproof.v | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/arm/CSE2depsproof.v b/arm/CSE2depsproof.v index 2112a230..61fe5980 100644 --- a/arm/CSE2depsproof.v +++ b/arm/CSE2depsproof.v @@ -34,9 +34,8 @@ Section MEMORY_WRITE. Variable chunkw chunkr : memory_chunk. Variable base : val. - Variable addrw addrr valw valr : val. + Variable addrw addrr valw : val. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. Section INDEXED_AWAY. Variable ofsw ofsr : int. @@ -50,7 +49,7 @@ Section MEMORY_WRITE. forall RANGER : 0 <= Int.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, forall SWAPPABLE : Int.unsigned ofsw + size_chunk chunkw <= Int.unsigned ofsr \/ Int.unsigned ofsr + size_chunk chunkr <= Int.unsigned ofsw, - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intros. @@ -62,7 +61,6 @@ Section MEMORY_WRITE. simpl in *. inv ADDRR. inv ADDRW. - rewrite <- READ. destruct base; try discriminate. eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). exact STORE. @@ -83,7 +81,7 @@ Section MEMORY_WRITE. Theorem load_store_away : can_swap_accesses_ofs (Int.unsigned ofsr) chunkr (Int.unsigned ofsw) chunkw = true -> - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intro SWAP. unfold can_swap_accesses_ofs in SWAP. @@ -105,16 +103,15 @@ Section SOUNDNESS. Lemma may_overlap_sound: forall m m' : mem, - forall chunk addr args chunk' addr' args' v a a' vl rs, + 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') = Some vl -> - (Mem.loadv chunk' m' a') = Some vl. + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). Proof. intros until rs. - intros ADDR ADDR' OVERLAP STORE LOAD. + intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. { (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. -- cgit From 50fbe4a02ab8deab82c4f137dc9575bac6b9b573 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 18:08:59 +0100 Subject: fix for aarch64 --- aarch64/CSE2depsproof.v | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/aarch64/CSE2depsproof.v b/aarch64/CSE2depsproof.v index e20824e3..4aac23af 100644 --- a/aarch64/CSE2depsproof.v +++ b/aarch64/CSE2depsproof.v @@ -32,9 +32,8 @@ Section MEMORY_WRITE. Variable chunkw chunkr : memory_chunk. Variable base : val. - Variable addrw addrr valw valr : val. + Variable addrw addrr valw : val. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - Hypothesis READ : Mem.loadv chunkr m addrr = Some valr. Section INDEXED_AWAY. Variable ofsw ofsr : int64. @@ -48,7 +47,7 @@ Section MEMORY_WRITE. forall RANGER : 0 <= Int64.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, forall SWAPPABLE : Int64.unsigned ofsw + size_chunk chunkw <= Int64.unsigned ofsr \/ Int64.unsigned ofsr + size_chunk chunkr <= Int64.unsigned ofsw, - Mem.loadv chunkr m2 addrr = Some valr. + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intros. @@ -60,7 +59,7 @@ Section MEMORY_WRITE. simpl in *. inv ADDRR. inv ADDRW. - rewrite <- READ. + destruct base; try discriminate. eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). exact STORE. @@ -80,8 +79,8 @@ Section MEMORY_WRITE. Qed. Theorem load_store_away : - can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> - Mem.loadv chunkr m2 addrr = Some valr. + can_swap_accesses_ofs (Int64.unsigned ofsr) chunkr (Int64.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intro SWAP. unfold can_swap_accesses_ofs in SWAP. @@ -103,16 +102,15 @@ Section SOUNDNESS. Lemma may_overlap_sound: forall m m' : mem, - forall chunk addr args chunk' addr' args' v a a' vl rs, + 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') = Some vl -> - (Mem.loadv chunk' m' a') = Some vl. + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). Proof. intros until rs. - intros ADDR ADDR' OVERLAP STORE LOAD. + intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. { (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. @@ -120,7 +118,7 @@ Proof. 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. + destruct (can_swap_accesses_ofs (Int64.unsigned ofs0) chunk' (Int64.unsigned ofs) chunk) eqn:SWAP. 2: discriminate. simpl in *. eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. -- cgit From 5996f8d84a61f76292f1a40c39faeb838011de6e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 18:10:00 +0100 Subject: fixes for risc-V --- riscV/CSE2depsproof.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/riscV/CSE2depsproof.v b/riscV/CSE2depsproof.v index 2ed12658..a3811e78 100644 --- a/riscV/CSE2depsproof.v +++ b/riscV/CSE2depsproof.v @@ -34,7 +34,7 @@ Section MEMORY_WRITE. Variable chunkw chunkr : memory_chunk. Variable base : val. - Variable addrw addrr valw valr : val. + Variable addrw addrr valw : val. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. Section INDEXED_AWAY. -- cgit From 4f659bb46bb3e2d2c1f297d65e71bb8e66782f79 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 18:13:04 +0100 Subject: forgot k1C --- mppa_k1c/CSE2deps.v | 20 ++++++++ mppa_k1c/CSE2depsproof.v | 127 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 147 insertions(+) create mode 100644 mppa_k1c/CSE2deps.v create mode 100644 mppa_k1c/CSE2depsproof.v diff --git a/mppa_k1c/CSE2deps.v b/mppa_k1c/CSE2deps.v new file mode 100644 index 00000000..8ab9242a --- /dev/null +++ b/mppa_k1c/CSE2deps.v @@ -0,0 +1,20 @@ +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. diff --git a/mppa_k1c/CSE2depsproof.v b/mppa_k1c/CSE2depsproof.v new file mode 100644 index 00000000..a3811e78 --- /dev/null +++ b/mppa_k1c/CSE2depsproof.v @@ -0,0 +1,127 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Require Import Globalenvs Values. +Require Import Linking Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import CSE2 CSE2deps. +Require Import Lia. + +Lemma ptrofs_size : + Ptrofs.wordsize = (if Archi.ptr64 then 64 else 32)%nat. +Proof. + unfold Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. + trivial. +Qed. + +Lemma ptrofs_modulus : + Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296. +Proof. + unfold Ptrofs.modulus. + rewrite ptrofs_size. + destruct Archi.ptr64; reflexivity. +Qed. + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Section MEMORY_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + Variable base : val. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Aindexed ofsw) (base :: nil) = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aindexed ofsr) (base :: nil) = Some addrr. + + Lemma load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + rewrite ptrofs_modulus in *. + simpl in *. + inv ADDRR. + inv ADDRW. + destruct base; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + all: try rewrite ptrofs_modulus in *. + all: destruct Archi.ptr64. + + all: intuition lia. + Qed. + + Theorem load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End MEMORY_WRITE. +End SOUNDNESS. + + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Lemma may_overlap_sound: + forall m m' : mem, + forall chunk addr args chunk' addr' args' v a a' rs, + (eval_addressing genv sp addr (rs ## args)) = Some a -> + (eval_addressing genv sp addr' (rs ## args')) = Some a' -> + (may_overlap chunk addr args chunk' addr' args') = false -> + (Mem.storev chunk m a v) = Some m' -> + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE. + destruct addr; destruct addr'; try discriminate. + { (* Aindexed / Aindexed *) + destruct args as [ | base [ | ]]. 1,3: discriminate. + destruct args' as [ | base' [ | ]]. 1,3: discriminate. + simpl in OVERLAP. + destruct (peq base base'). 2: discriminate. + subst base'. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. -- cgit From 51db43fa5ea3f0bfcb42f68b59df1c39842c6486 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 18:15:49 +0100 Subject: try to get it to compile --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 5566cf57..2cd40800 100644 --- a/Makefile +++ b/Makefile @@ -86,6 +86,7 @@ BACKEND=\ ValueDomain.v ValueAOp.v ValueAnalysis.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ + CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \ Unusedglob.v Unusedglobproof.v \ -- cgit From 690fa3a3969f3e1294f8b381f6b8d9c051b264d3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Mar 2020 18:27:24 +0100 Subject: Linearize: Dependencies computing to decide which sequence to put first --- backend/Linearizeaux.ml | 163 +++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 132 insertions(+), 31 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 3ef86344..58d7558b 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -140,33 +140,6 @@ let rec last_element = function | e :: [] -> e | e' :: e :: l -> last_element (e::l) -(** old version -let dfs code entrypoint = - let visited = ref (PTree.map (fun n i -> false) code) in - let rec dfs_list code = function - | [] -> [] - | node :: ln -> - let node_dfs = - if not (get_some @@ PTree.get node !visited) then begin - visited := PTree.set node true !visited; - match PTree.get node code with - | None -> failwith "No such node" - | Some bb -> [node] @ match (last_element bb) with - | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ - | Lbuiltin _ -> assert false - | Ltailcall _ | Lreturn -> [] - | Lbranch n -> dfs_list code [n] - | Lcond (_, _, ifso, ifnot) -> dfs_list code [ifnot; ifso] - | Ljumptable(_, ln) -> dfs_list code ln - end - else [] - in node_dfs @ (dfs_list code ln) - in dfs_list code [entrypoint] - -let enumerate_aux_trace f reach = dfs f.fn_code f.fn_entrypoint -*) - - let forward_sequences code entry = let visited = ref (PTree.map (fun n i -> false) code) in (* returns the list of traversed nodes, and a list of nodes to start traversing next *) @@ -273,12 +246,140 @@ let try_merge code (fs: (BinNums.positive list) list) = done; !seqs -let order_sequences fs = fs +(** Code adapted from Duplicateaux.get_loop_headers + * + * Getting loop branches with a DFS visit : + * Each node is either Unvisited, Visited, or Processed + * pre-order: node becomes Processed + * post-order: node becomes Visited + * + * If we come accross an edge to a Processed node, it's a loop! + *) +type pos = BinNums.positive + +module PP = struct + type t = pos * pos + let compare a b = + let ax, ay = a in + let bx, by = b in + let dx = compare ax bx in + if (dx == 0) then compare ay by + else dx +end + +module PPMap = Map.Make(PP) + +type vstate = Unvisited | Processed | Visited + +let get_loop_edges code entry = + let visited = ref (PTree.map (fun n i -> Unvisited) code) in + let is_loop_edge = ref PPMap.empty + in let rec dfs_visit code from = function + | [] -> () + | node :: ln -> + match (get_some @@ PTree.get node !visited) with + | Visited -> () + | Processed -> begin + let from_node = get_some from in + is_loop_edge := PPMap.add (from_node, node) true !is_loop_edge; + visited := PTree.set node Visited !visited + end + | Unvisited -> begin + visited := PTree.set node Processed !visited; + let bb = get_some @@ PTree.get node code in + let next_visits = (match (last_element bb) with + | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ + | Lbuiltin _ -> assert false + | Ltailcall _ | Lreturn -> [] + | Lbranch n -> [n] + | Lcond (_, _, ifso, ifnot) -> [ifso; ifnot] + | Ljumptable(_, ln) -> ln + ) in dfs_visit code (Some node) next_visits; + visited := PTree.set node Visited !visited; + dfs_visit code from ln + end + in begin + dfs_visit code None [entry]; + !is_loop_edge + end + +let ppmap_is_true pp ppmap = PPMap.mem pp ppmap && PPMap.find pp ppmap + +module Int = struct + type t = int + let compare x y = compare x y +end + +module ISet = Set.Make(Int) + +let construct_depmap code entry fs = + let is_loop_edge = get_loop_edges code entry in + let visited = ref (PTree.map (fun n i -> false) code) in + let depmap = Array.map (fun e -> ISet.empty) fs in + let find_index_of_node n = + let index = ref 0 in + begin + Array.iteri (fun i s -> + match List.find_opt (fun e -> e == n) s with + | Some _ -> index := i + | None -> () + ) fs; + !index + end + in let rec dfs_visit code = function + | [] -> () + | node :: ln -> + match (get_some @@ PTree.get node !visited) with + | true -> () + | false -> begin + visited := PTree.set node true !visited; + let bb = get_some @@ PTree.get node code in + let next_visits = + match (last_element bb) with + | Ltailcall _ | Lreturn -> [] + | Lbranch n -> [n] + | Lcond (_, _, ifso, ifnot) -> begin + (if not (ppmap_is_true (node, ifso) is_loop_edge) then + let in_index_fs = find_index_of_node node in + let out_index_fs = find_index_of_node ifso in + depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs) + else + ()); + [ifso; ifnot] + end + | Ljumptable(_, ln) -> begin + let in_index_fs = find_index_of_node node in + List.iter (fun n -> + if not (ppmap_is_true (node, n) is_loop_edge) then + let out_index_fs = find_index_of_node n in + depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs) + else + () + ) ln; + ln + end + (* end of bblocks should not be another value than one of the above *) + | _ -> failwith "last_element gave an invalid output" + in dfs_visit code next_visits + end + in begin + dfs_visit code [entry]; + depmap + end + +let order_sequences code entry fs = + let fs_a = Array.of_list fs in + let depmap = construct_depmap code entry fs_a in + Array.iter (fun _ -> ()) depmap; + (* algo *) + fs let enumerate_aux_trace f reach = - let fs = forward_sequences f.fn_code f.fn_entrypoint - in let ofs = order_sequences fs - in List.flatten ofs + let code = f.fn_code in + let entry = f.fn_entrypoint in + let fs = forward_sequences code entry in + let ofs = order_sequences code entry fs in + List.flatten ofs let enumerate_aux f reach = if !Clflags.option_ftracelinearize then enumerate_aux_trace f reach -- cgit From 86d593820f481b893c7ca00d39b2ac73a6e73aa0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 19:01:25 +0100 Subject: same version as in dm-cse2 --- Makefile | 1 + backend/CSE2proof.v | 48 ++++++++++++++++++++++++------------------------ 2 files changed, 25 insertions(+), 24 deletions(-) diff --git a/Makefile b/Makefile index 5566cf57..2cd40800 100644 --- a/Makefile +++ b/Makefile @@ -86,6 +86,7 @@ BACKEND=\ ValueDomain.v ValueAOp.v ValueAnalysis.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ + CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \ Unusedglob.v Unusedglobproof.v \ diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 7e1dd430..9f55846d 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -55,9 +55,9 @@ Definition sem_sym_val sym rs (v : option val) : Prop := match eval_addressing genv sp addr rs##args with | Some a => match Mem.loadv chunk m a with | Some dat => v = Some dat - | None => v = None \/ v = Some (default_notrap_load_value chunk) + | None => v = None \/ v = Some Vundef end - | None => v = None \/ v = Some (default_notrap_load_value chunk) + | None => v = None \/ v = Some Vundef end end. @@ -404,9 +404,9 @@ Lemma find_load_sound : match eval_addressing genv sp addr rs##args with | Some a => match Mem.loadv chunk m a with | Some dat => rs#src = dat - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end. Proof. intros until rs. @@ -421,9 +421,9 @@ Proof. match eval_addressing genv sp addr rs##args with | Some a => match Mem.loadv chunk m a with | Some dat => rs#src = dat - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end end -> fold_left @@ -433,9 +433,9 @@ Proof. match eval_addressing genv sp addr rs##args with | Some a => match Mem.loadv chunk m a with | Some dat => rs#src = dat - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end) as REC. { @@ -523,7 +523,7 @@ Lemma find_load_notrap1_sound' : sem_rel rel rs -> find_load rel chunk addr args = Some src -> eval_addressing genv sp addr rs##args = None -> - rs # src = (default_notrap_load_value chunk). + rs # src = Vundef. Proof. intros until rs. intros REL FINDLOAD ADDR. pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z. @@ -543,7 +543,7 @@ Lemma find_load_notrap2_sound' : find_load rel chunk addr args = Some src -> eval_addressing genv sp addr rs##args = Some a -> Mem.loadv chunk m a = None -> - rs # src = (default_notrap_load_value chunk). + rs # src = Vundef. Proof. intros until a. intros REL FINDLOAD ADDR LOAD. pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z. @@ -689,11 +689,11 @@ Lemma load2_notrap1_sound : sem_rel rel rs -> not (In dst args) -> eval_addressing genv sp addr (rs ## args) = None -> - sem_rel (load2 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). + sem_rel (load2 chunk addr dst args rel) (rs # dst <- Vundef). Proof. intros until rs. intros REL NOT_IN ADDR x. - pose proof (kill_reg_sound rel dst rs (default_notrap_load_value chunk) REL x) as KILL. + pose proof (kill_reg_sound rel dst rs Vundef REL x) as KILL. unfold load2. destruct (peq x dst). { @@ -726,11 +726,11 @@ Lemma load2_notrap2_sound : not (In dst args) -> eval_addressing genv sp addr (rs ## args) = Some a -> Mem.loadv chunk m a = None -> - sem_rel (load2 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). + sem_rel (load2 chunk addr dst args rel) (rs # dst <- Vundef). Proof. intros until a. intros REL NOT_IN ADDR LOAD x. - pose proof (kill_reg_sound rel dst rs (default_notrap_load_value chunk) REL x) as KILL. + pose proof (kill_reg_sound rel dst rs Vundef REL x) as KILL. unfold load2. destruct (peq x dst). { @@ -784,7 +784,7 @@ Lemma load1_notrap1_sound : forall rs : regset, sem_rel rel rs -> eval_addressing genv sp addr (rs ## args) = None -> - sem_rel (load1 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). + sem_rel (load1 chunk addr dst args rel) (rs # dst <- Vundef). Proof. intros until rs. intros REL ADDR LOAD. @@ -807,7 +807,7 @@ Lemma load1_notrap2_sound : sem_rel rel rs -> eval_addressing genv sp addr (rs ## args) = Some a -> Mem.loadv chunk m a = None -> - sem_rel (load1 chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). + sem_rel (load1 chunk addr dst args rel) (rs # dst <- Vundef). Proof. intros until a. intros REL ADDR LOAD. @@ -841,9 +841,9 @@ Proof. assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with | Some a => match Mem.loadv chunk m a with | Some dat => rs#src = dat - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end) as FIND_LOAD. { apply (find_load_sound rel); trivial. @@ -869,7 +869,7 @@ Lemma load_notrap1_sound : forall rs : regset, sem_rel rel rs -> eval_addressing genv sp addr (rs ## args) = None -> - sem_rel (load chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). + sem_rel (load chunk addr dst args rel) (rs # dst <- Vundef). Proof. intros until rs. intros REL ADDR. @@ -879,9 +879,9 @@ Proof. assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with | Some a => match Mem.loadv chunk m a with | Some dat => rs#src = dat - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end) as FIND_LOAD. { apply (find_load_sound rel); trivial. @@ -906,7 +906,7 @@ Lemma load_notrap2_sound : sem_rel rel rs -> eval_addressing genv sp addr (rs ## args) = Some a -> Mem.loadv chunk m a = None -> - sem_rel (load chunk addr dst args rel) (rs # dst <- (default_notrap_load_value chunk)). + sem_rel (load chunk addr dst args rel) (rs # dst <- Vundef). Proof. intros until a. intros REL ADDR. @@ -916,9 +916,9 @@ Proof. assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with | Some a => match Mem.loadv chunk m a with | Some dat => rs#src = dat - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end - | None => rs#src = default_notrap_load_value chunk + | None => rs#src = Vundef end) as FIND_LOAD. { apply (find_load_sound rel); trivial. -- cgit From 668912983cd68f5f233bfd3af280f911a8522a84 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 19:18:44 +0100 Subject: fix for ppc --- powerpc/CSE2depsproof.v | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/powerpc/CSE2depsproof.v b/powerpc/CSE2depsproof.v index a047b02a..fdded9b6 100644 --- a/powerpc/CSE2depsproof.v +++ b/powerpc/CSE2depsproof.v @@ -24,6 +24,14 @@ Proof. destruct Archi.ptr64; reflexivity. Qed. +Lemma ptrofs_max_unsigned : + Ptrofs.max_unsigned = if Archi.ptr64 then 18446744073709551615 else 4294967295. +Proof. + unfold Ptrofs.max_unsigned. + rewrite ptrofs_modulus. + destruct Archi.ptr64; reflexivity. +Qed. + Section SOUNDNESS. Variable F V : Type. Variable genv: Genv.t F V. @@ -38,17 +46,17 @@ Section MEMORY_WRITE. Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. Section INDEXED_AWAY. - Variable ofsw ofsr : ptrofs. + Variable ofsw ofsr : int. 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, + forall RANGEW : 0 <= Int.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Int.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Int.unsigned ofsw + size_chunk chunkw <= Int.unsigned ofsr + \/ Int.unsigned ofsr + size_chunk chunkr <= Int.unsigned ofsw, Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intros. @@ -66,19 +74,19 @@ Section MEMORY_WRITE. exact STORE. right. - all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsr)) as [OFSR | OFSR]; rewrite OFSR). - all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsw)) as [OFSW | OFSW]; rewrite OFSW). - - all: try rewrite ptrofs_modulus in *. - - all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia). - all: intuition lia. + all: unfold Ptrofs.of_int. + + all: repeat rewrite Ptrofs.unsigned_repr by (unfold Ptrofs.max_unsigned; rewrite ptrofs_modulus; destruct Archi.ptr64; lia). + all: repeat rewrite ptrofs_modulus. + all: destruct Archi.ptr64; intuition lia. Qed. Theorem load_store_away : - can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + can_swap_accesses_ofs (Int.unsigned ofsr) chunkr (Int.unsigned ofsw) chunkw = true -> Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. Proof. intro SWAP. @@ -117,7 +125,7 @@ Proof. 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. + destruct (can_swap_accesses_ofs (Int.unsigned i0) chunk' (Int.unsigned i) chunk) eqn:SWAP. 2: discriminate. simpl in *. eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. -- cgit From 039b532ae972292ec2f726505422afd49569b738 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 4 Mar 2020 18:18:40 +0100 Subject: Include typedef name in error message (#228) In case of redefinition of a typedef name with a different type. --- cparser/Elab.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index f60e15a3..9e17cb7e 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -2428,8 +2428,8 @@ let enter_typedef loc env sto (s, ty, init) = env end else begin - error loc "typedef redefinition with different types (%a vs %a)" - (print_typ env) ty (print_typ env) ty'; + error loc "redefinition of typedef '%s' with different type (%a vs %a)" + s (print_typ env) ty (print_typ env) ty'; env end | _ -> -- cgit From 5eb64cdae7deeaef774fdead6f3ce6e4108a3256 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 6 Mar 2020 15:59:44 +0100 Subject: [UNTESTED] Sequence ordering --- backend/Linearizeaux.ml | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 58d7558b..ce518dbb 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -370,9 +370,33 @@ let construct_depmap code entry fs = let order_sequences code entry fs = let fs_a = Array.of_list fs in let depmap = construct_depmap code entry fs_a in - Array.iter (fun _ -> ()) depmap; - (* algo *) - fs + let fs_evaluated = Array.map (fun e -> false) fs_a in + let ordered_fs = ref [] in + let evaluate s_id = + begin + assert (not fs_evaluated.(s_id)); + ordered_fs := fs_a.(s_id) :: !ordered_fs; + fs_evaluated.(s_id) <- true; + Array.iteri (fun i deps -> + depmap.(i) <- ISet.remove s_id deps + ) depmap + end + in let select_next () = + let selected_id = ref (-1) in + begin + Array.iteri (fun i deps -> + if !selected_id == -1 && deps == ISet.empty && not fs_evaluated.(i) + then selected_id := i + ) depmap; + !selected_id + end + in begin + while List.length !ordered_fs != List.length fs do + let next_id = select_next () in + evaluate next_id + done; + !ordered_fs + end let enumerate_aux_trace f reach = let code = f.fn_code in -- cgit From 8300321b348a6b416a8e0498ecebf944697d0641 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 6 Mar 2020 16:20:22 +0100 Subject: Adding debug info in Linearizeaux --- backend/Linearizeaux.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index ce518dbb..b609b57a 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -367,6 +367,16 @@ let construct_depmap code entry fs = depmap end +let print_sequence s = + Printf.printf "["; + List.iter (fun n -> Printf.printf "%d, " (P.to_int n)) s; + Printf.printf "]\n" + +let print_ssequence ofs = + Printf.printf "["; + List.iter (fun s -> print_sequence s) ofs; + Printf.printf "]\n" + let order_sequences code entry fs = let fs_a = Array.of_list fs in let depmap = construct_depmap code entry fs_a in @@ -391,10 +401,12 @@ let order_sequences code entry fs = !selected_id end in begin + print_ssequence fs; while List.length !ordered_fs != List.length fs do let next_id = select_next () in evaluate next_id done; + print_ssequence !ordered_fs; !ordered_fs end -- cgit From 7b85e3b00e500c5d65cf2df1adeae8ecd7d3e88d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 7 Mar 2020 06:50:50 +0100 Subject: removing warnings on hints in core --- mppa_k1c/Asmblockdeps.v | 6 +++--- mppa_k1c/Asmblockgenproof1.v | 4 ++-- mppa_k1c/PostpassSchedulingproof.v | 2 +- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 2 +- mppa_k1c/abstractbb/ImpSimuTest.v | 14 +++++++------- mppa_k1c/abstractbb/Impure/ImpHCons.v | 4 ++-- mppa_k1c/abstractbb/Parallelizability.v | 8 ++++---- mppa_k1c/abstractbb/SeqSimuTheory.v | 11 ++++------- mppa_k1c/lib/Asmblockgenproof0.v | 4 ++-- mppa_k1c/lib/ForwardSimulationBlock.v | 6 +++--- mppa_k1c/lib/Machblockgenproof.v | 20 ++++++++++---------- 11 files changed, 39 insertions(+), 42 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 02f9141b..bc9f2584 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1005,7 +1005,7 @@ Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: Proof. (* a little tactic to automate reasoning on preg_eq *) -Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. +Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. Local Ltac preg_eq_discr r rd := destruct (preg_eq r rd); try (subst r; rewrite assign_eq, Pregmap.gss; auto); rewrite (assign_diff _ (#rd) (#r) _); auto; @@ -1053,7 +1053,7 @@ Local Ltac preg_eq_discr r rd := preg_eq_discr r rd0. } (* Load Octuple word *) - + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. + + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. unfold parexec_load_o_offset. destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]; destruct Ge; simpl. rewrite H0, H. @@ -1423,7 +1423,7 @@ Section SECT_BBLOCK_EQUIV. Variable Ge: genv. -Local Hint Resolve trans_state_match. +Local Hint Resolve trans_state_match: core. Lemma bblock_simu_reduce: forall p1 p2 ge fn, diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index ecb4629b..d3c2008f 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -859,7 +859,7 @@ Proof. destruct cmp; discriminate. Qed. -Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct. +Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct: core. Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m' tbb, @@ -1163,7 +1163,7 @@ Proof. split; intros; Simpl. Qed. -Local Hint Resolve Val_cmpu_correct Val_cmplu_correct. +Local Hint Resolve Val_cmpu_correct Val_cmplu_correct: core. Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index fbb06c9b..3b123c75 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -567,7 +567,7 @@ Proof. unfold builtin_alone in H0. erewrite H0; eauto. Qed. -Local Hint Resolve verified_schedule_nob_checks_alls_bundles. +Local Hint Resolve verified_schedule_nob_checks_alls_bundles: core. Lemma verified_schedule_checks_alls_bundles bb lb bundle: verified_schedule bb = OK lb -> diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 5c94d435..cf46072f 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -403,7 +403,7 @@ Proof. * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto. * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto. Qed. -Local Hint Resolve app_fail_allvalid_correct. +Local Hint Resolve app_fail_allvalid_correct: core. Lemma app_fail_correct l pt t1 t2: match_pt t1 pt -> diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index ea55b735..7a77ec15 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -304,12 +304,12 @@ Proof. rewrite <- EQT; eauto. + exploit smem_valid_set_decompose_1; eauto. - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl. - Local Hint Resolve smem_valid_set_decompose_1. + Local Hint Resolve smem_valid_set_decompose_1: core. intros; case (R.eq_dec x x0). + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. + intros; rewrite !Dict.set_spec_diff; simpl; eauto. Qed. -Local Hint Resolve naive_set_correct. +Local Hint Resolve naive_set_correct: core. Definition equiv_hsmem ge (hd1 hd2: hsmem) := (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m) @@ -523,7 +523,7 @@ Lemma hinst_smem_correct i: forall hd hod, WHEN hinst_smem i hd hod ~> hd' THEN forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, smem_valid ge d m -> smem_valid ge od m) -> smem_model ge (inst_smem i d od) hd'. Proof. - Local Hint Resolve smem_valid_set_proof. + Local Hint Resolve smem_valid_set_proof: core. induction i; simpl; wlp_simplify; eauto 15 with wlp. Qed. Global Opaque hinst_smem. @@ -563,7 +563,7 @@ Definition bblock_hsmem: bblock -> ?? hsmem Lemma bblock_hsmem_correct p: WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. - Local Hint Resolve hsmem_empty_correct. + Local Hint Resolve hsmem_empty_correct: core. wlp_simplify. Qed. Global Opaque bblock_hsmem. @@ -775,7 +775,7 @@ Proof. intro H; erewrite <- list_term_eval_set_hid; rewrite H. apply list_term_eval_set_hid. Qed. -Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv. +Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv: core. Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := DO log <~ count_logger ();; @@ -802,7 +802,7 @@ Obligation 2. wlp_simplify. Qed. -Local Hint Resolve g_bblock_simu_test_correct. +Local Hint Resolve g_bblock_simu_test_correct: core. Theorem bblock_simu_test_correct p1 p2: WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. @@ -1123,7 +1123,7 @@ Definition get {A} (d:t A) (x:R.t): option A Definition set {A} (d:t A) (x:R.t) (v:A): t A := PositiveMap.add x v d. -Local Hint Unfold PositiveMap.E.eq. +Local Hint Unfold PositiveMap.E.eq: core. Lemma set_spec_eq A d x (v: A): get (set d x v) x = Some v. diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v index d8002375..637116cc 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -95,7 +95,7 @@ Proof. wlp_simplify. Qed. Global Opaque assert_list_incl. -Hint Resolve assert_list_incl_correct. +Hint Resolve assert_list_incl_correct: wlp. End Sets. @@ -165,7 +165,7 @@ Lemma hConsV_correct A (hasheq: A -> A -> ?? bool): (forall x y, WHEN hasheq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data). Proof. - Local Hint Resolve f_equal2. + Local Hint Resolve f_equal2: core. wlp_simplify. exploit H; eauto. + wlp_simplify. diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index 22809095..30904b5d 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -332,7 +332,7 @@ Fixpoint bblock_wframe(p:bblock): list R.t := | i::p' => (inst_wframe i)++(bblock_wframe p') end. -Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm. +Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm: core. Lemma bblock_wframe_Permutation p p': Permutation p p' -> Permutation (bblock_wframe p) (bblock_wframe p'). @@ -620,7 +620,7 @@ Include ParallelizablityChecking L. Section PARALLEL2. Variable ge: genv. -Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame. +Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame: core. (** Now, refinement of each operation toward parallelizable *) @@ -659,14 +659,14 @@ Fixpoint inst_sframe (i: inst): S.t := | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (inst_sframe i')) end. -Local Hint Resolve exp_sframe_correct. +Local Hint Resolve exp_sframe_correct: core. Lemma inst_sframe_correct i: S.match_frame (inst_sframe i) (inst_frame i). Proof. induction i as [|[y e] i']; simpl; auto. Qed. -Local Hint Resolve inst_wsframe_correct inst_sframe_correct. +Local Hint Resolve inst_wsframe_correct inst_sframe_correct: core. Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool := match p with diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v index 649dd083..e234883f 100644 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -102,9 +102,6 @@ Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := let d':=inst_smem i d d in bblock_smem_rec p' d' end. -(* -Local Hint Resolve smem_eval_empty. -*) Definition bblock_smem: bblock -> smem := fun p => bblock_smem_rec p smem_empty. @@ -124,7 +121,7 @@ Proof. intros d a H; eapply inst_smem_pre_monotonic; eauto. Qed. -Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic. +Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic: core. Lemma term_eval_exp e (od:smem) m0 old: (forall x, term_eval ge (od x) m0 = Some (old x)) -> @@ -185,7 +182,7 @@ Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x). Proof. - Local Hint Resolve inst_smem_Some_correct1. + Local Hint Resolve inst_smem_Some_correct1: core. induction p as [ | i p]; simpl; intros m1 m2 d H. - inversion_clear H; eauto. - intros H0 x0. @@ -299,7 +296,7 @@ Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem), (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> pre (bblock_smem_rec p d) ge m0. Proof. - Local Hint Resolve inst_valid. + Local Hint Resolve inst_valid: core. induction p as [ | i p]; simpl; intros m1 d H; auto. intros H0 H1. destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. @@ -326,7 +323,7 @@ Theorem bblock_smem_simu p1 p2: smem_simu (bblock_smem p1) (bblock_smem p2) -> bblock_simu ge p1 p2. Proof. - Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. + Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1: core. intros (INCL & EQUIV) m DONTFAIL; unfold smem_valid in * |-. destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. assert (X: forall x, term_eval ge (bblock_smem p1 x) m = Some (m1 x)); eauto. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 940c6563..58455ada 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -414,7 +414,7 @@ Proof. Qed. -Local Hint Resolve code_tail_0 code_tail_S. +Local Hint Resolve code_tail_0 code_tail_S: core. Lemma code_tail_next: forall fn ofs c0, @@ -458,7 +458,7 @@ Proof. omega. Qed. -Local Hint Resolve code_tail_next. +Local Hint Resolve code_tail_next: core. Lemma code_tail_next_int: forall fn ofs bi c, diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v index 39dd2234..224eda0a 100644 --- a/mppa_k1c/lib/ForwardSimulationBlock.v +++ b/mppa_k1c/lib/ForwardSimulationBlock.v @@ -21,7 +21,7 @@ Section starN_lemma. Variable L: semantics. -Local Hint Resolve starN_refl starN_step Eapp_assoc. +Local Hint Resolve starN_refl starN_step Eapp_assoc: core. Lemma starN_split n s t s': starN (step L) (globalenv L) n s t s' -> @@ -93,7 +93,7 @@ Hypothesis simu_end_block: (** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *) -Local Hint Resolve starN_refl starN_step. +Local Hint Resolve starN_refl starN_step: core. Definition follows_in_block (head current: state L1): Prop := dist_end_block head >= dist_end_block current @@ -164,7 +164,7 @@ Inductive is_well_memorized (s s': memostate): Prop := memorized s' = None -> is_well_memorized s s'. -Local Hint Resolve StartBloc MidBloc ExitBloc. +Local Hint Resolve StartBloc MidBloc ExitBloc: core. Definition memoL1 := {| state := memostate; diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 91be5e2e..0de2df52 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -72,7 +72,7 @@ Proof. apply match_states_trans_state. Qed. -Local Hint Resolve match_states_trans_state. +Local Hint Resolve match_states_trans_state: core. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. @@ -284,7 +284,7 @@ Proof. Qed. Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated - parent_sp_preserved. + parent_sp_preserved: core. Definition dist_end_block_code (c: Mach.code) := @@ -299,8 +299,8 @@ Definition dist_end_block (s: Mach.state): nat := | _ => 0 end. -Local Hint Resolve exec_nil_body exec_cons_body. -Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore. +Local Hint Resolve exec_nil_body exec_cons_body: core. +Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore: core. Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. Proof. @@ -336,7 +336,7 @@ Proof. omega. Qed. -Local Hint Resolve dist_end_block_code_simu_mid_block. +Local Hint Resolve dist_end_block_code_simu_mid_block: core. Lemma size_nonzero c b bl: @@ -392,8 +392,8 @@ destruct i; congruence. Qed. -Local Hint Resolve Mlabel_is_not_cfi. -Local Hint Resolve MBbasic_is_not_cfi. +Local Hint Resolve Mlabel_is_not_cfi: core. +Local Hint Resolve MBbasic_is_not_cfi: core. Lemma add_to_new_block_is_label i: header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. @@ -408,7 +408,7 @@ Proof. + unfold cfi_bblock in H; simpl in H; congruence. Qed. -Local Hint Resolve Mlabel_is_not_basic. +Local Hint Resolve Mlabel_is_not_basic: core. Lemma trans_code_decompose c: forall b bl, is_trans_code c (b::bl) -> @@ -510,8 +510,8 @@ Proof. rewrite Hs2, Hb2; eauto. Qed. -Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit. -Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same. +Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit: core. +Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same: core. Lemma match_states_concat_trans_code st f sp c rs m h: -- cgit From 1df2fadbf5ab0687d2aac52f3a83bbe071c25139 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 9 Mar 2020 08:07:04 +0100 Subject: removing some coqc 8.10 warnings --- backend/Duplicateproof.v | 2 +- mppa_k1c/lib/Machblockgen.v | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index a8e9b16b..466b4b75 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -378,7 +378,7 @@ Theorem step_simulation: step tge s2 t s2' /\ match_states s1' s2'. Proof. - Local Hint Resolve transf_fundef_correct. + Local Hint Resolve transf_fundef_correct: core. induction 1; intros; inv MS. (* Inop *) - eapply dupmap_correct in DUPLIC; eauto. diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index a65b218f..2ba42814 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -105,7 +105,7 @@ Inductive is_end_block: Machblock_inst -> code -> Prop := | End_basic bi bh bl: header bh <> nil -> is_end_block (MB_basic bi) (bh::bl) | End_cfi cfi bl: bl <> nil -> is_end_block (MB_cfi cfi) bl. -Local Hint Resolve End_empty End_basic End_cfi. +Local Hint Resolve End_empty End_basic End_cfi: core. Inductive is_trans_code: Mach.code -> code -> Prop := | Tr_nil: is_trans_code nil nil @@ -123,7 +123,7 @@ Inductive is_trans_code: Mach.code -> code -> Prop := header bh = nil -> is_trans_code (i::c) (add_basic bi bh::bl). -Local Hint Resolve Tr_nil Tr_end_block. +Local Hint Resolve Tr_nil Tr_end_block: core. Lemma add_to_code_is_trans_code i c bl: is_trans_code c bl -> @@ -145,7 +145,7 @@ Proof. rewrite <- Heqti. eapply End_cfi. congruence. Qed. -Local Hint Resolve add_to_code_is_trans_code. +Local Hint Resolve add_to_code_is_trans_code: core. Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, is_trans_code c2 mbi -> @@ -185,7 +185,7 @@ Proof. exists mbi1. split; congruence. Qed. -Local Hint Resolve trans_code_is_trans_code. +Local Hint Resolve trans_code_is_trans_code: core. Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). Proof. -- cgit From f2a5f59fca7be2c9b31a18e31c66cd21819fce56 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 9 Mar 2020 08:25:59 +0100 Subject: removing more coq8.10 warnings --- mppa_k1c/Asmblockdeps.v | 2 +- mppa_k1c/Asmblockgen.v | 2 ++ mppa_k1c/Asmblockgenproof1.v | 2 ++ mppa_k1c/Asmvliw.v | 6 +++++- 4 files changed, 10 insertions(+), 2 deletions(-) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index bc9f2584..01eda623 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -339,7 +339,7 @@ Proof. } destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence. Qed. - + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 50637723..36269954 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -28,6 +28,8 @@ Require Import Chunks. Local Open Scope string_scope. Local Open Scope error_monad_scope. +Import PArithCoercions. + (** The code generation functions take advantage of several characteristics of the [Mach] code generated by earlier passes of the compiler, mostly that argument and result registers are of the correct diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index d3c2008f..5b44ddaa 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -23,6 +23,8 @@ Require Import Op Locations Machblock Conventions. Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. Require Import Chunks. +Import PArithCoercions. + (** Decomposition of integer constants. *) Lemma make_immed32_sound: diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e042d95a..946007c1 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -555,6 +555,8 @@ Inductive ar_instruction : Type := | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) . +Module PArithCoercions. + Coercion PArithR: arith_name_r >-> Funclass. Coercion PArithRR: arith_name_rr >-> Funclass. Coercion PArithRI32: arith_name_ri32 >-> Funclass. @@ -569,6 +571,8 @@ Coercion PArithARR: arith_name_arr >-> Funclass. Coercion PArithARRI32: arith_name_arri32 >-> Funclass. Coercion PArithARRI64: arith_name_arri64 >-> Funclass. +End PArithCoercions. + Inductive basic : Type := | PArith (i: ar_instruction) | PLoad (i: ld_instruction) @@ -1709,7 +1713,7 @@ Proof. Qed. -Local Hint Resolve parexec_bblock_write_in_order. +Local Hint Resolve parexec_bblock_write_in_order: core. Lemma det_parexec_write_in_order f b rs m rs' m': det_parexec f b rs m rs' m' -> parexec_wio_bblock f b rs m = Next rs' m'. -- cgit From 7794bebc14750c5d8116f54cabe143231ef60308 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Mar 2020 11:27:38 +0100 Subject: Linearizeaux: Fixed bug where the output list was in reverse order --- backend/Linearizeaux.ml | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index b609b57a..7aed5936 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -312,6 +312,18 @@ end module ISet = Set.Make(Int) +let print_iset s = begin + Printf.printf "{"; + ISet.iter (fun e -> Printf.printf "%d, " e) s; + Printf.printf "}" +end + +let print_depmap dm = begin + Printf.printf "[|"; + Array.iter (fun s -> print_iset s; Printf.printf ", ") dm; + Printf.printf "|]\n" +end + let construct_depmap code entry fs = let is_loop_edge = get_loop_edges code entry in let visited = ref (PTree.map (fun n i -> false) code) in @@ -395,19 +407,23 @@ let order_sequences code entry fs = let selected_id = ref (-1) in begin Array.iteri (fun i deps -> - if !selected_id == -1 && deps == ISet.empty && not fs_evaluated.(i) - then selected_id := i + begin + (* Printf.printf "Deps: "; print_iset deps; Printf.printf "\n"; *) + if !selected_id == -1 && deps == ISet.empty && not fs_evaluated.(i) + then selected_id := i + end ) depmap; !selected_id end in begin + (* Printf.printf "depmap: "; print_depmap depmap; *) print_ssequence fs; while List.length !ordered_fs != List.length fs do let next_id = select_next () in evaluate next_id done; - print_ssequence !ordered_fs; - !ordered_fs + (* print_ssequence (List.rev (!ordered_fs)); *) + List.rev (!ordered_fs) end let enumerate_aux_trace f reach = -- cgit From 510923fcea8ededcd71fc81ae0fb1981bf8b9223 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 12:43:36 +0100 Subject: cycles.h for ARMv7 --- test/monniaux/cycles.h | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h index 21541145..4a87299b 100644 --- a/test/monniaux/cycles.h +++ b/test/monniaux/cycles.h @@ -38,6 +38,13 @@ static inline cycle_t get_cycle(void) { return cycles; } +#elif defined (__ARM_ARCH) && (__ARM_ARCH >= 6) +static inline cycle_t get_cycle(void) { + cycle_t cycles; + __asm__ volatile ("mrc p15, 0, %0, c9, c13, 0":"=r" (cycles)); + return cycles; +} + #else static inline cycle_t get_cycle(void) { return 0; } #endif -- cgit From 611d7bec0f35fa5fb017ecf36a17f8967425548e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Mar 2020 14:11:48 +0100 Subject: Removing prints in Duplicateaux.ml --- backend/Duplicateaux.ml | 85 ++++++++++++------------------------------------- 1 file changed, 20 insertions(+), 65 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index d0b7129e..e2b5647b 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -95,52 +95,6 @@ let print_intset s = Printf.printf "}" end -(* FIXME - dominators not working well because the order of dataflow update isn't right *) - (* -let get_dominators code entrypoint = - let bfs_order = bfs code entrypoint - and predecessors = get_predecessors_rtl code - in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code) - in begin - Printf.printf "BFS: "; - print_intlist bfs_order; - Printf.printf "\n"; - List.iter (fun n -> - let preds = get_some @@ PTree.get n predecessors - and single = PSet.singleton n - in match preds with - | [] -> doms := PTree.set n single !doms - | p::lp -> - let set_p = get_some @@ PTree.get p !doms - and set_lp = List.map (fun p -> get_some @@ PTree.get p !doms) lp - in let inter = List.fold_left PSet.inter set_p set_lp - in let union = PSet.union inter single - in begin - Printf.printf "----------------------------------------\n"; - Printf.printf "n = %d\n" (P.to_int n); - Printf.printf "set_p = "; print_intset set_p; Printf.printf "\n"; - Printf.printf "set_lp = ["; List.iter (fun s -> print_intset s; Printf.printf ", ") set_lp; Printf.printf "]\n"; - Printf.printf "=> inter = "; print_intset inter; Printf.printf "\n"; - Printf.printf "=> union = "; print_intset union; Printf.printf "\n"; - doms := PTree.set n union !doms - end - ) bfs_order; - !doms - end -*) - -let print_dominators dominators = - let domlist = PTree.elements dominators - in begin - Printf.printf "{\n"; - List.iter (fun (n, doms) -> - Printf.printf "\t"; - Printf.printf "%d:" (P.to_int n); - print_intset doms; - Printf.printf "\n" - ) domlist - end - type vstate = Unvisited | Processed | Visited (** Getting loop branches with a DFS visit : @@ -253,30 +207,31 @@ let get_directions code entrypoint = and is_loop_header = get_loop_headers code entrypoint and directions = ref (PTree.map (fun n i -> false) code) (* false <=> fallthru *) in begin - Printf.printf "Loop headers: "; - ptree_printbool is_loop_header; - Printf.printf "\n"; + (* Printf.printf "Loop headers: "; *) + (* ptree_printbool is_loop_header; *) + (* Printf.printf "\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); + (* Printf.printf "Analyzing %d.." (P.to_int n); *) let preferred = ref false in (try - Printf.printf " call.."; + (* Printf.printf " call.."; *) do_call_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf " opcode.."; + (* Printf.printf " opcode.."; *) do_opcode_heuristic code cond ifso ifnot preferred; - Printf.printf " return.."; + (* Printf.printf " return.."; *) do_return_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf " store.."; + (* Printf.printf " store.."; *) do_store_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf " loop.."; + (* Printf.printf " loop.."; *) do_loop_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf "Random choice for %d\n" (P.to_int n); + (* Printf.printf "Random choice for %d\n" (P.to_int n); *) preferred := Random.bool () - with HeuristicSucceeded | DuplicateOpcodeHeuristic.HeuristicSucceeded - -> Printf.printf " %s\n" (match !preferred with true -> "BRANCH" - | false -> "FALLTHROUGH") + with HeuristicSucceeded | DuplicateOpcodeHeuristic.HeuristicSucceeded -> begin + (* Printf.printf " %s\n" (match !preferred with true -> "BRANCH" | false -> "FALLTHROUGH"); *) + () + end ); directions := PTree.set n !preferred !directions | _ -> () ) bfs_order; @@ -306,9 +261,9 @@ let rec to_ttl_code_rec directions = function let to_ttl_code code entrypoint = let directions = get_directions code entrypoint in begin - Printf.printf "Ifso directions: "; + (* Printf.printf "Ifso directions: "; ptree_printbool directions; - Printf.printf "\n"; + Printf.printf "\n"; *) Random.init(0); (* using same seed to make it deterministic *) to_ttl_code_rec directions (PTree.elements code) end @@ -423,7 +378,7 @@ let select_traces code entrypoint = end end done; - Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; + (* Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; *) !traces end @@ -471,7 +426,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 -> @@ -548,7 +503,7 @@ let rec invert_iconds_trace code = function | Icond (c, lr, ifso, ifnot) -> assert (n' == ifso || n' == ifnot); if (n' == ifso) then ( - Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); + (* Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); *) PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso)) code ) else code | _ -> code @@ -568,5 +523,5 @@ let duplicate_aux f = let traces = select_traces (to_ttl_code code entrypoint) entrypoint in let icond_code = invert_iconds code traces in let preds = get_predecessors_rtl icond_code in - let (new_code, pTreeId) = (print_traces traces; superblockify_traces icond_code preds traces) in + let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in ((new_code, f.fn_entrypoint), pTreeId) -- cgit From 7c403eb8d50a0292c741b25ff967d2a170637258 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 14:27:41 +0100 Subject: cycles for aarch64 --- test/monniaux/cycles.h | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h index 4a87299b..aed9941a 100644 --- a/test/monniaux/cycles.h +++ b/test/monniaux/cycles.h @@ -1,5 +1,6 @@ #include #include + typedef unsigned long cycle_t; #ifdef MAX_MEASURES @@ -39,12 +40,27 @@ static inline cycle_t get_cycle(void) { } #elif defined (__ARM_ARCH) && (__ARM_ARCH >= 6) +#if (__ARM_ARCH < 8) +/* need this kernel module +https://github.com/zertyz/MTL/tree/master/cpp/time/kernel/arm */ static inline cycle_t get_cycle(void) { cycle_t cycles; __asm__ volatile ("mrc p15, 0, %0, c9, c13, 0":"=r" (cycles)); return cycles; } +#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; + __asm__ volatile("mrs %0, pmccntr_el0" : "=r"(val)); + return val; +} +#endif #else static inline cycle_t get_cycle(void) { return 0; } #endif -- cgit From 4226a49dccaafe0ecd4b591eaab932679712d58b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Mar 2020 14:44:35 +0100 Subject: Duplicate: getting rid of the annoying exception-based code --- backend/Duplicateaux.ml | 75 ++++++++++++++---------------------- mppa_k1c/DuplicateOpcodeHeuristic.ml | 9 +---- 2 files changed, 31 insertions(+), 53 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index e2b5647b..05b8ddb8 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -160,47 +160,37 @@ let rec look_ahead code node is_loop_header predicate = else look_ahead code n is_loop_header predicate ) -exception HeuristicSucceeded - -let do_call_heuristic code ifso ifnot is_loop_header preferred = +let do_call_heuristic code cond ifso ifnot is_loop_header = let predicate n = (function | Icall _ -> true | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else () + in if (look_ahead code ifso is_loop_header predicate) then Some false + else if (look_ahead code ifnot is_loop_header predicate) then Some true + else None -let do_opcode_heuristic code cond ifso ifnot preferred = DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot preferred +let do_opcode_heuristic code cond ifso ifnot is_loop_header = DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot is_loop_header -let do_return_heuristic code ifso ifnot is_loop_header preferred = +let do_return_heuristic code cond ifso ifnot is_loop_header = let predicate n = (function | Ireturn _ -> true | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else () + in if (look_ahead code ifso is_loop_header predicate) then Some false + else if (look_ahead code ifnot is_loop_header predicate) then Some true + else None -let do_store_heuristic code ifso ifnot is_loop_header preferred = +let do_store_heuristic code cond ifso ifnot is_loop_header = let predicate n = (function | Istore _ -> true | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else () + in if (look_ahead code ifso is_loop_header predicate) then Some false + else if (look_ahead code ifnot is_loop_header predicate) then Some true + else None -let do_loop_heuristic code ifso ifnot is_loop_header preferred = +let do_loop_heuristic code cond ifso ifnot is_loop_header = let predicate n = get_some @@ PTree.get n is_loop_header - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else () + in if (look_ahead code ifso is_loop_header predicate) then Some true + else if (look_ahead code ifnot is_loop_header predicate) then Some false + else None let get_directions code entrypoint = let bfs_order = bfs code entrypoint @@ -214,25 +204,18 @@ let get_directions code entrypoint = match (get_some @@ PTree.get n code) with | Icond (cond, lr, ifso, ifnot) -> (* Printf.printf "Analyzing %d.." (P.to_int n); *) - let preferred = ref false - in (try - (* Printf.printf " call.."; *) - do_call_heuristic code ifso ifnot is_loop_header preferred; - (* Printf.printf " opcode.."; *) - do_opcode_heuristic code cond ifso ifnot preferred; - (* Printf.printf " return.."; *) - do_return_heuristic code ifso ifnot is_loop_header preferred; - (* Printf.printf " store.."; *) - do_store_heuristic code ifso ifnot is_loop_header preferred; - (* Printf.printf " loop.."; *) - do_loop_heuristic code ifso ifnot is_loop_header preferred; - (* Printf.printf "Random choice for %d\n" (P.to_int n); *) - preferred := Random.bool () - with HeuristicSucceeded | DuplicateOpcodeHeuristic.HeuristicSucceeded -> begin - (* Printf.printf " %s\n" (match !preferred with true -> "BRANCH" | false -> "FALLTHROUGH"); *) - () - end - ); directions := PTree.set n !preferred !directions + let heuristics = [ do_call_heuristic; do_opcode_heuristic; + do_return_heuristic; do_store_heuristic; do_loop_heuristic ] in + let preferred = ref None in + begin + List.iter (fun do_heur -> + match !preferred with + | None -> preferred := do_heur code cond ifso ifnot is_loop_header + | Some _ -> () + ) heuristics; + match !preferred with None -> preferred := Some (Random.bool ()) | Some _ -> (); + directions := PTree.set n (get_some !preferred) !directions + end | _ -> () ) bfs_order; !directions diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml index 690553ce..2ec314c1 100644 --- a/mppa_k1c/DuplicateOpcodeHeuristic.ml +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -2,10 +2,8 @@ open Op open Integers -exception HeuristicSucceeded - -let opcode_heuristic code cond ifso ifnot preferred = - let decision = match cond with +let opcode_heuristic code cond ifso ifnot is_loop_header = + match cond with | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with | Clt | Cle -> Some false | Cgt | Cge -> Some true @@ -27,6 +25,3 @@ let opcode_heuristic code cond ifso ifnot preferred = | _ -> None ) | _ -> None - in match decision with - | Some b -> (preferred := b; raise HeuristicSucceeded) - | None -> () -- cgit From ec0d767ba602c35e320ee77f2ccd6f513adeb7b6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Mar 2020 14:57:14 +0100 Subject: Linearizeaux: forgotten print --- backend/Linearizeaux.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 7aed5936..22db25e0 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -417,7 +417,7 @@ let order_sequences code entry fs = end in begin (* Printf.printf "depmap: "; print_depmap depmap; *) - print_ssequence fs; + (* print_ssequence fs; *) while List.length !ordered_fs != List.length fs do let next_id = select_next () in evaluate next_id -- cgit From b016de5a1a8230b5a6c51d8e7cd8829d39a4c781 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Mar 2020 15:16:08 +0100 Subject: [BROKEN] Replacing the boolean -fduplicate option by an integer To control the threshold for duplication --- backend/Duplicateaux.ml | 10 ++++++---- driver/Clflags.ml | 4 ++-- driver/Compiler.v | 10 +++++----- driver/Driver.ml | 4 ++-- extraction/extraction.v | 2 -- 5 files changed, 15 insertions(+), 15 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 05b8ddb8..636a8d8e 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -467,7 +467,7 @@ let tail_duplicate code preds ptree trace = in (new_code, new_ptree, !nb_duplicated) let superblockify_traces code preds traces = - let max_nb_duplicated = 1 (* FIXME - should be architecture dependent *) + let max_nb_duplicated = !Clflags.option_fduplicate (* FIXME - should be architecture dependent *) in let ptree = make_identity_ptree code in let rec f code ptree = function | [] -> (code, ptree, 0) @@ -499,12 +499,14 @@ let rec invert_iconds code = function else code in invert_iconds code' ts -(* For now, identity function *) let duplicate_aux f = let entrypoint = f.fn_entrypoint in let code = f.fn_code in let traces = select_traces (to_ttl_code code entrypoint) entrypoint in let icond_code = invert_iconds code traces in let preds = get_predecessors_rtl icond_code in - let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in - ((new_code, f.fn_entrypoint), pTreeId) + if !Clflags.option_fduplicate >= 1 then + let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in + ((new_code, f.fn_entrypoint), pTreeId) + else + ((icond_code, entrypoint), make_identity_ptree code) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 6d6f1df4..79c0bce0 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -28,8 +28,8 @@ let option_fconstprop = ref true let option_fcse = ref true let option_fcse2 = 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 *) +let option_fduplicate = ref 0 +let option_finvertcond = ref true let option_ftracelinearize = ref false let option_fpostpass = ref true let option_fpostpass_sched = ref "list" diff --git a/driver/Compiler.v b/driver/Compiler.v index 499feff2..da19a0b9 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -134,7 +134,7 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 2) @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 3) - @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) + @@@ time "Tail-duplicating" Duplicate.transf_program @@ print (print_RTL 4) @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 5) @@ -254,7 +254,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog ::: mkpass Renumberproof.match_prog - ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) + ::: mkpass Duplicateproof.match_prog ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) ::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) @@ -301,7 +301,7 @@ 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 (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 (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 *. destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. @@ -326,7 +326,7 @@ Proof. 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 p10; split. eapply partial_if_match; eauto. apply Duplicateproof.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. exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. @@ -412,7 +412,7 @@ Ltac DestructM := eapply Inliningproof.transf_program_correct; eassumption. 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 Duplicateproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. eapply compose_forward_simulations. diff --git a/driver/Driver.ml b/driver/Driver.ml index db71aef9..dd357423 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -204,7 +204,7 @@ Processing options: -finvertcond Invert conditions based on predicted paths (to prefer fallthrough). Requires -fduplicate to be also activated [on] -ftracelinearize Linearizes based on the traces identified by duplicate phase - It is recommended to also activate -fduplicate with this pass [off] + It is heavily recommended to activate -finvertcond with this pass [off] -fforward-moves Forward moves after CSE -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their @@ -393,7 +393,7 @@ let cmdline_actions = @ f_opt "cse2" option_fcse2 @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass - @ f_opt "duplicate" option_fduplicate + @ [ Exact "-fduplicate", Integer (fun n -> option_fduplicate := n) ] @ f_opt "invertcond" option_finvertcond @ f_opt "tracelinearize" option_ftracelinearize @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched diff --git a/extraction/extraction.v b/extraction/extraction.v index 929c21e0..ba6b080b 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -105,8 +105,6 @@ Extract Constant Compopts.generate_float_constants => "fun _ -> !Clflags.option_ffloatconstprop >= 2". Extract Constant Compopts.optim_tailcalls => "fun _ -> !Clflags.option_ftailcalls". -Extract Constant Compopts.optim_duplicate => - "fun _ -> !Clflags.option_fduplicate". Extract Constant Compopts.optim_constprop => "fun _ -> !Clflags.option_fconstprop". Extract Constant Compopts.optim_CSE => -- cgit From deaf767b7f60cc3b3a0d3314e763a682571a00fa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 15:16:44 +0100 Subject: more portable cycles.h --- test/monniaux/clock.c | 4 ++-- test/monniaux/cycles.h | 36 +++++++++++++++++++++++++-------- test/monniaux/quicksort/quicksort_run.c | 2 +- 3 files changed, 31 insertions(+), 11 deletions(-) diff --git a/test/monniaux/clock.c b/test/monniaux/clock.c index fb636667..4ec679f6 100644 --- a/test/monniaux/clock.c +++ b/test/monniaux/clock.c @@ -24,9 +24,9 @@ cycle_t get_current_cycle(void) { } void print_total_clock(void) { - printf("time cycles: %lu\n", total_clock); + printf("time cycles: %" PRcycle "\n", total_clock); } void printerr_total_clock(void) { - fprintf(stderr, "time cycles: %lu\n", total_clock); + fprintf(stderr, "time cycles: %" PRcycle "\n", total_clock); } diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h index aed9941a..c7dc582b 100644 --- a/test/monniaux/cycles.h +++ b/test/monniaux/cycles.h @@ -1,14 +1,11 @@ +#include #include #include -typedef unsigned long cycle_t; - -#ifdef MAX_MEASURES - static cycle_t _last_stop[MAX_MEASURES] = {0}; - static cycle_t _total_cycles[MAX_MEASURES] = {0}; -#endif - #ifdef __K1C__ +typedef uint64_t cycle_t; +#define PRcycle PRId64 + #include <../../k1-cos/include/hal/cos_registers.h> static inline void cycle_count_config(void) @@ -28,11 +25,20 @@ static inline cycle_t get_cycle(void) #else // not K1C static inline void cycle_count_config(void) { } -#ifdef __x86_64__ +#if defined(__i386__) || defined( __x86_64__) +#define PRcycle PRId64 +typedef uint64_t cycle_t; #include static inline cycle_t get_cycle(void) { return __rdtsc(); } #elif __riscv +#ifdef __riscv32 +#define PRcycle PRId32 +typedef uint32_t cycle_t; +#else +#define PRcycle PRId64 +typedef uint64_t cycle_t; +#endif static inline cycle_t get_cycle(void) { cycle_t cycles; asm volatile ("rdcycle %0" : "=r" (cycles)); @@ -41,6 +47,9 @@ static inline cycle_t get_cycle(void) { #elif defined (__ARM_ARCH) && (__ARM_ARCH >= 6) #if (__ARM_ARCH < 8) +typedef uint32_t cycle_t; +#define PRcycle PRId32 + /* need this kernel module https://github.com/zertyz/MTL/tree/master/cpp/time/kernel/arm */ static inline cycle_t get_cycle(void) { @@ -49,6 +58,8 @@ static inline cycle_t get_cycle(void) { return cycles; } #else +#define PRcycle PRId64 +typedef uint64_t cycle_t; /* need this kernel module: https://github.com/jerinjacobk/armv8_pmu_cycle_counter_el0 @@ -61,7 +72,10 @@ static inline cycle_t get_cycle(void) return val; } #endif + #else +#define PRcycle PRId32 +typedef uint32_t cycle_t; static inline cycle_t get_cycle(void) { return 0; } #endif #endif @@ -71,3 +85,9 @@ static inline cycle_t get_cycle(void) { return 0; } #define TIMESTOP(i) {cycle_t cur = get_cycle(); _total_cycles[i] += cur - _last_stop[i]; _last_stop[i] = cur;} #define TIMEPRINT(n) { for (int i = 0; i <= n; i++) printf("%d cycles: %" PRIu64 "\n", i, _total_cycles[i]); } #endif + + +#ifdef MAX_MEASURES + static cycle_t _last_stop[MAX_MEASURES] = {0}; + static cycle_t _total_cycles[MAX_MEASURES] = {0}; +#endif diff --git a/test/monniaux/quicksort/quicksort_run.c b/test/monniaux/quicksort/quicksort_run.c index c35d0752..3c640b24 100644 --- a/test/monniaux/quicksort/quicksort_run.c +++ b/test/monniaux/quicksort/quicksort_run.c @@ -13,7 +13,7 @@ int main (void) { quicksort(vec, len); quicksort_time = get_cycle() - quicksort_time; printf("sorted=%s\n" - "time cycles:%" PRIu64 "\n", + "time cycles:%" PRcycle "\n", data_vec_is_sorted(vec, len)?"true":"false", quicksort_time); free(vec); -- cgit From 103083dfcef7a71a57fd6c05af276db1f034ac75 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Mar 2020 11:18:06 +0100 Subject: Fixing build --- driver/Driver.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/driver/Driver.ml b/driver/Driver.ml index dd357423..43aedf50 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -318,7 +318,7 @@ let cmdline_actions = [ Exact "-O0", Unit (unset_all optimization_options); Exact "-O", Unit (set_all optimization_options); - _Regexp "-O1", Self (fun _ -> set_all optimization_options (); option_fpostpass := false; option_fduplicate := false); + _Regexp "-O1", Self (fun _ -> set_all optimization_options (); option_fpostpass := false); _Regexp "-O[123]$", Unit (set_all optimization_options); Exact "-Os", Set option_Osize; Exact "-Obranchless", Set option_Obranchless; -- cgit From 22bfb4389571e9b2779b6e5b9f48b8a0e5c35867 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Mar 2020 14:16:23 +0100 Subject: Bug fix in ftracelinearize --- backend/Linearizeaux.ml | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 22db25e0..23d06075 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -140,10 +140,21 @@ let rec last_element = function | e :: [] -> e | e' :: e :: l -> last_element (e::l) +let print_plist l = + let rec f = function + | [] -> () + | n :: l -> Printf.printf "%d, " (P.to_int n); f l + in begin + Printf.printf "["; + f l; + Printf.printf "]" + end + let forward_sequences code entry = let visited = ref (PTree.map (fun n i -> false) code) 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); *) if not (get_some @@ PTree.get node !visited) then begin visited := PTree.set node true !visited; match PTree.get node code with @@ -164,8 +175,8 @@ let forward_sequences code entry = in let rec f code = function | [] -> [] | node :: ln -> - let fs, rem = traverse_fallthrough code node - in [fs] @ (f code rem) + let fs, rem_from_node = traverse_fallthrough code node + in [fs] @ ((f code rem_from_node) @ (f code ln)) in (f code [entry]) module PInt = struct @@ -417,12 +428,12 @@ let order_sequences code entry fs = end in begin (* Printf.printf "depmap: "; print_depmap depmap; *) - (* print_ssequence fs; *) + (* Printf.printf "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; - (* print_ssequence (List.rev (!ordered_fs)); *) + (* Printf.printf "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs)); *) List.rev (!ordered_fs) end -- cgit From 273c48f412d018e5d5649db266b282fc272a0af8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Mar 2020 15:23:41 +0100 Subject: Linearize: More helpful message when tracelinearize fails --- backend/Linearizeaux.ml | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 23d06075..bd8f747e 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -415,16 +415,24 @@ let order_sequences code entry fs = ) depmap end in let select_next () = - let selected_id = ref (-1) in + let selected_id = ref None in begin Array.iteri (fun i deps -> begin (* Printf.printf "Deps: "; print_iset deps; Printf.printf "\n"; *) - if !selected_id == -1 && deps == ISet.empty && not fs_evaluated.(i) - then selected_id := i + match !selected_id with + | None -> if (deps == ISet.empty && not fs_evaluated.(i)) then selected_id := Some i + | Some id -> () end ) depmap; - !selected_id + match !selected_id with + | Some id -> id + | None -> begin + Printf.printf "original fs: "; print_ssequence fs; + Printf.printf "depmap: "; print_depmap depmap; + Printf.printf "current ordered fs: "; print_ssequence @@ List.rev (!ordered_fs); + failwith "Could not find a next schedulable trace. Are the dependencies alright?" + end end in begin (* Printf.printf "depmap: "; print_depmap depmap; *) -- cgit From 9a86085b2226905e8cf14b600f2069202c5d12bd Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Mar 2020 15:24:13 +0100 Subject: Some dependencies were not taken into account in tracelinearize --- backend/Linearizeaux.ml | 27 ++++++++++++--------------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index bd8f747e..3602cb91 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -349,6 +349,14 @@ let construct_depmap code entry fs = ) fs; !index end + in let check_and_update_depmap from 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 + if out_index_fs != in_index_fs then + depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs) + else () + else () in let rec dfs_visit code = function | [] -> () | node :: ln -> @@ -360,25 +368,14 @@ let construct_depmap code entry fs = let next_visits = match (last_element bb) with | Ltailcall _ | Lreturn -> [] - | Lbranch n -> [n] + | Lbranch n -> (check_and_update_depmap node n; [n]) | Lcond (_, _, ifso, ifnot) -> begin - (if not (ppmap_is_true (node, ifso) is_loop_edge) then - let in_index_fs = find_index_of_node node in - let out_index_fs = find_index_of_node ifso in - depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs) - else - ()); + check_and_update_depmap node ifso; + check_and_update_depmap node ifnot; [ifso; ifnot] end | Ljumptable(_, ln) -> begin - let in_index_fs = find_index_of_node node in - List.iter (fun n -> - if not (ppmap_is_true (node, n) is_loop_edge) then - let out_index_fs = find_index_of_node n in - depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs) - else - () - ) ln; + List.iter (fun n -> check_and_update_depmap node n) ln; ln end (* end of bblocks should not be another value than one of the above *) -- cgit From a7098538edfda9fdbd95bc7c6ba6e380811230fa Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Mar 2020 15:41:05 +0100 Subject: Linearizeaux, forgot to visit the rest of the nodes in dfs_visit --- backend/Linearizeaux.ml | 48 ++++++++++++++++++++++++++---------------------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 3602cb91..5bdeeb8f 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -350,6 +350,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); *) 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 @@ -360,28 +361,31 @@ let construct_depmap code entry fs = in let rec dfs_visit code = function | [] -> () | node :: ln -> - match (get_some @@ PTree.get node !visited) with - | true -> () - | false -> begin - visited := PTree.set node true !visited; - let bb = get_some @@ PTree.get node code in - let next_visits = - match (last_element bb) with - | Ltailcall _ | Lreturn -> [] - | Lbranch n -> (check_and_update_depmap node n; [n]) - | Lcond (_, _, ifso, ifnot) -> begin - check_and_update_depmap node ifso; - check_and_update_depmap node ifnot; - [ifso; ifnot] - end - | Ljumptable(_, ln) -> begin - List.iter (fun n -> check_and_update_depmap node n) ln; - ln - end - (* end of bblocks should not be another value than one of the above *) - | _ -> failwith "last_element gave an invalid output" - in dfs_visit code next_visits - end + begin + match (get_some @@ PTree.get node !visited) with + | true -> () + | false -> begin + visited := PTree.set node true !visited; + let bb = get_some @@ PTree.get node code in + let next_visits = + match (last_element bb) with + | Ltailcall _ | Lreturn -> [] + | Lbranch n -> (check_and_update_depmap node n; [n]) + | Lcond (_, _, ifso, ifnot) -> begin + check_and_update_depmap node ifso; + check_and_update_depmap node ifnot; + [ifso; ifnot] + end + | Ljumptable(_, ln) -> begin + List.iter (fun n -> check_and_update_depmap node n) ln; + ln + end + (* end of bblocks should not be another value than one of the above *) + | _ -> failwith "last_element gave an invalid output" + in dfs_visit code next_visits + end; + dfs_visit code ln + end in begin dfs_visit code [entry]; depmap -- cgit From 530d30cf71661419f54e175dd6bdb7d3f68f7f5c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Mar 2020 15:48:47 +0100 Subject: Linearizeaux: dumb selector when cycling dependencies are found --- backend/Linearizeaux.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 5bdeeb8f..a813ac96 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -429,10 +429,12 @@ let order_sequences code entry fs = match !selected_id with | Some id -> id | None -> begin - Printf.printf "original fs: "; print_ssequence fs; - Printf.printf "depmap: "; print_depmap depmap; - Printf.printf "current ordered fs: "; print_ssequence @@ List.rev (!ordered_fs); - failwith "Could not find a next schedulable trace. Are the dependencies alright?" + Array.iteri (fun i deps -> + match !selected_id with + | None -> if not fs_evaluated.(i) then selected_id := Some i + | Some id -> () + ) depmap; + get_some !selected_id end end in begin -- cgit From e63e318c720c678d44cbb27d940ebfa076a7f8b4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 11 Mar 2020 13:34:35 +0100 Subject: remet is_trivial_op dans CSE2 --- backend/CSE2.v | 2 +- backend/CSE2proof.v | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index be72405b..d5444e3b 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -469,7 +469,7 @@ Definition transf_instr (fmap : option (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/CSE2proof.v b/backend/CSE2proof.v index 7e1dd430..6368e585 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1200,8 +1200,11 @@ Proof. reflexivity. - (* op *) unfold transf_instr in *. - destruct find_op_in_fmap eqn:FIND_OP. + destruct (if is_trivial_op op then None else find_op_in_fmap (forward_map f) pc op + (subst_args (forward_map f) pc args)) eqn:FIND_OP. { + destruct (is_trivial_op op). + discriminate. unfold find_op_in_fmap, fmap_sem', fmap_sem in *. destruct (forward_map f) as [map |] eqn:MAP. 2: discriminate. -- cgit From 9e706de1eb25d6d6dbeb1eb2ced71e48523a499f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Mar 2020 15:43:26 +0100 Subject: Fixed stupid typo bug preventing the prediction update for the RANDOM predictor --- backend/Duplicateaux.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 636a8d8e..209527b9 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -213,7 +213,7 @@ let get_directions code entrypoint = | None -> preferred := do_heur code cond ifso ifnot is_loop_header | Some _ -> () ) heuristics; - match !preferred with None -> preferred := Some (Random.bool ()) | Some _ -> (); + (match !preferred with None -> preferred := Some (Random.bool ()) | Some _ -> ()); directions := PTree.set n (get_some !preferred) !directions end | _ -> () -- cgit From 1b00a75796a8ace42cc480efadaad948407f5a31 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Mar 2020 16:16:18 +0100 Subject: More debug info on Linearize and Duplicate --- backend/Duplicateaux.ml | 71 ++++++++++++++++++++++++++++++++----------------- backend/Linearizeaux.ml | 2 +- 2 files changed, 47 insertions(+), 26 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 209527b9..d3036b9a 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -161,36 +161,52 @@ let rec look_ahead code node is_loop_header predicate = ) let do_call_heuristic code cond ifso ifnot is_loop_header = - let predicate n = (function - | Icall _ -> true - | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then Some false - else if (look_ahead code ifnot is_loop_header predicate) then Some true - else None + begin + Printf.printf "\tCall heuristic..\n"; + let predicate n = (function + | Icall _ -> true + | _ -> false) @@ get_some @@ PTree.get n code + in if (look_ahead code ifso is_loop_header predicate) then Some false + else if (look_ahead code ifnot is_loop_header predicate) then Some true + else None + end -let do_opcode_heuristic code cond ifso ifnot is_loop_header = DuplicateOpcodeHeuristic.opcode_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"; + DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot is_loop_header + end let do_return_heuristic code cond ifso ifnot is_loop_header = - let predicate n = (function - | Ireturn _ -> true - | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then Some false - else if (look_ahead code ifnot is_loop_header predicate) then Some true - else None + begin + Printf.printf "\tReturn heuristic..\n"; + let predicate n = (function + | Ireturn _ -> true + | _ -> false) @@ get_some @@ PTree.get n code + in if (look_ahead code ifso is_loop_header predicate) then Some false + else if (look_ahead code ifnot is_loop_header predicate) then Some true + else None + end let do_store_heuristic code cond ifso ifnot is_loop_header = - let predicate n = (function - | Istore _ -> true - | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then Some false - else if (look_ahead code ifnot is_loop_header predicate) then Some true - else None + begin + Printf.printf "\tStore heuristic..\n"; + let predicate n = (function + | Istore _ -> true + | _ -> false) @@ get_some @@ PTree.get n code + in if (look_ahead code ifso is_loop_header predicate) then Some false + else if (look_ahead code ifnot is_loop_header predicate) then Some true + else None + end let do_loop_heuristic code cond ifso ifnot is_loop_header = - let predicate n = get_some @@ PTree.get n is_loop_header - in if (look_ahead code ifso is_loop_header predicate) then Some true - else if (look_ahead code ifnot is_loop_header predicate) then Some false - else None + begin + Printf.printf "\tLoop heuristic..\n"; + let predicate n = get_some @@ PTree.get n is_loop_header + in if (look_ahead code ifso is_loop_header predicate) then Some true + else if (look_ahead code ifnot is_loop_header predicate) then Some false + else None + end let get_directions code entrypoint = let bfs_order = bfs code entrypoint @@ -208,13 +224,18 @@ let get_directions code entrypoint = do_return_heuristic; do_store_heuristic; do_loop_heuristic ] in let preferred = ref None in begin + Printf.printf "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; - (match !preferred with None -> preferred := Some (Random.bool ()) | Some _ -> ()); - directions := PTree.set n (get_some !preferred) !directions + (match !preferred with None -> (Printf.printf "\tRANDOM\n"; preferred := Some (Random.bool ())) | Some _ -> ()); + directions := PTree.set n (get_some !preferred) !directions; + (match !preferred with | Some false -> Printf.printf "\tFALLTHROUGH\n" + | Some true -> Printf.printf "\tBRANCH\n" + | None -> ()); + Printf.printf "---------------------------------------\n" end | _ -> () ) bfs_order; diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index a813ac96..eed58f8d 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -444,7 +444,7 @@ let order_sequences code entry fs = let next_id = select_next () in evaluate next_id done; - (* Printf.printf "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs)); *) + Printf.printf "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs)); List.rev (!ordered_fs) end -- cgit From 3fef5e1d45820a775a7c941851af6f0bf3f1537d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Mar 2020 17:00:48 +0100 Subject: Adding info field for branching in RTL, LTL, XTL and all associated passes --- backend/Allocation.v | 4 ++-- backend/Allocproof.v | 6 +++--- backend/CSE.v | 6 +++--- backend/CSE2.v | 6 +++--- backend/Constprop.v | 6 +++--- backend/Constpropproof.v | 4 ++-- backend/Deadcode.v | 4 ++-- backend/Duplicate.v | 4 ++-- backend/Duplicateaux.ml | 27 ++++++++++++++------------- backend/Duplicateproof.v | 8 ++++---- backend/ForwardMoves.v | 6 +++--- backend/Inlining.v | 4 ++-- backend/Inliningspec.v | 6 +++--- backend/LTL.v | 8 ++++---- backend/Linearize.v | 2 +- backend/Linearizeaux.ml | 10 +++++----- backend/Liveness.v | 2 +- backend/PrintLTL.ml | 2 +- backend/PrintRTL.ml | 2 +- backend/PrintXTL.ml | 2 +- backend/RTL.v | 19 ++++++++++--------- backend/RTLgen.v | 2 +- backend/RTLgenspec.v | 4 ++-- backend/RTLtyping.v | 6 +++--- backend/Regalloc.ml | 20 ++++++++++---------- backend/Renumber.v | 2 +- backend/Splitting.ml | 4 ++-- backend/Tunneling.v | 4 ++-- backend/Unusedglob.v | 2 +- backend/ValueAnalysis.v | 2 +- backend/XTL.ml | 6 +++--- backend/XTL.mli | 2 +- 32 files changed, 97 insertions(+), 95 deletions(-) diff --git a/backend/Allocation.v b/backend/Allocation.v index d18b07a9..2323c050 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -314,10 +314,10 @@ Definition pair_instr_block Some(BSbuiltin ef args res mv1 args' res' mv2 s) | _ => None end - | Icond cond args s1 s2 => + | Icond cond args s1 s2 i => let (mv1, b1) := extract_moves nil b in match b1 with - | Lcond cond' args' s1' s2' :: b2 => + | Lcond cond' args' s1' s2' i' :: b2 => assertion (eq_condition cond cond'); assertion (peq s1 s1'); assertion (peq s2 s2'); diff --git a/backend/Allocproof.v b/backend/Allocproof.v index b6880860..3c7df58a 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -169,11 +169,11 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (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, + | 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) - (expand_moves mv (Lcond cond args' s1 s2 :: k)) + (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) diff --git a/backend/CSE.v b/backend/CSE.v index 2827161d..1936d4e4 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -496,7 +496,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ => set_res_unknown before res end - | Icond cond args ifso ifnot => + | Icond cond args ifso ifnot _ => before | Ijumptable arg tbl => before @@ -549,10 +549,10 @@ Definition transf_instr (n: numbering) (instr: instruction) := let (n1, vl) := valnum_regs n args in let (addr', args') := reduce _ combine_addr n1 addr args vl in Istore chunk addr' args' src s - | Icond cond args s1 s2 => + | Icond cond args s1 s2 i => let (n1, vl) := valnum_regs n args in let (cond', args') := reduce _ combine_cond n1 cond args vl in - Icond cond' args' s1 s2 + Icond cond' args' s1 s2 i | _ => instr end. diff --git a/backend/CSE2.v b/backend/CSE2.v index d5444e3b..900a7517 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -405,7 +405,7 @@ Qed. Definition apply_instr instr (rel : RELATION.t) : RB.t := match instr with | Inop _ - | Icond _ _ _ _ + | Icond _ _ _ _ _ | Ijumptable _ _ => Some rel | Istore chunk addr args _ _ => Some (kill_store chunk addr args rel) | Iop op args dst _ => Some (gen_oper op dst args rel) @@ -485,8 +485,8 @@ Definition transf_instr (fmap : option (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 i => + Icond cond (subst_args fmap pc args) s1 s2 i | Ijumptable arg tbl => Ijumptable (subst_arg fmap pc arg) tbl | Ireturn (Some arg) => diff --git a/backend/Constprop.v b/backend/Constprop.v index eda41b39..0be9438c 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -69,7 +69,7 @@ Fixpoint successor_rec (n: nat) (f: function) (ae: AE.t) (pc: node) : node := match f.(fn_code)!pc with | Some (Inop s) => successor_rec n' f ae s - | Some (Icond cond args s1 s2) => + | Some (Icond cond args s1 s2 _) => match resolve_branch (eval_static_condition cond (aregs ae args)) with | Some b => successor_rec n' f ae (if b then s1 else s2) | None => pc @@ -217,14 +217,14 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) end | _, _ => dfl end - | Icond cond args s1 s2 => + | Icond cond args s1 s2 i => let aargs := aregs ae args in match resolve_branch (eval_static_condition cond aargs) with | Some b => if b then Inop s1 else Inop s2 | None => let (cond', args') := cond_strength_reduction cond args aargs in - Icond cond' args' s1 s2 + Icond cond' args' s1 s2 i end | Ijumptable arg tbl => match areg ae arg with diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 63cfee24..60663503 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -142,8 +142,8 @@ Inductive match_pc (f: function) (rs: regset) (m: mem): nat -> node -> node -> P f.(fn_code)!pc = Some (Inop s) -> match_pc f rs m n s pcx -> match_pc f rs m (S n) pc pcx - | match_pc_cond: forall n pc cond args s1 s2 pcx, - f.(fn_code)!pc = Some (Icond cond args s1 s2) -> + | match_pc_cond: forall n pc cond args s1 s2 pcx i, + f.(fn_code)!pc = Some (Icond cond args s1 s2 i) -> (forall b, eval_condition cond rs##args m = Some b -> match_pc f rs m n (if b then s1 else s2) pcx) -> diff --git a/backend/Deadcode.v b/backend/Deadcode.v index 1f208a91..3412a6fa 100644 --- a/backend/Deadcode.v +++ b/backend/Deadcode.v @@ -142,7 +142,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) nmem_dead_stack f.(fn_stacksize)) | Some(Ibuiltin ef args res s) => transfer_builtin approx!!pc ef args res ne nm - | Some(Icond cond args s1 s2) => + | Some(Icond cond args s1 s2 _) => if peq s1 s2 then after else (add_needs args (needs_of_condition cond) ne, nm) | Some(Ijumptable arg tbl) => @@ -192,7 +192,7 @@ Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t) if nmem_contains (snd an!!pc) (aaddr_arg approx!!pc dst) sz then instr else Inop s - | Icond cond args s1 s2 => + | Icond cond args s1 s2 _ => if peq s1 s2 then Inop s1 else instr | _ => instr diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 82c17367..af85efe4 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -134,8 +134,8 @@ Definition verify_match_inst dupmap inst tinst := else Error (msg "Different ef in Ibuiltin") | _ => Error (msg "verify_match_inst Ibuiltin") end - | Icond cond lr n1 n2 => match tinst with - | Icond cond' lr' n1' n2' => + | Icond cond lr n1 n2 i => match tinst with + | Icond cond' lr' n1' n2' i' => if (list_eq_dec Pos.eq_dec lr lr') then if (eq_condition cond cond') then do u1 <- verify_is_copy dupmap n1 n1'; diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index d3036b9a..86bc06c9 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -39,7 +39,7 @@ let bfs code entrypoint = | 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 + | 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 end done; @@ -56,7 +56,7 @@ let get_predecessors_rtl code = let succ = match i with | Inop n | Iop (_,_,_,n) | Iload (_, _,_,_,_,n) | Istore (_,_,_,_,n) | Icall (_,_,_,_,n) | Ibuiltin (_, _, _, n) -> [n] - | Icond (_,_,n1,n2) -> [n1;n2] + | Icond (_,_,n1,n2,_) -> [n1;n2] | Ijumptable (_,ln) -> ln | Itailcall _ | Ireturn _ -> [] in List.iter (fun s -> @@ -123,7 +123,7 @@ let get_loop_headers code entrypoint = | 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] + | Icond (_, _, n1, n2, _) -> [n1; n2] | Itailcall _ | Ireturn _ -> [] | Ijumptable (_, ln) -> ln ) in dfs_visit code next_visits; @@ -218,7 +218,7 @@ let get_directions code entrypoint = (* Printf.printf "\n"; *) List.iter (fun n -> match (get_some @@ PTree.get n code) with - | Icond (cond, lr, ifso, ifnot) -> + | Icond (cond, lr, ifso, ifnot, _) -> (* Printf.printf "Analyzing %d.." (P.to_int n); *) let heuristics = [ do_call_heuristic; do_opcode_heuristic; do_return_heuristic; do_store_heuristic; do_loop_heuristic ] in @@ -251,9 +251,9 @@ let to_ttl_inst direction = function | Icall (s, ri, lr, r, n) -> Tleaf (Icall(s, ri, lr, r, n)) | Itailcall (s, ri, lr) -> Tleaf (Itailcall(s, ri, lr)) | Ibuiltin (ef, lbr, br, n) -> Tleaf (Ibuiltin(ef, lbr, br, n)) -| Icond (cond, lr, n, n') -> (match direction with - | false -> Tnext (n', Icond(cond, lr, n, n')) - | true -> Tnext (n, Icond(cond, lr, n, n'))) +| Icond (cond, lr, n, n', i) -> (match direction with + | false -> Tnext (n', Icond(cond, lr, n, n', i)) + | true -> Tnext (n, Icond(cond, lr, n, n', i))) | Ijumptable (r, ln) -> Tleaf (Ijumptable(r, ln)) let rec to_ttl_code_rec directions = function @@ -299,7 +299,7 @@ let dfs code entrypoint = | Itailcall _ | Ireturn _ -> [] | _ -> failwith "Tleaf case not handled in dfs" ) | Tnext (n,i) -> (dfs_list code [n]) @ match i with - | Icond (_, _, n1, n2) -> dfs_list code [n1; n2] + | Icond (_, _, n1, n2, _) -> dfs_list code [n1; n2] | Inop _ | Iop _ | Iload _ | Istore _ -> [] | _ -> failwith "Tnext case not handled in dfs" end @@ -314,7 +314,7 @@ let get_predecessors_ttl code = | 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] + | 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 @@ -413,10 +413,10 @@ let rec change_pointers code n n' = function | Ibuiltin(a, b, c, n0) -> assert (n0 == n); Ibuiltin(a, b, c, n') | Ijumptable(a, ln) -> assert (optbool @@ List.find_opt (fun e -> e == n) ln); Ijumptable(a, List.map (fun e -> if (e == n) then n' else e) ln) - | Icond(a, b, n1, n2) -> assert (n1 == n || n2 == n); + | Icond(a, b, n1, n2, i) -> assert (n1 == n || n2 == n); let n1' = if (n1 == n) then n' else n1 in let n2' = if (n2 == n) then n' else n2 - in Icond(a, b, n1', n2') + in Icond(a, b, n1', n2', i) | Inop n0 -> assert (n0 == n); Inop n' | Iop (a, b, c, n0) -> assert (n0 == n); Iop (a, b, c, n') | Iload (a, b, c, d, e, n0) -> assert (n0 == n); Iload (a, b, c, d, e, n') @@ -504,11 +504,12 @@ let rec invert_iconds_trace code = function | n::[] -> code | n :: n' :: t -> let code' = match ptree_get_some n code with - | Icond (c, lr, ifso, ifnot) -> + | Icond (c, lr, ifso, ifnot, i) -> assert (n' == ifso || n' == ifnot); if (n' == ifso) then ( (* Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); *) - PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso)) code ) + let i' = match i with None -> None | Some b -> Some (not b) in + PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso, i')) code ) else code | _ -> code in invert_iconds_trace code' (n'::t) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 466b4b75..6b598dc7 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -23,12 +23,12 @@ Inductive match_inst (dupmap: PTree.t node): instruction -> instruction -> Prop match_inst dupmap (Itailcall s ri lr) (Itailcall s ri lr) | match_inst_builtin: forall n n' ef la br, dupmap!n' = (Some n) -> match_inst dupmap (Ibuiltin ef la br n) (Ibuiltin ef la br n') - | match_inst_cond: forall ifso ifso' ifnot ifnot' c lr, + | match_inst_cond: forall ifso ifso' ifnot ifnot' c lr i i', dupmap!ifso' = (Some ifso) -> dupmap!ifnot' = (Some ifnot) -> - match_inst dupmap (Icond c lr ifso ifnot) (Icond c lr ifso' ifnot') - | match_inst_revcond: forall ifso ifso' ifnot ifnot' c lr, + match_inst dupmap (Icond c lr ifso ifnot i) (Icond c lr ifso' ifnot' i') + | match_inst_revcond: forall ifso ifso' ifnot ifnot' c lr i i', dupmap!ifso' = (Some ifso) -> dupmap!ifnot' = (Some ifnot) -> - match_inst dupmap (Icond c lr ifso ifnot) (Icond (negate_condition c) lr ifnot' ifso') + match_inst dupmap (Icond c lr ifso ifnot i) (Icond (negate_condition c) lr ifnot' ifso' i') | match_inst_jumptable: forall ln ln' r, list_forall2 (fun n n' => (dupmap!n' = (Some n))) ln ln' -> match_inst dupmap (Ijumptable r ln) (Ijumptable r ln') diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index c73b0213..7cfd411f 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -250,7 +250,7 @@ Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) := Definition apply_instr instr x := match instr with | Inop _ - | Icond _ _ _ _ + | Icond _ _ _ _ _ | Ijumptable _ _ | Istore _ _ _ _ _ => Some x | Iop Omove (src :: nil) dst _ => Some (move src dst x) @@ -309,8 +309,8 @@ Definition transf_instr (fmap : option (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 i => + Icond cond (subst_args fmap pc args) s1 s2 i | Ijumptable arg tbl => Ijumptable (subst_arg fmap pc arg) tbl | Ireturn (Some arg) => diff --git a/backend/Inlining.v b/backend/Inlining.v index 9cf535b9..8c7e1898 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -397,9 +397,9 @@ Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit := | Ibuiltin ef args res s => set_instr (spc ctx pc) (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s)) - | Icond cond args s1 s2 => + | Icond cond args s1 s2 info => set_instr (spc ctx pc) - (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) + (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2) info) | Ijumptable r tbl => set_instr (spc ctx pc) (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v index e20fb373..eba026ec 100644 --- a/backend/Inliningspec.v +++ b/backend/Inliningspec.v @@ -312,9 +312,9 @@ Inductive tr_instr: context -> node -> instruction -> code -> Prop := match res with BR r => Ple r ctx.(mreg) | _ => True end -> c!(spc ctx pc) = Some (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s)) -> tr_instr ctx pc (Ibuiltin ef args res s) c - | tr_cond: forall ctx pc cond args s1 s2 c, - c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) -> - tr_instr ctx pc (Icond cond args s1 s2) c + | tr_cond: forall ctx pc cond args s1 s2 c i, + c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2) i) -> + tr_instr ctx pc (Icond cond args s1 s2 i) c | tr_jumptable: forall ctx pc r tbl c, c!(spc ctx pc) = Some (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) -> tr_instr ctx pc (Ijumptable r tbl) c diff --git a/backend/LTL.v b/backend/LTL.v index ee8b4826..3edd60a2 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -37,7 +37,7 @@ Inductive instruction: Type := | Ltailcall (sg: signature) (ros: mreg + ident) | Lbuiltin (ef: external_function) (args: list (builtin_arg loc)) (res: builtin_res mreg) | Lbranch (s: node) - | Lcond (cond: condition) (args: list mreg) (s1 s2: node) + | Lcond (cond: condition) (args: list mreg) (s1 s2: node) (info: option bool) | Ljumptable (arg: mreg) (tbl: list node) | Lreturn. @@ -263,11 +263,11 @@ Inductive step: state -> trace -> state -> Prop := | exec_Lbranch: forall s f sp pc bb rs m, step (Block s f sp (Lbranch pc :: bb) rs m) E0 (State s f sp pc rs m) - | exec_Lcond: forall s f sp cond args pc1 pc2 bb rs b pc rs' m, + | exec_Lcond: forall s f sp cond args pc1 pc2 bb rs b pc rs' m i, eval_condition cond (reglist rs args) m = Some b -> pc = (if b then pc1 else pc2) -> rs' = undef_regs (destroyed_by_cond cond) rs -> - step (Block s f sp (Lcond cond args pc1 pc2 :: bb) rs m) + step (Block s f sp (Lcond cond args pc1 pc2 i :: bb) rs m) E0 (State s f sp pc rs' m) | exec_Ljumptable: forall s f sp arg tbl bb rs m n pc rs', rs (R arg) = Vint n -> @@ -328,7 +328,7 @@ Fixpoint successors_block (b: bblock) : list node := | nil => nil (**r should never happen *) | Ltailcall _ _ :: _ => nil | Lbranch s :: _ => s :: nil - | Lcond _ _ s1 s2 :: _ => s1 :: s2 :: nil + | Lcond _ _ s1 s2 _ :: _ => s1 :: s2 :: nil | Ljumptable _ tbl :: _ => tbl | Lreturn :: _ => nil | instr :: b' => successors_block b' diff --git a/backend/Linearize.v b/backend/Linearize.v index 4216958c..66b36428 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -179,7 +179,7 @@ Fixpoint linearize_block (b: LTL.bblock) (k: code) : code := Lbuiltin ef args res :: linearize_block b' k | LTL.Lbranch s :: b' => add_branch s k - | LTL.Lcond cond args s1 s2 :: b' => + | LTL.Lcond cond args s1 s2 _ :: b' => if starts_with s1 k then Lcond (negate_condition cond) args s2 :: add_branch s1 k else diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index eed58f8d..c9a5d620 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -81,7 +81,7 @@ let basic_blocks f joins = | [] -> assert false | Lbranch s :: _ -> next_in_block blk minpc s | Ltailcall (sig0, ros) :: _ -> end_block blk minpc - | Lcond (cond, args, ifso, ifnot) :: _ -> + | Lcond (cond, args, ifso, ifnot, _) :: _ -> end_block blk minpc; start_block ifso; start_block ifnot | Ljumptable(arg, tbl) :: _ -> end_block blk minpc; List.iter start_block tbl @@ -165,7 +165,7 @@ let forward_sequences code entry = | Lbuiltin _ -> assert false | Ltailcall _ | Lreturn -> ([], []) | Lbranch n -> let ln, rem = traverse_fallthrough code n in (ln, rem) - | Lcond (_, _, ifso, ifnot) -> let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) + | Lcond (_, _, ifso, ifnot, _) -> let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) | Ljumptable(_, ln) -> match ln with | [] -> ([], []) | n :: ln -> let lln, rem = traverse_fallthrough code n in (lln, ln @ rem) @@ -219,7 +219,7 @@ let can_be_merged code s s' = | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ | Lbuiltin _ | Ltailcall _ | Lreturn -> false | Lbranch n -> n == first_s' - | Lcond (_, _, ifso, ifnot) -> ifnot == first_s' + | Lcond (_, _, ifso, ifnot, _) -> ifnot == first_s' | Ljumptable (_, ln) -> match ln with | [] -> false @@ -303,7 +303,7 @@ let get_loop_edges code entry = | Lbuiltin _ -> assert false | Ltailcall _ | Lreturn -> [] | Lbranch n -> [n] - | Lcond (_, _, ifso, ifnot) -> [ifso; ifnot] + | Lcond (_, _, ifso, ifnot, _) -> [ifso; ifnot] | Ljumptable(_, ln) -> ln ) in dfs_visit code (Some node) next_visits; visited := PTree.set node Visited !visited; @@ -371,7 +371,7 @@ let construct_depmap code entry fs = match (last_element bb) with | Ltailcall _ | Lreturn -> [] | Lbranch n -> (check_and_update_depmap node n; [n]) - | Lcond (_, _, ifso, ifnot) -> begin + | Lcond (_, _, ifso, ifnot, _) -> begin check_and_update_depmap node ifso; check_and_update_depmap node ifnot; [ifso; ifnot] diff --git a/backend/Liveness.v b/backend/Liveness.v index afe11ae6..9652b363 100644 --- a/backend/Liveness.v +++ b/backend/Liveness.v @@ -94,7 +94,7 @@ Definition transfer | Ibuiltin ef args res s => reg_list_live (params_of_builtin_args args) (reg_list_dead (params_of_builtin_res res) after) - | Icond cond args ifso ifnot => + | Icond cond args ifso ifnot _ => reg_list_live args after | Ijumptable arg tbl => reg_live arg after diff --git a/backend/PrintLTL.ml b/backend/PrintLTL.ml index b309a9f2..f173e374 100644 --- a/backend/PrintLTL.ml +++ b/backend/PrintLTL.ml @@ -83,7 +83,7 @@ let print_instruction pp succ = function (print_builtin_args loc) args | Lbranch s -> print_succ pp s succ - | Lcond(cond, args, s1, s2) -> + | Lcond(cond, args, s1, s2, _) -> fprintf pp "if (%a) goto %d else goto %d" (print_condition mreg) (cond, args) (P.to_int s1) (P.to_int s2) diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml index c25773e5..5eab9901 100644 --- a/backend/PrintRTL.ml +++ b/backend/PrintRTL.ml @@ -75,7 +75,7 @@ let print_instruction pp (pc, i) = (name_of_external ef) (print_builtin_args reg) args; print_succ pp s (pc - 1) - | Icond(cond, args, s1, s2) -> + | Icond(cond, args, s1, s2, _) -> fprintf pp "if (%a) goto %d else goto %d\n" (PrintOp.print_condition reg) (cond, args) (P.to_int s1) (P.to_int s2) diff --git a/backend/PrintXTL.ml b/backend/PrintXTL.ml index 1c7655fb..d1b79623 100644 --- a/backend/PrintXTL.ml +++ b/backend/PrintXTL.ml @@ -104,7 +104,7 @@ let print_instruction pp succ = function (print_builtin_args var) args | Xbranch s -> print_succ pp s succ - | Xcond(cond, args, s1, s2) -> + | Xcond(cond, args, s1, s2, _) -> fprintf pp "if (%a) goto %d else goto %d" (print_condition var) (cond, args) (P.to_int s1) (P.to_int s2) diff --git a/backend/RTL.v b/backend/RTL.v index 29a49311..dec59ca2 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -67,11 +67,12 @@ Inductive instruction: Type := (** [Ibuiltin ef args dest succ] calls the built-in function identified by [ef], giving it the values of [args] as arguments. It stores the return value in [dest] and branches to [succ]. *) - | Icond: condition -> list reg -> node -> node -> instruction - (** [Icond cond args ifso ifnot] evaluates the boolean condition + | Icond: condition -> list reg -> node -> node -> option bool -> instruction + (** [Icond cond args ifso ifnot info] evaluates the boolean condition [cond] over the values of registers [args]. If the condition is true, it transitions to [ifso]. If the condition is false, - it transitions to [ifnot]. *) + it transitions to [ifnot]. [info] is a ghost field there to provide + information relative to branch prediction. *) | Ijumptable: reg -> list node -> instruction (** [Ijumptable arg tbl] transitions to the node that is the [n]-th element of the list [tbl], where [n] is the unsigned integer @@ -262,8 +263,8 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp pc rs m) t (State s f sp pc' (regmap_setres res vres rs) m') | exec_Icond: - forall s f sp pc rs m cond args ifso ifnot b pc', - (fn_code f)!pc = Some(Icond cond args ifso ifnot) -> + forall s f sp pc rs m cond args ifso ifnot b pc' predb, + (fn_code f)!pc = Some(Icond cond args ifso ifnot predb) -> eval_condition cond rs##args m = Some b -> pc' = (if b then ifso else ifnot) -> step (State s f sp pc rs m) @@ -403,7 +404,7 @@ Definition successors_instr (i: instruction) : list node := | Icall sig ros args res s => s :: nil | Itailcall sig ros args => nil | Ibuiltin ef args res s => s :: nil - | Icond cond args ifso ifnot => ifso :: ifnot :: nil + | Icond cond args ifso ifnot _ => ifso :: ifnot :: nil | Ijumptable arg tbl => tbl | Ireturn optarg => nil end. @@ -424,7 +425,7 @@ Definition instr_uses (i: instruction) : list reg := | Itailcall sig (inl r) args => r :: args | Itailcall sig (inr id) args => args | Ibuiltin ef args res s => params_of_builtin_args args - | Icond cond args ifso ifnot => args + | Icond cond args ifso ifnot _ => args | Ijumptable arg tbl => arg :: nil | Ireturn None => nil | Ireturn (Some arg) => arg :: nil @@ -442,7 +443,7 @@ Definition instr_defs (i: instruction) : option reg := | Itailcall sig ros args => None | Ibuiltin ef args res s => match res with BR r => Some r | _ => None end - | Icond cond args ifso ifnot => None + | Icond cond args ifso ifnot _ => None | Ijumptable arg tbl => None | Ireturn optarg => None end. @@ -485,7 +486,7 @@ Definition max_reg_instr (m: positive) (pc: node) (i: instruction) := | Ibuiltin ef args res s => fold_left Pos.max (params_of_builtin_args args) (fold_left Pos.max (params_of_builtin_res res) m) - | Icond cond args ifso ifnot => fold_left Pos.max args m + | Icond cond args ifso ifnot _ => fold_left Pos.max args m | Ijumptable arg tbl => Pos.max arg m | Ireturn None => m | Ireturn (Some arg) => Pos.max arg m diff --git a/backend/RTLgen.v b/backend/RTLgen.v index 2c27944a..ac98f3a1 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -479,7 +479,7 @@ with transl_condexpr (map: mapping) (a: condexpr) (ntrue nfalse: node) match a with | CEcond c al => do rl <- alloc_regs map al; - do nt <- add_instr (Icond c rl ntrue nfalse); + do nt <- add_instr (Icond c rl ntrue nfalse None); transl_exprlist map al rl nt | CEcondition a b c => do nc <- transl_condexpr map c ntrue nfalse; diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 92b48e2b..30ad7d82 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -744,9 +744,9 @@ 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, + | tr_CEcond: forall map pr cond bl ns ntrue nfalse n1 rl i, tr_exprlist c map pr bl ns n1 rl -> - c!n1 = Some (Icond cond rl ntrue nfalse) -> + c!n1 = Some (Icond cond rl ntrue nfalse i) -> tr_condition c map pr (CEcond cond 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 -> diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 857f2211..15ed6d8a 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -139,11 +139,11 @@ Inductive wt_instr : instruction -> Prop := valid_successor s -> wt_instr (Ibuiltin ef args res s) | wt_Icond: - forall cond args s1 s2, + forall cond args s1 s2 i, map env args = type_of_condition cond -> valid_successor s1 -> valid_successor s2 -> - wt_instr (Icond cond args s1 s2) + wt_instr (Icond cond args s1 s2 i) | wt_Ijumptable: forall arg tbl, env arg = Tint -> @@ -313,7 +313,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv := | _ => type_builtin_args e args sig.(sig_args) end; type_builtin_res e1 res (proj_sig_res sig) - | Icond cond args s1 s2 => + | Icond cond args s1 s2 _ => do x1 <- check_successor s1; do x2 <- check_successor s2; S.set_list e args (type_of_condition cond) diff --git a/backend/Regalloc.ml b/backend/Regalloc.ml index f2658b04..ffe26933 100644 --- a/backend/Regalloc.ml +++ b/backend/Regalloc.ml @@ -295,8 +295,8 @@ let block_of_RTL_instr funsig tyenv = function (Xbuiltin(ef, args2, res2) :: movelist (params_of_builtin_res res2) (params_of_builtin_res res1) [Xbranch s]) - | RTL.Icond(cond, args, s1, s2) -> - [Xcond(cond, vregs tyenv args, s1, s2)] + | RTL.Icond(cond, args, s1, s2, i) -> + [Xcond(cond, vregs tyenv args, s1, s2, i)] | RTL.Ijumptable(arg, tbl) -> [Xjumptable(vreg tyenv arg, tbl)] | RTL.Ireturn None -> @@ -380,7 +380,7 @@ let live_before instr after = vset_addargs args (vset_removeres res after) | Xbranch s -> after - | Xcond(cond, args, s1, s2) -> + | Xcond(cond, args, s1, s2, _) -> List.fold_right VSet.add args after | Xjumptable(arg, tbl) -> VSet.add arg after @@ -575,7 +575,7 @@ let spill_costs f = charge_list 10 1 (params_of_builtin_res res) end | Xbranch _ -> () - | Xcond(cond, args, _, _) -> + | Xcond(cond, args, _, _, _) -> charge_list 10 1 args | Xjumptable(arg, _) -> charge 10 1 arg @@ -718,7 +718,7 @@ let add_interfs_instr g instr live = end | Xbranch s -> () - | Xcond(cond, args, s1, s2) -> + | Xcond(cond, args, s1, s2, _) -> add_interfs_destroyed g live (destroyed_by_cond cond) | Xjumptable(arg, tbl) -> add_interfs_destroyed g live destroyed_by_jumptable @@ -797,7 +797,7 @@ let tospill_instr alloc instr ts = (addlist_tospill alloc (params_of_builtin_res res) ts) | Xbranch s -> ts - | Xcond(cond, args, s1, s2) -> + | Xcond(cond, args, s1, s2, _) -> addlist_tospill alloc args ts | Xjumptable(arg, tbl) -> add_tospill alloc arg ts @@ -990,9 +990,9 @@ let spill_instr tospill eqs instr = (c1 @ Xbuiltin(ef, args', res') :: c2, eqs2) | Xbranch s -> ([instr], eqs) - | Xcond(cond, args, s1, s2) -> + | Xcond(cond, args, s1, s2, i) -> let (args', c1, eqs1) = reload_vars tospill eqs args in - (c1 @ [Xcond(cond, args', s1, s2)], eqs1) + (c1 @ [Xcond(cond, args', s1, s2, i)], eqs1) | Xjumptable(arg, tbl) -> let (arg', c1, eqs1) = reload_var tospill eqs arg in (c1 @ [Xjumptable(arg', tbl)], eqs1) @@ -1128,8 +1128,8 @@ let transl_instr alloc instr k = AST.map_builtin_res (mreg_of alloc) res) :: k | Xbranch s -> LTL.Lbranch s :: [] - | Xcond(cond, args, s1, s2) -> - LTL.Lcond(cond, mregs_of alloc args, s1, s2) :: [] + | Xcond(cond, args, s1, s2, i) -> + LTL.Lcond(cond, mregs_of alloc args, s1, s2, i) :: [] | Xjumptable(arg, tbl) -> LTL.Ljumptable(mreg_of alloc arg, tbl) :: [] | Xreturn optarg -> diff --git a/backend/Renumber.v b/backend/Renumber.v index 7ba16658..2727b979 100644 --- a/backend/Renumber.v +++ b/backend/Renumber.v @@ -48,7 +48,7 @@ Definition renum_instr (i: instruction) : instruction := | Icall sg ros args res s => Icall sg ros args res (renum_pc s) | Itailcall sg ros args => i | Ibuiltin ef args res s => Ibuiltin ef args res (renum_pc s) - | Icond cond args s1 s2 => Icond cond args (renum_pc s1) (renum_pc s2) + | Icond cond args s1 s2 info => Icond cond args (renum_pc s1) (renum_pc s2) info | Ijumptable arg tbl => Ijumptable arg (List.map renum_pc tbl) | Ireturn or => i end. diff --git a/backend/Splitting.ml b/backend/Splitting.ml index 78eb66a5..3ca45c3b 100644 --- a/backend/Splitting.ml +++ b/backend/Splitting.ml @@ -162,8 +162,8 @@ let ren_instr f maps pc i = | Ibuiltin(ef, args, res, s) -> Ibuiltin(ef, List.map (AST.map_builtin_arg (ren_reg before)) args, AST.map_builtin_res (ren_reg after) res, s) - | Icond(cond, args, s1, s2) -> - Icond(cond, ren_regs before args, s1, s2) + | Icond(cond, args, s1, s2, i) -> + Icond(cond, ren_regs before args, s1, s2, i) | Ijumptable(arg, tbl) -> Ijumptable(ren_reg before arg, tbl) | Ireturn optarg -> diff --git a/backend/Tunneling.v b/backend/Tunneling.v index da1ce45a..a4c4a195 100644 --- a/backend/Tunneling.v +++ b/backend/Tunneling.v @@ -78,11 +78,11 @@ Definition record_gotos (f: LTL.function) : U.t := Definition tunnel_instr (uf: U.t) (i: instruction) : instruction := match i with | Lbranch s => Lbranch (U.repr uf s) - | Lcond cond args s1 s2 => + | Lcond cond args s1 s2 info => let s1' := U.repr uf s1 in let s2' := U.repr uf s2 in if peq s1' s2' then Lbranch s1' - else Lcond cond args s1' s2' + else Lcond cond args s1' s2' info | Ljumptable arg tbl => Ljumptable arg (List.map (U.repr uf) tbl) | _ => i end. diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 1b5f2547..93ca7af4 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -53,7 +53,7 @@ Definition ref_instruction (i: instruction) : list ident := | Itailcall _ (inl r) _ => nil | Itailcall _ (inr id) _ => id :: nil | Ibuiltin _ args _ _ => globals_of_builtin_args args - | Icond cond _ _ _ => nil + | Icond cond _ _ _ _ => nil | Ijumptable _ _ => nil | Ireturn _ => nil end. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index e25d2e5f..2e79d1a9 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -156,7 +156,7 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : VA.Bot | Some(Ibuiltin ef args res s) => transfer_builtin ae am rm ef args res - | Some(Icond cond args s1 s2) => + | Some(Icond cond args s1 s2 _) => VA.State ae am | Some(Ijumptable arg tbl) => VA.State ae am diff --git a/backend/XTL.ml b/backend/XTL.ml index c496fafb..1d8e89c0 100644 --- a/backend/XTL.ml +++ b/backend/XTL.ml @@ -36,7 +36,7 @@ type instruction = | Xtailcall of signature * (var, ident) sum * var list | Xbuiltin of external_function * var builtin_arg list * var builtin_res | Xbranch of node - | Xcond of condition * var list * node * node + | Xcond of condition * var list * node * node * bool option | Xjumptable of var * node list | Xreturn of var list @@ -105,7 +105,7 @@ let twin_reg r = let rec successors_block = function | Xbranch s :: _ -> [s] | Xtailcall(sg, vos, args) :: _ -> [] - | Xcond(cond, args, s1, s2) :: _ -> [s1; s2] + | Xcond(cond, args, s1, s2, _) :: _ -> [s1; s2] | Xjumptable(arg, tbl) :: _ -> tbl | Xreturn _:: _ -> [] | instr :: blk -> successors_block blk @@ -179,7 +179,7 @@ let type_instr = function type_builtin_res res (proj_sig_res sg) | Xbranch s -> () - | Xcond(cond, args, s1, s2) -> + | Xcond(cond, args, s1, s2, _) -> set_vars_type args (type_of_condition cond) | Xjumptable(arg, tbl) -> set_var_type arg Tint diff --git a/backend/XTL.mli b/backend/XTL.mli index b4b77fab..7b7f7186 100644 --- a/backend/XTL.mli +++ b/backend/XTL.mli @@ -37,7 +37,7 @@ type instruction = | Xtailcall of signature * (var, ident) sum * var list | Xbuiltin of external_function * var builtin_arg list * var builtin_res | Xbranch of node - | Xcond of condition * var list * node * node + | Xcond of condition * var list * node * node * bool option | Xjumptable of var * node list | Xreturn of var list -- cgit From 4fe7ec168a9ce2c8c6e04d7f56729fd7a5758ce1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Mar 2020 17:30:37 +0100 Subject: [BROKEN] Started to change the trace selection --- backend/Duplicateaux.ml | 92 ++++++++++++++++++++----------------------------- 1 file changed, 38 insertions(+), 54 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 86bc06c9..c379faf3 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -2,19 +2,6 @@ open RTL open Maps open Camlcoq -(* TTL : IR emphasizing the preferred next node *) -module TTL = struct - type instruction = - | Tleaf of RTL.instruction - | Tnext of node * RTL.instruction - - type code = instruction PTree.t -end;; - -open TTL - -(** RTL to TTL *) - let get_some = function | None -> failwith "Did not get some" | Some thing -> thing @@ -242,37 +229,26 @@ let get_directions code entrypoint = !directions end -let to_ttl_inst direction = function -| Ireturn o -> Tleaf (Ireturn o) -| Inop n -> Tnext (n, Inop n) -| Iop (op, lr, r, n) -> Tnext (n, Iop(op, lr, r, n)) -| Iload (tm, m, a, lr, r, n) -> Tnext (n, Iload(tm, m, a, lr, r, n)) -| Istore (m, a, lr, r, n) -> Tnext (n, Istore(m, a, lr, r, n)) -| Icall (s, ri, lr, r, n) -> Tleaf (Icall(s, ri, lr, r, n)) -| Itailcall (s, ri, lr) -> Tleaf (Itailcall(s, ri, lr)) -| Ibuiltin (ef, lbr, br, n) -> Tleaf (Ibuiltin(ef, lbr, br, n)) -| Icond (cond, lr, n, n', i) -> (match direction with - | false -> Tnext (n', Icond(cond, lr, n, n', i)) - | true -> Tnext (n, Icond(cond, lr, n, n', i))) -| Ijumptable (r, ln) -> Tleaf (Ijumptable(r, ln)) - -let rec to_ttl_code_rec directions = function +let update_direction direction = function +| Icond (cond, lr, n, n', _) -> Icond (cond, lr, n, n', Some direction) +| i -> i + +let rec update_direction_rec directions = function | [] -> PTree.empty | m::lm -> let (n, i) = m in let direction = get_some @@ PTree.get n directions - in PTree.set n (to_ttl_inst direction i) (to_ttl_code_rec directions lm) + in PTree.set n (update_direction direction i) (update_direction_rec directions lm) -let to_ttl_code code entrypoint = +let update_directions code entrypoint = let directions = get_directions code entrypoint in begin (* Printf.printf "Ifso directions: "; ptree_printbool directions; Printf.printf "\n"; *) - Random.init(0); (* using same seed to make it deterministic *) - to_ttl_code_rec directions (PTree.elements code) + update_direction_rec directions (PTree.elements code) end -(** Trace selection on TTL *) +(** Trace selection *) let rec exists_false_rec = function | [] -> false @@ -280,7 +256,7 @@ let rec exists_false_rec = function let exists_false boolmap = exists_false_rec (PTree.elements boolmap) -(* DFS on TTL to guide the exploration *) +(* DFS using prediction info to guide the exploration *) let dfs code entrypoint = let visited = ref (PTree.map (fun n i -> false) code) in let rec dfs_list code = function @@ -291,22 +267,21 @@ let dfs code entrypoint = visited := PTree.set node true !visited; match PTree.get node code with | None -> failwith "No such node" - | Some ti -> [node] @ match ti with - | Tleaf i -> (match i with - | Icall(_, _, _, _, n) -> dfs_list code [n] - | Ibuiltin(_, _, _, n) -> dfs_list code [n] - | Ijumptable(_, ln) -> dfs_list code ln - | Itailcall _ | Ireturn _ -> [] - | _ -> failwith "Tleaf case not handled in dfs" ) - | Tnext (n,i) -> (dfs_list code [n]) @ match i with - | Icond (_, _, n1, n2, _) -> dfs_list code [n1; n2] - | Inop _ | Iop _ | Iload _ | Istore _ -> [] - | _ -> failwith "Tnext case not handled in dfs" + | Some i -> [node] @ match i with + | Icall(_, _, _, _, n) -> dfs_list code [n] + | Ibuiltin(_, _, _, n) -> dfs_list code [n] + | Ijumptable(_, ln) -> dfs_list code ln + | Itailcall _ | Ireturn _ -> [] + | Inop _ | Iop _ | Iload _ | Istore _ -> [] + | Icond (_, _, n1, n2, info) -> match info with + | Some false -> dfs_list code [n2; n1] + | _ -> dfs_list code [n1; n2] end else [] in node_dfs @ (dfs_list code ln) in dfs_list code [entrypoint] +(* let get_predecessors_ttl code = let preds = ref (PTree.map (fun n i -> []) code) in let process_inst (node, ti) = match ti with @@ -322,8 +297,7 @@ let get_predecessors_ttl code = List.iter process_inst (PTree.elements code); !preds end - -let rtl_proj code = PTree.map (fun n ti -> match ti with Tleaf i | Tnext(_, i) -> i) code +*) let rec select_unvisited_node is_visited = function | [] -> failwith "Empty list" @@ -332,11 +306,21 @@ let rec select_unvisited_node is_visited = function let best_successor_of node code is_visited = match (PTree.get node code) with | None -> failwith "No such node in the code" - | Some ti -> match ti with - | Tleaf _ -> None - | Tnext (n,_) -> if not (ptree_get_some n is_visited) then Some n - else None - + | 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 + | Icond (_, _, n1, n2, ob) -> (match ob with None -> None | Some false -> Some n2 | Some true -> Some n1) + | _ -> None + in match next_node with + | None -> None + | 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 = match (PTree.get node predecessors) with | None -> failwith "No predecessor list found" @@ -347,7 +331,7 @@ let best_predecessor_of node predecessors order is_visited = * "Trace Selection for Compiling Large C Application Programs to Microcode" *) let select_traces code entrypoint = let order = dfs code entrypoint in - let predecessors = get_predecessors_ttl code 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 *) while exists_false !is_visited do (* while (there are unvisited nodes) *) @@ -524,7 +508,7 @@ let rec invert_iconds code = function let duplicate_aux f = let entrypoint = f.fn_entrypoint in let code = f.fn_code in - let traces = select_traces (to_ttl_code code entrypoint) entrypoint in + let traces = select_traces code entrypoint in let icond_code = invert_iconds code traces in let preds = get_predecessors_rtl icond_code in if !Clflags.option_fduplicate >= 1 then -- cgit From c77d6412f132bf6c09189e5f2d3c8799440f1977 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 12 Mar 2020 14:25:30 +0100 Subject: Fixed typo in Duplicate: dfs --- backend/Duplicateaux.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index c379faf3..cabcf1fd 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -270,9 +270,12 @@ let dfs code entrypoint = | Some i -> [node] @ match i with | Icall(_, _, _, _, n) -> dfs_list code [n] | Ibuiltin(_, _, _, n) -> dfs_list code [n] + | Iop (_, _, _, n) -> dfs_list code [n] + | Iload (_, _, _, _, _, n) -> dfs_list code [n] + | Istore (_, _, _, _, n) -> dfs_list code [n] + | Inop n -> dfs_list code [n] | Ijumptable(_, ln) -> dfs_list code ln | Itailcall _ | Ireturn _ -> [] - | Inop _ | Iop _ | Iload _ | Istore _ -> [] | Icond (_, _, n1, n2, info) -> match info with | Some false -> dfs_list code [n2; n1] | _ -> dfs_list code [n1; n2] -- cgit From 786ada1bd193e3995b948e2bd11d6285654a5c6a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 12 Mar 2020 16:08:47 +0100 Subject: Correcting a few bugs in trace selection and expansion --- backend/Duplicateaux.ml | 15 +++++++-------- backend/Linearizeaux.ml | 20 +++++++++++++------- 2 files changed, 20 insertions(+), 15 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index cabcf1fd..37647714 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -198,9 +198,8 @@ let do_loop_heuristic code cond ifso ifnot is_loop_header = let get_directions code entrypoint = let bfs_order = bfs code entrypoint and is_loop_header = get_loop_headers code entrypoint - and directions = ref (PTree.map (fun n i -> false) code) (* false <=> fallthru *) + and directions = ref (PTree.map (fun n i -> None) code) (* None <=> no predicted direction *) in begin - (* Printf.printf "Loop headers: "; *) (* ptree_printbool is_loop_header; *) (* Printf.printf "\n"; *) List.iter (fun n -> @@ -217,11 +216,10 @@ let get_directions code entrypoint = | None -> preferred := do_heur code cond ifso ifnot is_loop_header | Some _ -> () ) heuristics; - (match !preferred with None -> (Printf.printf "\tRANDOM\n"; preferred := Some (Random.bool ())) | Some _ -> ()); - directions := PTree.set n (get_some !preferred) !directions; + directions := PTree.set n !preferred !directions; (match !preferred with | Some false -> Printf.printf "\tFALLTHROUGH\n" - | Some true -> Printf.printf "\tBRANCH\n" - | None -> ()); + | Some true -> Printf.printf "\tBRANCH\n" + | None -> Printf.printf "\tUNSURE\n"); Printf.printf "---------------------------------------\n" end | _ -> () @@ -230,7 +228,7 @@ let get_directions code entrypoint = end let update_direction direction = function -| Icond (cond, lr, n, n', _) -> Icond (cond, lr, n, n', Some direction) +| Icond (cond, lr, n, n', _) -> Icond (cond, lr, n, n', direction) | i -> i let rec update_direction_rec directions = function @@ -239,6 +237,7 @@ let rec update_direction_rec directions = function in let direction = get_some @@ PTree.get n directions in PTree.set n (update_direction direction i) (update_direction_rec directions lm) +(* Uses branch prediction to write prediction annotations in Icond *) let update_directions code entrypoint = let directions = get_directions code entrypoint in begin @@ -510,7 +509,7 @@ let rec invert_iconds code = function let duplicate_aux f = let entrypoint = f.fn_entrypoint in - let code = f.fn_code in + let code = update_directions (f.fn_code) entrypoint in let traces = select_traces code entrypoint in let icond_code = invert_iconds code traces in let preds = get_predecessors_rtl icond_code in diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index c9a5d620..5b3384f2 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -154,7 +154,7 @@ let forward_sequences code entry = let visited = ref (PTree.map (fun n i -> false) code) 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); *) + Printf.printf "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 @@ -163,12 +163,13 @@ let forward_sequences code entry = let ln, rem = match (last_element bb) with | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ | Lbuiltin _ -> assert false - | Ltailcall _ | Lreturn -> ([], []) + | Ltailcall _ | Lreturn -> begin Printf.printf "STOP tailcall/return\n"; ([], []) end | Lbranch n -> let ln, rem = traverse_fallthrough code n in (ln, rem) - | Lcond (_, _, ifso, ifnot, _) -> let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) - | Ljumptable(_, ln) -> match ln with - | [] -> ([], []) - | n :: ln -> let lln, rem = traverse_fallthrough code n in (lln, ln @ rem) + | Lcond (_, _, ifso, ifnot, info) -> (match info with + | None -> begin Printf.printf "STOP Lcond None\n"; ([], [ifso; ifnot]) end + | Some false -> let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) + | Some true -> failwith "Inconsistency detected: ifnot is not the preferred branch") + | Ljumptable(_, ln) -> begin Printf.printf "STOP Ljumptable\n"; ([], ln) end in ([node] @ ln, rem) end else ([], []) @@ -179,6 +180,7 @@ let forward_sequences code entry = in [fs] @ ((f code rem_from_node) @ (f code ln)) in (f code [entry]) +(** Unused code module PInt = struct type t = P.t let compare x y = compare (P.to_int x) (P.to_int y) @@ -219,7 +221,10 @@ let can_be_merged code s s' = | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ | Lbuiltin _ | Ltailcall _ | Lreturn -> false | Lbranch n -> n == first_s' - | Lcond (_, _, ifso, ifnot, _) -> ifnot == first_s' + | Lcond (_, _, ifso, ifnot, info) -> (match info with + | None -> false + | Some false -> ifnot == first_s' + | Some true -> failwith "Inconsistency detected - ifnot is not the preferred branch") | Ljumptable (_, ln) -> match ln with | [] -> false @@ -256,6 +261,7 @@ let try_merge code (fs: (BinNums.positive list) list) = end done; !seqs +*) (** Code adapted from Duplicateaux.get_loop_headers * -- cgit From dd345b4fd33a9e59507029f30da9a09d5e450db6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 13 Mar 2020 14:13:16 +0100 Subject: Added prediction info in the printers --- backend/PrintLTL.ml | 5 +++-- backend/PrintRTL.ml | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/backend/PrintLTL.ml b/backend/PrintLTL.ml index f173e374..d8f2ac12 100644 --- a/backend/PrintLTL.ml +++ b/backend/PrintLTL.ml @@ -83,10 +83,11 @@ let print_instruction pp succ = function (print_builtin_args loc) args | Lbranch s -> print_succ pp s succ - | Lcond(cond, args, s1, s2, _) -> - fprintf pp "if (%a) goto %d else goto %d" + | Lcond(cond, args, s1, s2, info) -> + fprintf pp "if (%a) goto %d else goto %d (prediction: %s)" (print_condition mreg) (cond, args) (P.to_int s1) (P.to_int s2) + (match info with None -> "none" | Some true -> "branch" | Some false -> "fallthrough") | Ljumptable(arg, tbl) -> let tbl = Array.of_list tbl in fprintf pp "jumptable (%a)" mreg arg; diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml index 5eab9901..b2ef05ca 100644 --- a/backend/PrintRTL.ml +++ b/backend/PrintRTL.ml @@ -75,10 +75,11 @@ let print_instruction pp (pc, i) = (name_of_external ef) (print_builtin_args reg) args; print_succ pp s (pc - 1) - | Icond(cond, args, s1, s2, _) -> - fprintf pp "if (%a) goto %d else goto %d\n" + | Icond(cond, args, s1, s2, info) -> + fprintf pp "if (%a) goto %d else goto %d (prediction: %s)\n" (PrintOp.print_condition reg) (cond, args) (P.to_int s1) (P.to_int s2) + (match info with None -> "none" | Some true -> "branch" | Some false -> "fallthrough") | Ijumptable(arg, tbl) -> let tbl = Array.of_list tbl in fprintf pp "jumptable (%a)\n" reg arg; -- cgit From afa0407bc6474cbb1b519544ec0386ba7502ca62 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 13 Mar 2020 14:13:52 +0100 Subject: More helpful debug info in linearize --- backend/Linearizeaux.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 5b3384f2..23ced4c2 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -168,7 +168,9 @@ let forward_sequences code entry = | Lcond (_, _, ifso, ifnot, info) -> (match info with | None -> begin Printf.printf "STOP Lcond None\n"; ([], [ifso; ifnot]) end | Some false -> let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) - | Some true -> failwith "Inconsistency detected: ifnot is not the preferred branch") + | 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 in ([node] @ ln, rem) end -- cgit From 5d1b51ae43e3b2784805aae60144870a6f14b6e0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 13 Mar 2020 14:14:02 +0100 Subject: Fixing bug where conditions were not necessarily inverted --- backend/Duplicateaux.ml | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 37647714..c2839bc3 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -329,6 +329,18 @@ let best_predecessor_of node predecessors order is_visited = | Some lp -> try Some (List.find (fun n -> (List.mem n lp) && (not (ptree_get_some n is_visited))) order) with Not_found -> None +let print_trace t = print_intlist t + +let print_traces traces = + let rec f = function + | [] -> () + | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt + in begin + Printf.printf "Traces: {"; + f traces; + Printf.printf "}\n"; + end + (* Algorithm mostly inspired from Chang and Hwu 1988 * "Trace Selection for Compiling Large C Application Programs to Microcode" *) let select_traces code entrypoint = @@ -369,21 +381,10 @@ let select_traces code entrypoint = end done; (* Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; *) + Printf.printf "Traces: "; print_traces !traces; !traces end -let print_trace t = print_intlist t - -let print_traces traces = - let rec f = function - | [] -> () - | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt - in begin - Printf.printf "Traces: {"; - f traces; - Printf.printf "}\n"; - end - let rec make_identity_ptree_rec = function | [] -> PTree.empty | m::lm -> let (n, _) = m in PTree.set n n (make_identity_ptree_rec lm) @@ -487,18 +488,16 @@ let superblockify_traces code preds traces = let rec invert_iconds_trace code = function | [] -> code - | n::[] -> code - | n :: n' :: t -> + | n :: ln -> let code' = match ptree_get_some n code with - | Icond (c, lr, ifso, ifnot, i) -> - assert (n' == ifso || n' == ifnot); - if (n' == ifso) then ( - (* Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); *) - let i' = match i with None -> None | Some b -> Some (not b) in - PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso, i')) code ) - else code + | 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); *) + PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso, Some false)) code + end + | _ -> code) | _ -> code - in invert_iconds_trace code' (n'::t) + in invert_iconds_trace code' ln let rec invert_iconds code = function | [] -> code -- cgit From 192d5f379b3f1efa6f12b45af36f7cfea21d6d50 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 15 Mar 2020 00:00:33 +0100 Subject: more inlining --- backend/Inliningaux.ml | 9 ++++++--- driver/Clflags.ml | 1 + driver/Driver.ml | 2 ++ 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/backend/Inliningaux.ml b/backend/Inliningaux.ml index d58704ca..cf308962 100644 --- a/backend/Inliningaux.ml +++ b/backend/Inliningaux.ml @@ -17,7 +17,8 @@ open Maps open Op open Ordered open! RTL - +open Camlcoq + module PSet = Make(OrderedPositive) type inlining_info = { @@ -83,13 +84,15 @@ let static_called_once id io = else false -(* To be considered: heuristics based on size of function? *) +(* D. Monniaux: attempt at heuristic based on size *) +let small_enough (f : coq_function) = + P.to_int (RTL.max_pc_function f) <= !Clflags.option_inline_auto_threshold let should_inline (io: inlining_info) (id: ident) (f: coq_function) = if !Clflags.option_finline then begin match C2C.atom_inline id with | C2C.Inline -> true | C2C.Noinline -> false - | C2C.No_specifier -> static_called_once id io + | C2C.No_specifier -> static_called_once id io || small_enough f end else false diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 79c0bce0..ee5e9eeb 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -81,3 +81,4 @@ let option_faddx = ref false 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 30 diff --git a/driver/Driver.ml b/driver/Driver.ml index 43aedf50..01451e07 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -190,6 +190,7 @@ Processing options: -Os Optimize for code size in preference to code speed -Obranchless Optimize to generate fewer conditional branches; try to produce branch-free instruction sequences as much as possible + -finline-auto-threshold n Inline functions under size n -ftailcalls Optimize function calls in tail position [on] -fconst-prop Perform global constant propagation [on] -ffloat-const-prop Control constant propagation of floats @@ -322,6 +323,7 @@ let cmdline_actions = _Regexp "-O[123]$", Unit (set_all optimization_options); Exact "-Os", Set option_Osize; Exact "-Obranchless", Set option_Obranchless; + 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); Exact "-ffloat-const-prop", Integer(fun n -> option_ffloatconstprop := n); -- cgit From d0326db1105704e02e2b40facc2a85a267a2b9b5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 15 Mar 2020 09:18:02 +0100 Subject: by default do not inline much --- driver/Clflags.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index ee5e9eeb..8054eb5b 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -81,4 +81,4 @@ let option_faddx = ref false 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 30 +let option_inline_auto_threshold = ref 0 -- cgit From 1b111e3658b3f79a9814fd9799e2dbe0a921c768 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 17 Mar 2020 00:11:42 +0100 Subject: specify prefix with CCOMP_INSTALL_PREFIX --- config_simple.sh | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/config_simple.sh b/config_simple.sh index f02680c4..e2d3844c 100755 --- a/config_simple.sh +++ b/config_simple.sh @@ -3,4 +3,9 @@ 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 + +if test "x$CCOMP_INSTALL_PREFIX" = "x" ; +then CCOMP_INSTALL_PREFIX=/opt/CompCert ; +fi + +./configure --prefix ${CCOMP_INSTALL_PREFIX}/${branch}/${date}_${version}/$arch "$@" $arch -- cgit From fac63511aaf3fd3c77db69802c24474559365879 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 17 Mar 2020 07:44:45 +0100 Subject: fix for aarch64 DuplicateOpcodeHeuristic.ml --- aarch64/DuplicateOpcodeHeuristic.ml | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/aarch64/DuplicateOpcodeHeuristic.ml b/aarch64/DuplicateOpcodeHeuristic.ml index 85505245..5fc2156c 100644 --- a/aarch64/DuplicateOpcodeHeuristic.ml +++ b/aarch64/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,27 @@ -exception HeuristicSucceeded - -let opcode_heuristic code cond ifso ifnot preferred = () +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 + -- cgit From 0ebdbc31c3e992e43d85699a039ebdd23e272df6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 17 Mar 2020 07:49:46 +0100 Subject: DuplicateOpcodeHeuristic for ARM --- arm/DuplicateOpcodeHeuristic.ml | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/arm/DuplicateOpcodeHeuristic.ml b/arm/DuplicateOpcodeHeuristic.ml index 85505245..9b6a6409 100644 --- a/arm/DuplicateOpcodeHeuristic.ml +++ b/arm/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,22 @@ -exception HeuristicSucceeded - -let opcode_heuristic code cond ifso ifnot preferred = () +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 + | 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 + -- cgit From 2f19071e865181d9a0c2e61f5e57731fb86e4e5d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 17 Mar 2020 07:57:56 +0100 Subject: riscV/DuplicateOpcodeHeuristic.ml --- config_rv64.sh | 2 +- riscV/DuplicateOpcodeHeuristic.ml | 30 +++++++++++++++++++++++++++--- 2 files changed, 28 insertions(+), 4 deletions(-) diff --git a/config_rv64.sh b/config_rv64.sh index e95f8a70..0698c2ff 100755 --- a/config_rv64.sh +++ b/config_rv64.sh @@ -1 +1 @@ -exec ./config_simple.sh rv64-linux --toolprefix riscv64-unknown-elf- "$@" +exec ./config_simple.sh rv64-linux --toolprefix riscv64-linux-gnu- "$@" diff --git a/riscV/DuplicateOpcodeHeuristic.ml b/riscV/DuplicateOpcodeHeuristic.ml index 85505245..2ec314c1 100644 --- a/riscV/DuplicateOpcodeHeuristic.ml +++ b/riscV/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,27 @@ -exception HeuristicSucceeded - -let opcode_heuristic code cond ifso ifnot preferred = () +(* 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 -- cgit From 0eb778a85b5b76ab6c7fd914ffaff1affcbde7bb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 17 Mar 2020 08:05:17 +0100 Subject: DuplicateOpcodeHeuristic ppc --- powerpc/DuplicateOpcodeHeuristic.ml | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/powerpc/DuplicateOpcodeHeuristic.ml b/powerpc/DuplicateOpcodeHeuristic.ml index 85505245..33be79e8 100644 --- a/powerpc/DuplicateOpcodeHeuristic.ml +++ b/powerpc/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,27 @@ -exception HeuristicSucceeded - -let opcode_heuristic code cond ifso ifnot preferred = () +(* 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 -> (match c with + | Ceq -> Some false + | Cne -> Some true + | _ -> None + ) + | Cnotcompf c -> (match c with + | Ceq -> Some true + | Cne -> Some false + | _ -> None + ) + | _ -> None -- cgit From aa2e3d776cb82ce01c4afdbacc52951e60ff2104 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 17 Mar 2020 08:10:26 +0100 Subject: DuplicateOpcodeHeuristic x86 --- x86/DuplicateOpcodeHeuristic.ml | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/x86/DuplicateOpcodeHeuristic.ml b/x86/DuplicateOpcodeHeuristic.ml index 85505245..2ec314c1 100644 --- a/x86/DuplicateOpcodeHeuristic.ml +++ b/x86/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,27 @@ -exception HeuristicSucceeded - -let opcode_heuristic code cond ifso ifnot preferred = () +(* 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 -- cgit From fb43d1078c0b0824132b30d7dd9bfe6b0ac47122 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 17 Mar 2020 15:12:06 +0100 Subject: Desactivating branch predictions by default --- backend/Duplicateaux.ml | 18 +++++++++++------- driver/Clflags.ml | 2 +- driver/Driver.ml | 6 +++++- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 209527b9..a84f9754 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -502,11 +502,15 @@ let rec invert_iconds code = function let duplicate_aux f = let entrypoint = f.fn_entrypoint in let code = f.fn_code in - let traces = select_traces (to_ttl_code code entrypoint) entrypoint in - let icond_code = invert_iconds code traces in - let preds = get_predecessors_rtl icond_code in - if !Clflags.option_fduplicate >= 1 then - let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in - ((new_code, f.fn_entrypoint), pTreeId) + if !Clflags.option_fduplicate < 0 then + ((code, entrypoint), make_identity_ptree code) else - ((icond_code, entrypoint), make_identity_ptree code) + let traces = select_traces (to_ttl_code code entrypoint) entrypoint in + let icond_code = invert_iconds code traces in + let preds = get_predecessors_rtl icond_code in + if !Clflags.option_fduplicate >= 1 then + let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in + ((new_code, f.fn_entrypoint), pTreeId) + else + ((icond_code, entrypoint), make_identity_ptree code) + diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 8054eb5b..6986fb96 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -28,7 +28,7 @@ let option_fconstprop = ref true let option_fcse = ref true let option_fcse2 = ref true let option_fredundancy = ref true -let option_fduplicate = ref 0 +let option_fduplicate = ref (-1) let option_finvertcond = ref true let option_ftracelinearize = ref false let option_fpostpass = ref true diff --git a/driver/Driver.ml b/driver/Driver.ml index 01451e07..388482a0 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -201,7 +201,11 @@ Processing options: -fpostpass Perform postpass scheduling (only for K1 architecture) [on] -fpostpass= Perform postpass scheduling with the specified optimization [list] (=list: list scheduling, =ilp: ILP, =greedy: just packing bundles) - -fduplicate Perform tail duplication to form superblocks on predicted traces + -fduplicate Perform tail duplication to form superblocks on predicted traces + nb_nodes control the heuristic deciding to duplicate or not + A value of -1 desactivates the entire pass (including branch prediction) + A value of 0 desactivates the duplication (but activates the branch prediction) + FIXME : this is desactivated by default for now -finvertcond Invert conditions based on predicted paths (to prefer fallthrough). Requires -fduplicate to be also activated [on] -ftracelinearize Linearizes based on the traces identified by duplicate phase -- cgit From 75be7f9206e495966fdc8c409007a2bcadedddbe Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Mar 2020 15:28:48 +0100 Subject: Adding trace printf at start of some functions --- backend/Duplicateaux.ml | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 1548765e..99a2d9e3 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -6,7 +6,8 @@ let get_some = function | None -> failwith "Did not get some" | Some thing -> thing -let bfs code entrypoint = +let bfs code entrypoint = begin + Printf.printf "bfs\n"; flush stdout; let visited = ref (PTree.map (fun n i -> false) code) and bfs_list = ref [] and to_visit = Queue.create () @@ -32,6 +33,7 @@ let bfs code entrypoint = done; !bfs_list end +end let optbool o = match o with Some _ -> true | None -> false @@ -91,7 +93,8 @@ 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 = +let get_loop_headers code entrypoint = begin + Printf.printf "get_loop_headers\n"; flush stdout; 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 @@ -121,6 +124,7 @@ let get_loop_headers code entrypoint = dfs_visit code [entrypoint]; !is_loop_header end +end let ptree_printbool pt = let elements = PTree.elements pt @@ -195,7 +199,8 @@ let do_loop_heuristic code cond ifso ifnot is_loop_header = else None end -let get_directions code entrypoint = +let get_directions code entrypoint = begin + Printf.printf "get_directions\n"; flush stdout; let bfs_order = bfs code entrypoint and is_loop_header = get_loop_headers code entrypoint and directions = ref (PTree.map (fun n i -> None) code) (* None <=> no predicted direction *) @@ -226,6 +231,7 @@ let get_directions code entrypoint = ) bfs_order; !directions end +end let update_direction direction = function | Icond (cond, lr, n, n', _) -> Icond (cond, lr, n, n', direction) @@ -238,7 +244,8 @@ let rec update_direction_rec directions = function in PTree.set n (update_direction direction i) (update_direction_rec directions lm) (* Uses branch prediction to write prediction annotations in Icond *) -let update_directions code entrypoint = +let update_directions code entrypoint = begin + Printf.printf "Update_directions\n"; flush stdout; let directions = get_directions code entrypoint in begin (* Printf.printf "Ifso directions: "; @@ -246,6 +253,7 @@ let update_directions code entrypoint = Printf.printf "\n"; *) update_direction_rec directions (PTree.elements code) end +end (** Trace selection *) @@ -343,7 +351,8 @@ let print_traces traces = (* Algorithm mostly inspired from Chang and Hwu 1988 * "Trace Selection for Compiling Large C Application Programs to Microcode" *) -let select_traces code entrypoint = +let select_traces code entrypoint = begin + Printf.printf "select_traces\n"; flush stdout; let order = dfs code entrypoint in let predecessors = get_predecessors_rtl code in let traces = ref [] in @@ -384,6 +393,7 @@ let select_traces code entrypoint = Printf.printf "Traces: "; print_traces !traces; !traces end +end let rec make_identity_ptree_rec = function | [] -> PTree.empty -- cgit From d4002956b3fbe9085e685e0c596f776ecfcdafd7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Mar 2020 15:29:09 +0100 Subject: Correcting inefficiency in Duplicateaux::bfs --- backend/Duplicateaux.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 99a2d9e3..3ffe9aed 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -21,7 +21,7 @@ let bfs code entrypoint = begin match PTree.get !node code with | None -> failwith "No such node" | Some i -> - bfs_list := !bfs_list @ [!node]; + bfs_list := !node :: !bfs_list; match i with | Icall(_, _, _, _, n) -> Queue.add n to_visit | Ibuiltin(_, _, _, n) -> Queue.add n to_visit @@ -31,7 +31,7 @@ let bfs code entrypoint = begin | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) -> Queue.add n to_visit end done; - !bfs_list + List.rev !bfs_list end end -- cgit From c6f8888aa89cfa86a9d61ecdc8d030cc8710ab6d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Mar 2020 15:46:19 +0100 Subject: Fixing inefficient implementation of Duplicateaux.dfs --- backend/Duplicateaux.ml | 42 ++++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 3ffe9aed..ae0c6252 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -39,7 +39,8 @@ 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 = +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 @@ -56,6 +57,7 @@ let get_predecessors_rtl code = List.iter process_inst (PTree.elements code); !preds end +end module PInt = struct type t = P.t @@ -264,32 +266,28 @@ let rec exists_false_rec = function let exists_false boolmap = exists_false_rec (PTree.elements boolmap) (* DFS using prediction info to guide the exploration *) -let dfs code entrypoint = +let dfs code entrypoint = begin + Printf.printf "dfs\n"; flush stdout; let visited = ref (PTree.map (fun n i -> false) code) in let rec dfs_list code = function | [] -> [] | node :: ln -> - let node_dfs = - if not (get_some @@ PTree.get node !visited) then begin - visited := PTree.set node true !visited; - match PTree.get node code with - | None -> failwith "No such node" - | Some i -> [node] @ match i with - | Icall(_, _, _, _, n) -> dfs_list code [n] - | Ibuiltin(_, _, _, n) -> dfs_list code [n] - | Iop (_, _, _, n) -> dfs_list code [n] - | Iload (_, _, _, _, _, n) -> dfs_list code [n] - | Istore (_, _, _, _, n) -> dfs_list code [n] - | Inop n -> dfs_list code [n] - | Ijumptable(_, ln) -> dfs_list code ln - | Itailcall _ | Ireturn _ -> [] - | Icond (_, _, n1, n2, info) -> match info with - | Some false -> dfs_list code [n2; n1] - | _ -> dfs_list code [n1; n2] - end - else [] - in node_dfs @ (dfs_list code ln) + if get_some @@ PTree.get node !visited then dfs_list code ln + else begin + visited := PTree.set node true !visited; + let next_nodes = (match get_some @@ PTree.get node code with + | Icall(_, _, _, _, n) | Ibuiltin (_, _, _, n) | Iop (_, _, _, n) + | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) | Inop n -> [n] + | Ijumptable (_, ln) -> ln + | Itailcall _ | Ireturn _ -> [] + | Icond (_, _, n1, n2, info) -> (match info with + | Some false -> [n2; n1] + | _ -> [n1; n2] + ) + ) in node :: dfs_list code (next_nodes @ ln) + end in dfs_list code [entrypoint] +end (* let get_predecessors_ttl code = -- cgit From 66f96f7b3f84bf011be40b672e864c5c0f913f02 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 19 Mar 2020 12:02:52 +0100 Subject: New algo for Duplicateaux.select_traces in O(n) --- backend/Duplicateaux.ml | 75 ++++++++++++++++++++----------------------------- 1 file changed, 30 insertions(+), 45 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index ae0c6252..91d313f7 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -52,9 +52,11 @@ let get_predecessors_rtl code = begin 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 () - else preds := PTree.set s (node::previous_preds) !preds) succ + else preds := PTree.set s (node::previous_preds) !preds) + succ in begin List.iter process_inst (PTree.elements code); + Printf.printf "get_predecessors_rtl done\n"; flush stdout; !preds end end @@ -329,10 +331,10 @@ 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 order = 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) + | Some lp -> try Some (List.find (fun n -> List.mem n lp) order) with Not_found -> None let print_trace t = print_intlist t @@ -347,51 +349,34 @@ let print_traces traces = Printf.printf "}\n"; end -(* Algorithm mostly inspired from Chang and Hwu 1988 - * "Trace Selection for Compiling Large C Application Programs to Microcode" *) -let select_traces code entrypoint = begin - Printf.printf "select_traces\n"; flush stdout; - 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 *) - 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 - let current = ref seed in begin - is_visited := PTree.set seed true !is_visited; (* mark seed visited *) - let quit_loop = ref false in begin - while not !quit_loop do - let s = best_successor_of !current code !is_visited in - match s with - | None -> quit_loop := true (* if (s==0) exit loop *) - | Some succ -> begin - trace := !trace @ [succ]; - is_visited := PTree.set succ true !is_visited; (* mark s visited *) - current := succ - end - done; - current := seed; - quit_loop := false; - while not !quit_loop do - let s = best_predecessor_of !current predecessors order !is_visited in - match s with - | None -> quit_loop := true (* if (s==0) exit loop *) - | Some pred -> begin - trace := pred :: !trace; - is_visited := PTree.set pred true !is_visited; (* mark s visited *) - current := pred - end - done; - traces := !trace :: !traces; - end - end - done; - (* Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; *) +let select_traces code entrypoint = + let is_visited = ref (PTree.map (fun n i -> false) code) in + let bfs_order = bfs code entrypoint in + let rec go_through node = begin + is_visited := PTree.set node true !is_visited; + let next_node = match (get_some @@ PTree.get node code) with + | Icall(_, _, _, _, n) | Ibuiltin (_, _, _, n) | Iop (_, _, _, n) + | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) | Inop n -> Some n + | Ijumptable _ | Itailcall _ | Ireturn _ -> None + | Icond (_, _, n1, n2, info) -> (match info with + | Some false -> Some n2 + | Some true -> Some n1 + | None -> None + ) + in match next_node with + | None -> [node] + | Some n -> + if not (get_some @@ PTree.get n !is_visited) then node :: go_through n + else [node] + end + in let traces = ref [] in begin + List.iter (fun n -> + if not (get_some @@ PTree.get n !is_visited) then + traces := (go_through n) :: !traces + ) bfs_order; Printf.printf "Traces: "; print_traces !traces; !traces end -end let rec make_identity_ptree_rec = function | [] -> PTree.empty -- cgit From 88d3af62f4d0ed5f400c1e8690343a7a9ad15fe3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 05:59:01 +0100 Subject: progress in RA invariants --- mppa_k1c/Asmblockgenproof1.v | 47 ++++++++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 5b44ddaa..6a3f2389 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1517,21 +1517,21 @@ Opaque Int.eq. - (* Ocast8signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. - split; intros; simpl; Simpl. + repeat split; intros; simpl; Simpl. assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Ocast16signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. - split; intros; Simpl. + repeat split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. - + split. + + repeat split. * rewrite Pregmap.gss. subst v. destruct (rs x0); simpl; trivial. @@ -1542,7 +1542,7 @@ Opaque Int.eq. - (* Oshrxlimm *) econstructor; split. + apply exec_straight_one. simpl. eauto. - + split. + + repeat split. * rewrite Pregmap.gss. subst v. destruct (rs x0); simpl; trivial. @@ -1553,7 +1553,7 @@ Opaque Int.eq. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. eauto with asmgen. + exists rs'; repeat split; eauto with asmgen. - (* Osel *) unfold conditional_move in *. @@ -1572,24 +1572,25 @@ Opaque Int.eq. destruct c0; simpl in *. - all: - destruct c; simpl in *; inv EQ2; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - unfold cmove, cmoveu; - rewrite Pregmap.gss; - destruct (rs x1); simpl; trivial; - try rewrite int_ltu_to_neq; - try rewrite int64_ltu_to_neq; - try change (Int64.eq Int64.zero Int64.zero) with true; - try destruct Archi.ptr64; - repeat rewrite if_neg; - simpl; - trivial; - try destruct (_ || _); - trivial; - try apply Val.lessdef_normalize. + all: destruct c. + all: simpl in *. + all: inv EQ2. + all: try (econstructor; split; [idtac | split ]). + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x1); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. - (* Oselimm *) unfold conditional_move_imm32 in *. -- cgit From 5e05d4acc53b4b098cb55006b8daa32149d7fba4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 06:16:12 +0100 Subject: more understandabe proofs --- mppa_k1c/Asmblockgenproof1.v | 76 ++++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 6a3f2389..4c29867b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1596,49 +1596,49 @@ Opaque Int.eq. unfold conditional_move_imm32 in *. destruct c0; simpl in *. - all: - destruct c; simpl in *; inv EQ0; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - unfold cmove, cmoveu; - rewrite Pregmap.gss; - destruct (rs x0); simpl; trivial; - try rewrite int_ltu_to_neq; - try rewrite int64_ltu_to_neq; - try change (Int64.eq Int64.zero Int64.zero) with true; - try destruct Archi.ptr64; - repeat rewrite if_neg; - simpl; - trivial; - try destruct (_ || _); - trivial; - try apply Val.lessdef_normalize. - + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: try (econstructor; split; [idtac | split ]). + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. - (* Osellimm *) unfold conditional_move_imm64 in *. destruct c0; simpl in *. - all: - destruct c; simpl in *; inv EQ0; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - unfold cmove, cmoveu; - rewrite Pregmap.gss; - destruct (rs x0); simpl; trivial; - try rewrite int_ltu_to_neq; - try rewrite int64_ltu_to_neq; - try change (Int64.eq Int64.zero Int64.zero) with true; - try destruct Archi.ptr64; - repeat rewrite if_neg; - simpl; - trivial; - try destruct (_ || _); - trivial; - try apply Val.lessdef_normalize. - + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: try (econstructor; split; [idtac | split ]). + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. Qed. (** Memory accesses *) -- cgit From b1b2c6c6442a48c8eb2f7f378e440d8d4311048f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 06:35:43 +0100 Subject: proof clarification --- mppa_k1c/Asmblockgenproof1.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 4c29867b..00df01e3 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1483,6 +1483,8 @@ Proof. destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. Qed. +Ltac splitall := repeat match goal with |- _ /\ _ => split end. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1575,7 +1577,7 @@ Opaque Int.eq. all: destruct c. all: simpl in *. all: inv EQ2. - all: try (econstructor; split; [idtac | split ]). + all: econstructor; splitall. all: try apply exec_straight_one. all: intros; simpl; trivial. all: unfold Val.select, cmove, cmoveu; simpl. @@ -1599,7 +1601,7 @@ Opaque Int.eq. all: destruct c. all: simpl in *. all: inv EQ0. - all: try (econstructor; split; [idtac | split ]). + all: econstructor; splitall. all: try apply exec_straight_one. all: intros; simpl; trivial. all: unfold Val.select, cmove, cmoveu; simpl. @@ -1623,7 +1625,7 @@ Opaque Int.eq. all: destruct c. all: simpl in *. all: inv EQ0. - all: try (econstructor; split; [idtac | split ]). + all: econstructor; splitall. all: try apply exec_straight_one. all: intros; simpl; trivial. all: unfold Val.select, cmove, cmoveu; simpl. -- cgit From 87b17fa1912da24ba114a181d1fbd1779d33e835 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 20 Mar 2020 15:56:00 +0100 Subject: Reintroducing the Chang algorithm - selecting algo based on size --- backend/Duplicateaux.ml | 63 ++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 57 insertions(+), 6 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 91d313f7..b9f5cdf2 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -52,11 +52,9 @@ let get_predecessors_rtl code = begin 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 () - else preds := PTree.set s (node::previous_preds) !preds) - succ + else preds := PTree.set s (node::previous_preds) !preds) succ in begin List.iter process_inst (PTree.elements code); - Printf.printf "get_predecessors_rtl done\n"; flush stdout; !preds end end @@ -331,10 +329,10 @@ 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 = +let best_predecessor_of node predecessors 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) order) + | Some lp -> try Some (List.find (fun n -> (List.mem n lp) && (not (ptree_get_some n is_visited))) order) with Not_found -> None let print_trace t = print_intlist t @@ -349,7 +347,8 @@ let print_traces traces = Printf.printf "}\n"; end -let select_traces code entrypoint = +(* Dumb (but linear) trace selection *) +let select_traces_linear code entrypoint = let is_visited = ref (PTree.map (fun n i -> false) code) in let bfs_order = bfs code entrypoint in let rec go_through node = begin @@ -374,9 +373,61 @@ let select_traces code entrypoint = if not (get_some @@ PTree.get n !is_visited) then traces := (go_through n) :: !traces ) bfs_order; + !traces + end + + +(* 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; + 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; + 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 + let current = ref seed in begin + is_visited := PTree.set seed true !is_visited; (* mark seed visited *) + let quit_loop = ref false in begin + while not !quit_loop do + let s = best_successor_of !current code !is_visited in + match s with + | None -> quit_loop := true (* if (s==0) exit loop *) + | Some succ -> begin + trace := !trace @ [succ]; + is_visited := PTree.set succ true !is_visited; (* mark s visited *) + current := succ + end + done; + current := seed; + quit_loop := false; + while not !quit_loop do + let s = best_predecessor_of !current predecessors order !is_visited in + match s with + | None -> quit_loop := true (* if (s==0) exit loop *) + | Some pred -> begin + trace := pred :: !trace; + is_visited := PTree.set pred true !is_visited; (* mark s visited *) + current := pred + end + done; + traces := !trace :: !traces; + end + end + done; + (* Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; *) Printf.printf "Traces: "; print_traces !traces; !traces end +end + +let select_traces code entrypoint = + let length = List.length @@ PTree.elements code in + if (length < 5000) then select_traces_chang code entrypoint + else select_traces_linear code entrypoint let rec make_identity_ptree_rec = function | [] -> PTree.empty -- cgit From b675ed29c56a16cd35e5a8d7e49be7c582ebd4ab Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 19:16:52 +0100 Subject: essai d'intégration continue MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .gitlab-ci.yml | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 .gitlab-ci.yml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml new file mode 100644 index 00000000..8e840fd9 --- /dev/null +++ b/.gitlab-ci.yml @@ -0,0 +1,11 @@ +stages: + - build_x86_64 + +.build_x86_64: + stage: build_x86_64 + image: "coqorg/coq" + before_script: + - opam install -y menhir + script: + ./config_x86_64.sh + make -j "$NJOBS" \ No newline at end of file -- cgit From 404cf8865a61dc5c03d4255c42d47462666ace23 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 19:20:00 +0100 Subject: fix YAML syntax --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8e840fd9..5e76b79f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,11 +1,11 @@ stages: - build_x86_64 -.build_x86_64: +build_x86_64: stage: build_x86_64 image: "coqorg/coq" before_script: - opam install -y menhir script: ./config_x86_64.sh - make -j "$NJOBS" \ No newline at end of file + make -j "$NJOBS" -- cgit From aa926dbe4652b10ecc77347c99300bc6e00b5be4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 19:24:54 +0100 Subject: fix syntax --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5e76b79f..b6d78ef6 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -7,5 +7,5 @@ build_x86_64: before_script: - opam install -y menhir script: - ./config_x86_64.sh - make -j "$NJOBS" + - ./config_x86_64.sh + - make -j "$NJOBS" -- cgit From 64ce25f46ebe6558d252a878f2289e8ec3901f17 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 19:43:17 +0100 Subject: use later ocaml compiler --- .gitlab-ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b6d78ef6..d7093a58 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -5,6 +5,7 @@ build_x86_64: stage: build_x86_64 image: "coqorg/coq" before_script: + - opam switch \$COMPILER_EDGE; eval \$(opam env) - opam install -y menhir script: - ./config_x86_64.sh -- cgit From d045132186970daa0b7b523e4fdbeb87a71fd3ff Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 19:51:55 +0100 Subject: fix opam config env --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d7093a58..4f2b8413 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -5,7 +5,8 @@ build_x86_64: stage: build_x86_64 image: "coqorg/coq" before_script: - - opam switch \$COMPILER_EDGE; eval \$(opam env) + - opam switch \$COMPILER_EDGE + - eval `opam config env` - opam install -y menhir script: - ./config_x86_64.sh -- cgit From 43e091310b69f39e0591ee71922121a7508c3987 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 19:55:22 +0100 Subject: fix COMPILER_EDGE --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4f2b8413..2745b1eb 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -5,7 +5,7 @@ build_x86_64: stage: build_x86_64 image: "coqorg/coq" before_script: - - opam switch \$COMPILER_EDGE + - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: -- cgit From 599ef2ea4cf6f305097809ef123f948ac6c21429 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 20:11:41 +0100 Subject: more architectures --- .gitlab-ci.yml | 77 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2745b1eb..6eacd8bc 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,5 +1,11 @@ stages: + - build_ppc + - build_aarch64 + - build_arm + - build_rv64 + - build_rv32 - build_x86_64 + - build_x86 build_x86_64: stage: build_x86_64 @@ -11,3 +17,74 @@ build_x86_64: script: - ./config_x86_64.sh - make -j "$NJOBS" + +build_x86: + stage: build_x86 + image: "coqorg/coq" + before_script: + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_x86.sh + - make -j "$NJOBS" + +build_aarch64: + stage: build_aarch64 + image: "coqorg/coq" + before_script: + - sudo apt install gcc-aarch64-linux-gnu + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_aarch64.sh + - make -j "$NJOBS" + +build_arm: + stage: build_arm + image: "coqorg/coq" + before_script: + - sudo apt install gcc-arm-linux-gnueabihf + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_arm.sh + - make -j "$NJOBS" + +build_ppc: + stage: build_ppc + image: "coqorg/coq" + before_script: + - sudo apt install gcc-powerpc-linux + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_ppc.sh + - make -j "$NJOBS" + +build_rv64: + stage: build_rv64 + image: "coqorg/coq" + before_script: + - sudo apt install gcc-riscv64-linux-gnu + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_rv64.sh + - make -j "$NJOBS" + +build_rv32: + stage: build_rv32 + image: "coqorg/coq" + before_script: + - sudo apt install gcc-riscv64-linux-gnu + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_rv32.sh + - make -j "$NJOBS" -- cgit From 995df48bc3920b774a43da7612b1c63faa2ec7d4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 20:16:12 +0100 Subject: fix spelling --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6eacd8bc..9e6d21b0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -57,7 +57,7 @@ build_ppc: stage: build_ppc image: "coqorg/coq" before_script: - - sudo apt install gcc-powerpc-linux + - sudo apt install gcc-powerpc-linux-gnu - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir -- cgit From 4f3f8ce2a1da0362575087c642cc4e51fe0c9849 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 20:19:18 +0100 Subject: with several jobs --- .gitlab-ci.yml | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9e6d21b0..b31d676f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,14 +1,8 @@ stages: - - build_ppc - - build_aarch64 - - build_arm - - build_rv64 - - build_rv32 - - build_x86_64 - - build_x86 + - build build_x86_64: - stage: build_x86_64 + stage: build image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda @@ -19,7 +13,7 @@ build_x86_64: - make -j "$NJOBS" build_x86: - stage: build_x86 + stage: build image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda @@ -30,7 +24,7 @@ build_x86: - make -j "$NJOBS" build_aarch64: - stage: build_aarch64 + stage: build image: "coqorg/coq" before_script: - sudo apt install gcc-aarch64-linux-gnu @@ -42,7 +36,7 @@ build_aarch64: - make -j "$NJOBS" build_arm: - stage: build_arm + stage: build image: "coqorg/coq" before_script: - sudo apt install gcc-arm-linux-gnueabihf @@ -54,7 +48,7 @@ build_arm: - make -j "$NJOBS" build_ppc: - stage: build_ppc + stage: build image: "coqorg/coq" before_script: - sudo apt install gcc-powerpc-linux-gnu @@ -66,7 +60,7 @@ build_ppc: - make -j "$NJOBS" build_rv64: - stage: build_rv64 + stage: build image: "coqorg/coq" before_script: - sudo apt install gcc-riscv64-linux-gnu @@ -78,7 +72,7 @@ build_rv64: - make -j "$NJOBS" build_rv32: - stage: build_rv32 + stage: build image: "coqorg/coq" before_script: - sudo apt install gcc-riscv64-linux-gnu -- cgit From 64ed780f6ad9512bd4de2a6ab5cf79234e4d34e7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 20:31:48 +0100 Subject: ia32 --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b31d676f..a8120993 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -12,7 +12,7 @@ build_x86_64: - ./config_x86_64.sh - make -j "$NJOBS" -build_x86: +build_ia32: stage: build image: "coqorg/coq" before_script: @@ -20,7 +20,7 @@ build_x86: - eval `opam config env` - opam install -y menhir script: - - ./config_x86.sh + - ./config_ia32.sh - make -j "$NJOBS" build_aarch64: -- cgit From 1069688c9d49fc6ea0f667f640b6a60d7b1fdd84 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 21:01:52 +0100 Subject: fixing aarch64? --- .gitlab-ci.yml | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a8120993..144c920a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,8 +1,9 @@ stages: - build + - build2 build_x86_64: - stage: build + stage: build2 image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda @@ -13,7 +14,7 @@ build_x86_64: - make -j "$NJOBS" build_ia32: - stage: build + stage: build2 image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda @@ -27,7 +28,8 @@ build_aarch64: stage: build image: "coqorg/coq" before_script: - - sudo apt install gcc-aarch64-linux-gnu + - sudo apt-get update + - sudo apt-get -y install gcc-aarch64-linux-gnu - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir @@ -36,10 +38,10 @@ build_aarch64: - make -j "$NJOBS" build_arm: - stage: build + stage: build2 image: "coqorg/coq" before_script: - - sudo apt install gcc-arm-linux-gnueabihf + - sudo apt-get -y install gcc-arm-linux-gnueabihf - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir @@ -48,10 +50,10 @@ build_arm: - make -j "$NJOBS" build_ppc: - stage: build + stage: build2 image: "coqorg/coq" before_script: - - sudo apt install gcc-powerpc-linux-gnu + - sudo apt-get -y install gcc-powerpc-linux-gnu - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir @@ -60,10 +62,10 @@ build_ppc: - make -j "$NJOBS" build_rv64: - stage: build + stage: build2 image: "coqorg/coq" before_script: - - sudo apt install gcc-riscv64-linux-gnu + - sudo apt-get -y install gcc-riscv64-linux-gnu - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir @@ -72,10 +74,10 @@ build_rv64: - make -j "$NJOBS" build_rv32: - stage: build + stage: build2 image: "coqorg/coq" before_script: - - sudo apt install gcc-riscv64-linux-gnu + - sudo apt-get -y install gcc-riscv64-linux-gnu - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir -- cgit From e8408d8d85b3961a1cf177b3e8a307f80319e4e7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 21:03:49 +0100 Subject: workaround for time issues --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 144c920a..abe1724a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -28,7 +28,7 @@ build_aarch64: stage: build image: "coqorg/coq" before_script: - - sudo apt-get update + - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-aarch64-linux-gnu - opam switch 4.07.1+flambda - eval `opam config env` -- cgit From 090dc09e4dbda97eea4ed28e67d84adf26f807f7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 21:18:28 +0100 Subject: apt update --- .gitlab-ci.yml | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index abe1724a..a285d8f2 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,9 +1,8 @@ stages: - build - - build2 build_x86_64: - stage: build2 + stage: build image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda @@ -14,7 +13,7 @@ build_x86_64: - make -j "$NJOBS" build_ia32: - stage: build2 + stage: build image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda @@ -38,9 +37,10 @@ build_aarch64: - make -j "$NJOBS" build_arm: - stage: build2 + stage: build 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 - opam switch 4.07.1+flambda - eval `opam config env` @@ -50,9 +50,10 @@ build_arm: - make -j "$NJOBS" build_ppc: - stage: build2 + stage: build 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 - opam switch 4.07.1+flambda - eval `opam config env` @@ -62,9 +63,10 @@ build_ppc: - make -j "$NJOBS" build_rv64: - stage: build2 + stage: build 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 - opam switch 4.07.1+flambda - eval `opam config env` @@ -74,9 +76,10 @@ build_rv64: - make -j "$NJOBS" build_rv32: - stage: build2 + stage: build 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 - opam switch 4.07.1+flambda - eval `opam config env` -- cgit From 8f337f072a3731dbb778afdb4a5882fd744333a4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 21:33:13 +0100 Subject: +k1c target --- .gitlab-ci.yml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a285d8f2..9eafe558 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -87,3 +87,14 @@ build_rv32: script: - ./config_rv32.sh - make -j "$NJOBS" + +build_k1c: + stage: build + image: "coqorg/coq" + before_script: + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_k1c.sh -no-runtime-lib + - make -j "$NJOBS" -- cgit From 3ad897c65d5f16159694ede55958ac8c85339d55 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 22:50:07 +0100 Subject: la lib standard ne passe pas en rv32, ne pas la tester en CI --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9eafe558..b4571271 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -85,7 +85,7 @@ build_rv32: - eval `opam config env` - opam install -y menhir script: - - ./config_rv32.sh + - ./config_rv32.sh -no-runtime-lib - make -j "$NJOBS" build_k1c: -- cgit From d19e5a265cdee251b582792b63ed7e91c313579f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 21 Mar 2020 07:53:37 +0100 Subject: tentative pour n'avoir le gitlab-ci que sur mppa-work, mppa-k1c et master --- .gitlab-ci.yml | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b4571271..79a00d3b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -11,6 +11,10 @@ build_x86_64: script: - ./config_x86_64.sh - make -j "$NJOBS" + only: + - master + - mppa-k1c + - mppa-work build_ia32: stage: build @@ -22,6 +26,10 @@ build_ia32: script: - ./config_ia32.sh - make -j "$NJOBS" + only: + - master + - mppa-k1c + - mppa-work build_aarch64: stage: build @@ -35,6 +43,10 @@ build_aarch64: script: - ./config_aarch64.sh - make -j "$NJOBS" + only: + - master + - mppa-k1c + - mppa-work build_arm: stage: build @@ -48,6 +60,10 @@ build_arm: script: - ./config_arm.sh - make -j "$NJOBS" + only: + - master + - mppa-k1c + - mppa-work build_ppc: stage: build @@ -61,6 +77,10 @@ build_ppc: script: - ./config_ppc.sh - make -j "$NJOBS" + only: + - master + - mppa-k1c + - mppa-work build_rv64: stage: build @@ -74,6 +94,10 @@ build_rv64: script: - ./config_rv64.sh - make -j "$NJOBS" + only: + - master + - mppa-k1c + - mppa-work build_rv32: stage: build @@ -87,6 +111,10 @@ build_rv32: script: - ./config_rv32.sh -no-runtime-lib - make -j "$NJOBS" + only: + - master + - mppa-k1c + - mppa-work build_k1c: stage: build @@ -98,3 +126,6 @@ build_k1c: script: - ./config_k1c.sh -no-runtime-lib - make -j "$NJOBS" + only: + - mppa-k1c + - mppa-work -- cgit From 9ce733bd06a6f36a144769b05b9405ea7ebbbfb9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 21 Mar 2020 10:50:41 +0100 Subject: essai d'avoir le pipeline en manuel OU sur certaines branches --- .gitlab-ci.yml | 95 +++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 64 insertions(+), 31 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 79a00d3b..ad684229 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -11,10 +11,14 @@ build_x86_64: script: - ./config_x86_64.sh - make -j "$NJOBS" - only: - - master - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_ia32: stage: build @@ -26,10 +30,14 @@ build_ia32: script: - ./config_ia32.sh - make -j "$NJOBS" - only: - - master - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_aarch64: stage: build @@ -43,10 +51,14 @@ build_aarch64: script: - ./config_aarch64.sh - make -j "$NJOBS" - only: - - master - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_arm: stage: build @@ -60,10 +72,14 @@ build_arm: script: - ./config_arm.sh - make -j "$NJOBS" - only: - - master - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_ppc: stage: build @@ -77,10 +93,14 @@ build_ppc: script: - ./config_ppc.sh - make -j "$NJOBS" - only: - - master - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_rv64: stage: build @@ -94,10 +114,14 @@ build_rv64: script: - ./config_rv64.sh - make -j "$NJOBS" - only: - - master - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_rv32: stage: build @@ -111,10 +135,14 @@ build_rv32: script: - ./config_rv32.sh -no-runtime-lib - make -j "$NJOBS" - only: - - master - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_k1c: stage: build @@ -126,6 +154,11 @@ build_k1c: script: - ./config_k1c.sh -no-runtime-lib - make -j "$NJOBS" - only: - - mppa-k1c - - mppa-work + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual -- cgit From 1033c2a0ffefc336c343888e1abda02d7a1db228 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 23 Mar 2020 16:32:23 +0100 Subject: Removing store heuristic and more fine tuning loop heuristic --- backend/Duplicateaux.ml | 12 ++++++++---- backend/Linearizeaux.ml | 2 +- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index b9f5cdf2..9ee082ea 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -195,12 +195,16 @@ 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"; - let predicate n = get_some @@ PTree.get n is_loop_header - in if (look_ahead code ifso is_loop_header predicate) then Some true - else if (look_ahead code ifnot is_loop_header predicate) then Some false + 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 + if ifso_loop && ifnot_loop then None (* TODO - take the innermost loop ? *) + else if ifso_loop then Some true + else if ifnot_loop then Some false else None end + (* 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 @@ -214,7 +218,7 @@ let get_directions code entrypoint = begin | Icond (cond, lr, ifso, ifnot, _) -> (* Printf.printf "Analyzing %d.." (P.to_int n); *) let heuristics = [ do_call_heuristic; do_opcode_heuristic; - do_return_heuristic; do_store_heuristic; do_loop_heuristic ] in + do_return_heuristic; do_loop_heuristic; (* do_store_heuristic *) ] in let preferred = ref None in begin Printf.printf "Deciding condition for RTL node %d\n" (P.to_int n); diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 23ced4c2..e68a9b9a 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -154,7 +154,7 @@ let forward_sequences code entry = let visited = ref (PTree.map (fun n i -> false) code) 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); + (* Printf.printf "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 -- cgit From 815fd43dc43ea85d35f1275bd701f5b370ced2a5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 24 Mar 2020 11:46:13 +0100 Subject: Linearizeaux: Refining block selection in case of tie --- backend/Linearizeaux.ml | 56 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 19 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index e68a9b9a..3f207d9e 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -163,15 +163,15 @@ 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 (* Printf.printf "STOP tailcall/return\n"; *) ([], []) end | Lbranch n -> 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 (* Printf.printf "STOP Lcond None\n"; *) ([], [ifso; ifnot]) end | Some false -> 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 (* Printf.printf "STOP Ljumptable\n"; *) ([], ln) end in ([node] @ ln, rem) end else ([], []) @@ -423,31 +423,49 @@ let order_sequences code entry fs = depmap.(i) <- ISet.remove s_id deps ) depmap end + in let choose_best_of candidates = + let current_best_id = ref None in + let current_best_score = ref None in + begin + List.iter (fun id -> + match !current_best_id with + | None -> begin + current_best_id := Some id; + match fs_a.(id) with + | [] -> current_best_score := None + | n::l -> current_best_score := Some (P.to_int n) + end + | Some b -> begin + match fs_a.(id) with + | [] -> () + | n::l -> let nscore = P.to_int n in + match !current_best_score with + | None -> (current_best_id := Some id; current_best_score := Some nscore) + | Some bs -> if nscore > bs then (current_best_id := Some id; current_best_score := Some nscore) + end + ) candidates; + !current_best_id + end in let select_next () = - let selected_id = ref None in + let candidates = ref [] in begin Array.iteri (fun i deps -> begin (* Printf.printf "Deps: "; print_iset deps; Printf.printf "\n"; *) - match !selected_id with - | None -> if (deps == ISet.empty && not fs_evaluated.(i)) then selected_id := Some i - | Some id -> () + if (deps == ISet.empty && not fs_evaluated.(i)) then candidates := i :: !candidates end ) depmap; - match !selected_id with - | Some id -> id - | None -> begin - Array.iteri (fun i deps -> - match !selected_id with - | None -> if not fs_evaluated.(i) then selected_id := Some i - | Some id -> () - ) depmap; - get_some !selected_id - end + if not (List.length !candidates > 0) then begin + Array.iteri (fun i deps -> + if (not fs_evaluated.(i)) then candidates := i :: !candidates + ) depmap; + end; + get_some (choose_best_of !candidates) end in begin - (* Printf.printf "depmap: "; print_depmap depmap; *) - (* Printf.printf "forward sequences identified: "; print_ssequence fs; *) + Printf.printf "-------------------------------\n"; + Printf.printf "depmap: "; print_depmap depmap; + Printf.printf "forward sequences identified: "; print_ssequence fs; while List.length !ordered_fs != List.length fs do let next_id = select_next () in evaluate next_id -- cgit From c1aa5f9678c2a90453c57f9918b349753fdf50be Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 24 Mar 2020 17:08:13 +0100 Subject: Duplicate: added another loop heuristic which should detect loop branches better --- backend/Duplicateaux.ml | 62 +++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 57 insertions(+), 5 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 9ee082ea..fedb63fe 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -204,13 +204,65 @@ let do_loop_heuristic code cond ifso ifnot is_loop_header = else None end +let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header = + begin + Printf.printf "\tLoop2 heuristic..\n"; + match get_some @@ PTree.get n loop_info with + | None -> None + | Some b -> Some b + end + +(* Returns a PTree of either None or Some b where b determines the node following the loop, for a cb instruction *) +(* It uses the fact that loops in CompCert are done by a branch (backedge) instruction followed by a cb *) +let get_loop_info is_loop_header bfs_order code = + let loop_info = ref (PTree.map (fun n i -> None) code) in + let mark_path s n = + let visited = ref (PTree.map (fun n i -> false) code) in + let rec explore src dest = + if (get_some @@ PTree.get src !visited) then false + 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 + 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 () + | _ -> () + end + | Some _ -> () + in begin + List.iter (fun n -> + match get_some @@ PTree.get n code with + | 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 *) + | Ijumptable _ -> () + | Itailcall _ | Ireturn _ -> () + ) bfs_order; + !loop_info + end + (* 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 - and is_loop_header = get_loop_headers code entrypoint - and directions = ref (PTree.map (fun n i -> None) code) (* None <=> no predicted direction *) - in begin + 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"; *) List.iter (fun n -> @@ -218,7 +270,7 @@ let get_directions code entrypoint = begin | Icond (cond, lr, ifso, ifnot, _) -> (* Printf.printf "Analyzing %d.." (P.to_int n); *) let heuristics = [ do_call_heuristic; do_opcode_heuristic; - do_return_heuristic; do_loop_heuristic; (* do_store_heuristic *) ] in + do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; (* do_store_heuristic *) ] in let preferred = ref None in begin Printf.printf "Deciding condition for RTL node %d\n" (P.to_int n); -- cgit From ee7cd36732efd3af91f8d6cb9be18a58e0ff43a3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Mar 2020 20:03:00 +0100 Subject: exec_straight_steps exec_straight_steps_goto exec_straight_opt_steps_goto --- aarch64/Asmgenproof.v | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index eeff1956..5353d1ab 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -472,7 +472,8 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (MEXT: Mem.extends m m') (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) (AG: agree ms sp rs) - (DXP: ep = true -> rs#X29 = parent_sp s), + (DXP: ep = true -> rs#X29 = parent_sp s) + (LEAF: is_leaf_function f = true -> rs#X30 = parent_ra s), match_states (Mach.State s fb sp c ms m) (Asm.State rs m') | match_states_call: @@ -503,16 +504,17 @@ Lemma exec_straight_steps: exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#X29 = parent_sp s)) -> + /\ (it1_is_parent ep i = true -> rs2#X29 = parent_sp s) + /\ (is_leaf_function f = true -> rs2#X30 = parent_ra s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c ms2 m2) st'. Proof. intros. inversion H2. subst. monadInv H7. - exploit H3; eauto. intros [rs2 [A [B C]]]. + exploit H3; eauto. intros [rs2 [A [B [C D]]]]. exists (State rs2 m2'); split. - eapply exec_straight_exec; eauto. - econstructor; eauto. eapply exec_straight_at; eauto. + - eapply exec_straight_exec; eauto. + - econstructor; eauto. eapply exec_straight_at; eauto. Qed. Lemma exec_straight_steps_goto: -- cgit From b59b1c908b1f412591accba7d2ecb5818062c3f9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Mar 2020 20:47:36 +0100 Subject: progress in proofs about RA --- aarch64/Asmgenproof.v | 55 +++++++++++++++++++++++-------------- aarch64/Asmgenproof1.v | 73 +++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 92 insertions(+), 36 deletions(-) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index 5353d1ab..0dc37f36 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -473,7 +473,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) (AG: agree ms sp rs) (DXP: ep = true -> rs#X29 = parent_sp s) - (LEAF: is_leaf_function f = true -> rs#X30 = parent_ra s), + (LEAF: is_leaf_function f = true -> rs#RA = parent_ra s), match_states (Mach.State s fb sp c ms m) (Asm.State rs m') | match_states_call: @@ -505,7 +505,7 @@ Lemma exec_straight_steps: exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2 /\ (it1_is_parent ep i = true -> rs2#X29 = parent_sp s) - /\ (is_leaf_function f = true -> rs2#X30 = parent_ra s)) -> + /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c ms2 m2) st'. @@ -529,13 +529,14 @@ Lemma exec_straight_steps_goto: exists jmp, exists k', exists rs2, exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2' + /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c' ms2 m2) st'. Proof. intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B [C D]]]]]]. generalize (functions_transl _ _ _ H7 H8); intro FN. generalize (transf_function_no_overflow _ _ H8); intro NOOV. exploit exec_straight_steps_2; eauto. @@ -552,6 +553,7 @@ Proof. econstructor; eauto. apply agree_exten with rs2; auto with asmgen. congruence. + rewrite OTH by congruence; auto. Qed. Lemma exec_straight_opt_steps_goto: @@ -566,13 +568,14 @@ Lemma exec_straight_opt_steps_goto: exists jmp, exists k', exists rs2, exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2' + /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c' ms2 m2) st'. Proof. intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B [C D]]]]]]. generalize (functions_transl _ _ _ H7 H8); intro FN. generalize (transf_function_no_overflow _ _ H8); intro NOOV. inv A. @@ -585,6 +588,7 @@ Proof. econstructor; eauto. apply agree_exten with rs2; auto with asmgen. congruence. + rewrite OTH by congruence; auto. - exploit exec_straight_steps_2; eauto. intros [ofs' [PC2 CT2]]. exploit find_label_goto_label; eauto. @@ -599,6 +603,7 @@ Proof. econstructor; eauto. apply agree_exten with rs2; auto with asmgen. congruence. + rewrite OTH by congruence; auto. Qed. (** We need to show that, in the simulation diagram, we cannot @@ -640,17 +645,20 @@ Proof. - (* Mlabel *) left; eapply exec_straight_steps; eauto; intros. monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. apply agree_nextinstr; auto. simpl; congruence. + split. { apply agree_nextinstr; auto. } + split. { simpl; congruence. } + rewrite nextinstr_inv by congruence; assumption. - (* Mgetstack *) unfold load_stack in H. exploit Mem.loadv_extends; eauto. intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. + exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q [R S]]]]. exists rs'; split. eauto. - split. eapply agree_set_mreg; eauto with asmgen. congruence. - simpl; congruence. + split. { eapply agree_set_mreg; eauto with asmgen. congruence. } + split. { simpl; congruence. } + rewrite S. assumption. - (* Msetstack *) unfold store_stack in H. @@ -658,10 +666,12 @@ Proof. exploit Mem.storev_extends; eauto. intros [m2' [A B]]. left; eapply exec_straight_steps; eauto. rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. - exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. + exploit storeind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. exists rs'; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. + simpl; intros. + split. rewrite Q; auto with asmgen. + rewrite R. assumption. - (* Mgetparam *) assert (f0 = f) by congruence; subst f0. @@ -677,24 +687,29 @@ Opaque loadind. (* X30 contains parent *) exploit loadind_correct. eexact EQ. instantiate (2 := rs0). simpl; rewrite DXP; eauto. simpl; congruence. - intros [rs1 [P [Q R]]]. + intros [rs1 [P [Q [R S]]]]. exists rs1; split. eauto. split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. - simpl; intros. rewrite R; auto with asmgen. - apply preg_of_not_X29; auto. + simpl; split; intros. + { rewrite R; auto with asmgen. + apply preg_of_not_X29; auto. + } + { rewrite S; auto. } + (* X30 does not contain parent *) exploit loadptr_correct. eexact A. simpl; congruence. intros [rs1 [P [Q R]]]. exploit loadind_correct. eexact EQ. instantiate (2 := rs1). simpl; rewrite Q. eauto. simpl; congruence. - intros [rs2 [S [T U]]]. + intros [rs2 [S [T [U V]]]]. exists rs2; split. eapply exec_straight_trans; eauto. split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. instantiate (1 := rs1#X29 <- (rs2#X29)). intros. rewrite Pregmap.gso; auto with asmgen. congruence. intros. unfold Pregmap.set. destruct (PregEq.eq r' X29). congruence. auto with asmgen. - simpl; intros. rewrite U; auto with asmgen. + split; simpl; intros. rewrite U; auto with asmgen. apply preg_of_not_X29; auto. - + rewrite V. rewrite R by congruence. auto. + - (* Mop *) assert (eval_operation tge sp op (map rs args) m = Some v). { rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. } @@ -705,11 +720,11 @@ Opaque loadind. exists rs2; split. eauto. split. apply agree_set_undef_mreg with rs0; auto. apply Val.lessdef_trans with v'; auto. - simpl; intros. InvBooleans. + split; simpl; intros. InvBooleans. rewrite R; auto. apply preg_of_not_X29; auto. Local Transparent destroyed_by_op. destruct op; try exact I; simpl; congruence. - + - (* Mload *) assert (Op.eval_addressing tge sp addr (map rs args) = Some a). { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. } diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 6d44bcc8..c85543f3 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -22,6 +22,37 @@ Local Transparent Archi.ptr64. (** Properties of registers *) +Lemma preg_of_not_RA: + forall r, (preg_of r) <> RA. +Proof. + destruct r; discriminate. +Qed. + +Lemma RA_not_written: + forall (rs : regset) dst v, + rs # (preg_of dst) <- v RA = rs RA. +Proof. + intros. + apply Pregmap.gso. + intro. + symmetry in H. + exact (preg_of_not_RA dst H). +Qed. + +Hint Resolve RA_not_written : asmgen. + +Lemma RA_not_written2: + forall (rs : regset) dst v i, + preg_of dst = i -> + rs # i <- v RA = rs RA. +Proof. + intros. + subst i. + apply RA_not_written. +Qed. + +Hint Resolve RA_not_written2 : asmgen. + Lemma preg_of_iregsp_not_PC: forall r, preg_of_iregsp r <> PC. Proof. destruct r; simpl; congruence. @@ -1347,13 +1378,15 @@ Ltac TranslOpSimpl := [ apply exec_straight_one; [simpl; eauto | reflexivity] | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; apply Val.lessdef_same; Simpl; fail - | intros; Simpl; fail ] ]. + | split; [ intros; Simpl; fail + | intros; Simpl; eapply RA_not_written2; eauto] ]]. Ltac TranslOpBase := econstructor; split; [ apply exec_straight_one; [simpl; eauto | reflexivity] | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; Simpl - | intros; Simpl; fail ] ]. + | split; [ intros; Simpl; fail + | intros; Simpl; eapply RA_not_written2; eauto] ]]. Lemma transl_op_correct: forall op args res k (rs: regset) m v c, @@ -1362,15 +1395,15 @@ Lemma transl_op_correct: exists rs', exec_straight ge fn c rs m k rs' m /\ Val.lessdef v rs'#(preg_of res) - /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. + /\ (forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r) + /\ rs' RA = rs RA. Proof. Local Opaque Int.eq Int64.eq Val.add Val.addl Int.zwordsize Int64.zwordsize. intros until c; intros TR EV. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. - (* move *) destruct (preg_of res) eqn:RR; try discriminate; destruct (preg_of m0) eqn:R1; inv TR. -+ TranslOpSimpl. -+ TranslOpSimpl. + all: TranslOpSimpl. - (* intconst *) exploit exec_loadimm32. intros (rs' & A & B & C). exists rs'; split. eexact A. split. rewrite B; auto. intros; auto with asmgen. @@ -1712,7 +1745,7 @@ Lemma loadptr_correct: forall (base: iregsp) ofs dst k m v (rs: regset), exists rs', exec_straight ge fn (loadptr base ofs dst k) rs m k rs' m /\ rs'#dst = v - /\ forall r, r <> PC -> r <> X16 -> r <> dst -> rs' r = rs r. + /\ (forall r, r <> PC -> r <> X16 -> r <> dst -> rs' r = rs r). Proof. intros. destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. @@ -1720,7 +1753,8 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. simpl. unfold exec_load. rewrite B, H. eauto. auto. - split. Simpl. intros; Simpl. + split. Simpl. + intros; Simpl. Qed. Lemma storeptr_correct: forall (base: iregsp) ofs (src: ireg) k m m' (rs: regset), @@ -1729,7 +1763,8 @@ Lemma storeptr_correct: forall (base: iregsp) ofs (src: ireg) k m m' (rs: regset src <> X16 -> exists rs', exec_straight ge fn (storeptr src base ofs k) rs m k rs' m' - /\ forall r, r <> PC -> r <> X16 -> rs' r = rs r. + /\ (forall r, r <> PC -> r <> X16 -> rs' r = rs r) + /\ rs' RA = rs RA. Proof. intros. destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. @@ -1737,7 +1772,7 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. simpl. unfold exec_store. rewrite B, C, H by eauto with asmgen. eauto. auto. - intros; Simpl. + split; intros; Simpl. Qed. Lemma loadind_correct: forall (base: iregsp) ofs ty dst k c (rs: regset) m v, @@ -1747,7 +1782,8 @@ Lemma loadind_correct: forall (base: iregsp) ofs ty dst k c (rs: regset) m v, exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of dst) = v - /\ forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r. + /\ (forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r) + /\ rs' RA = rs RA. Proof. intros. destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. @@ -1763,7 +1799,10 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite SEM. unfold exec_load. rewrite B, H0. eauto. Simpl. - split. Simpl. intros; Simpl. + split. Simpl. + split. intros; Simpl. + Simpl. rewrite RA_not_written. + apply C; congruence. Qed. Lemma storeind_correct: forall (base: iregsp) ofs ty src k c (rs: regset) m m', @@ -1772,7 +1811,8 @@ Lemma storeind_correct: forall (base: iregsp) ofs ty src k c (rs: regset) m m', preg_of_iregsp base <> IR X16 -> exists rs', exec_straight ge fn c rs m k rs' m' - /\ forall r, data_preg r = true -> rs' r = rs r. + /\ (forall r, data_preg r = true -> rs' r = rs r) + /\ rs' RA = rs RA. Proof. intros. destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. @@ -1790,7 +1830,8 @@ Proof. apply exec_straight_one. rewrite SEM. unfold exec_store. rewrite B, C, H0 by eauto with asmgen. eauto. Simpl. - intros; Simpl. + split. intros; Simpl. + Simpl. Qed. Lemma make_epilogue_correct: @@ -1807,7 +1848,7 @@ Lemma make_epilogue_correct: /\ Mem.extends m' tm' /\ rs'#RA = parent_ra cs /\ rs'#SP = parent_sp cs - /\ (forall r, r <> PC -> r <> SP -> r <> X30 -> r <> X16 -> rs'#r = rs#r). + /\ (forall r, r <> PC -> r <> SP -> r <> RA -> r <> X16 -> 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'). @@ -1815,7 +1856,7 @@ Proof. 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. + unfold make_epilogue. exploit (loadptr_correct XSP (fn_retaddr_ofs f)). instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence. intros (rs1 & A1 & B1 & C1). @@ -1833,4 +1874,4 @@ Proof. intros. Simpl. Qed. -End CONSTRUCTORS. \ No newline at end of file +End CONSTRUCTORS. -- cgit From 4f29e1e0a8cea00a52fa31f42f050fcd90eb739c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Mar 2020 23:36:56 +0100 Subject: transl_cond --- aarch64/Asmgenproof1.v | 475 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 332 insertions(+), 143 deletions(-) diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index c85543f3..96561da7 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -53,6 +53,20 @@ Qed. Hint Resolve RA_not_written2 : asmgen. +Lemma RA_not_written3: + forall (rs : regset) dst v i, + ireg_of dst = OK i -> + rs # i <- v RA = rs RA. +Proof. + intros. + unfold ireg_of in H. + destruct preg_of eqn:PREG; try discriminate. + replace i0 with i in * by congruence. + eapply RA_not_written2; eassumption. +Qed. + +Hint Resolve RA_not_written3 : asmgen. + Lemma preg_of_iregsp_not_PC: forall r, preg_of_iregsp r <> PC. Proof. destruct r; simpl; congruence. @@ -70,6 +84,26 @@ Proof. red; intros; subst x. elim (preg_of_not_X16 r); auto. Qed. +Lemma ireg_of_not_RA: forall r x, ireg_of r = OK x -> x <> RA. +Proof. + unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H. + red; intros; subst x. elim (preg_of_not_RA r); auto. +Qed. + +Lemma ireg_of_not_RA': forall r x, ireg_of r = OK x -> RA <> x. +Proof. + intros. intro. + apply (ireg_of_not_RA r x); auto. +Qed. + +Lemma ireg_of_not_RA'': forall r x, ireg_of r = OK x -> IR RA <> IR x. +Proof. + intros. intro. + apply (ireg_of_not_RA' r x); auto. congruence. +Qed. + +Hint Resolve ireg_of_not_RA ireg_of_not_RA' ireg_of_not_RA'' : asmgen. + Lemma ireg_of_not_X16': forall r x, ireg_of r = OK x -> IR x <> IR X16. Proof. intros. apply ireg_of_not_X16 in H. congruence. @@ -236,42 +270,49 @@ Qed. Lemma exec_loadimm_k_w: forall (rd: ireg) k m l, wf_decomposition l -> + rd <> RA -> forall (rs: regset) accu, rs#rd = Vint (Int.repr accu) -> exists rs', exec_straight_opt ge fn (loadimm_k W rd l k) rs m k rs' m /\ rs'#rd = Vint (Int.repr (recompose_int accu l)) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. + /\ (forall r, r <> PC -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. - induction 1; intros rs accu ACCU; simpl. + induction 1; intros RD_NOT_RA rs accu ACCU; simpl. - exists rs; split. apply exec_straight_opt_refl. auto. -- destruct (IHwf_decomposition +- destruct (IHwf_decomposition RD_NOT_RA (nextinstr (rs#rd <- (insert_in_int rs#rd n p 16))) (Zinsert accu n p 16)) - as (rs' & P & Q & R). + as (rs' & P & Q & R & S). Simpl. rewrite ACCU. simpl. f_equal. apply Int.eqm_samerepr. apply Zinsert_eqmod. auto. omega. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. exists rs'; split. eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P. - split. exact Q. intros; Simpl. rewrite R by auto. Simpl. + split. exact Q. + split. + { intros; Simpl. + rewrite R by auto. Simpl. } + { rewrite S. Simpl. } Qed. Lemma exec_loadimm_z_w: forall rd l k rs m, wf_decomposition l -> + rd <> RA -> exists rs', exec_straight ge fn (loadimm_z W rd l k) rs m k rs' m /\ rs'#rd = Vint (Int.repr (recompose_int 0 l)) /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - unfold loadimm_z; destruct 1. + unfold loadimm_z; destruct 1; intro RD_NOT_RA. - econstructor; split. apply exec_straight_one. simpl; eauto. auto. split. Simpl. intros; Simpl. - set (accu0 := Zinsert 0 n p 16). set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))). - destruct (exec_loadimm_k_w rd k m l H1 rs1 accu0) as (rs2 & P & Q & R); auto. + destruct (exec_loadimm_k_w rd k m l H1 RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R & S); auto. unfold rs1; Simpl. exists rs2; split. eapply exec_straight_opt_step; eauto. @@ -284,12 +325,13 @@ Qed. Lemma exec_loadimm_n_w: forall rd l k rs m, wf_decomposition l -> + rd <> RA -> exists rs', exec_straight ge fn (loadimm_n W rd l k) rs m k rs' m /\ rs'#rd = Vint (Int.repr (Z.lnot (recompose_int 0 l))) /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - unfold loadimm_n; destruct 1. + unfold loadimm_n; destruct 1; intro RD_NOT_RA. - econstructor; split. apply exec_straight_one. simpl; eauto. auto. split. Simpl. @@ -298,7 +340,8 @@ Proof. set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))). destruct (exec_loadimm_k_w rd k m (negate_decomposition l) (negate_decomposition_wf l H1) - rs1 accu0) as (rs2 & P & Q & R). + RD_NOT_RA rs1 accu0) + as (rs2 & P & Q & R & S). unfold rs1; Simpl. exists rs2; split. eapply exec_straight_opt_step; eauto. @@ -310,7 +353,8 @@ Proof. Qed. Lemma exec_loadimm32: - forall rd n k rs m, + forall rd n k rs m + (RD_NOT_RA : rd <> RA), exists rs', exec_straight ge fn (loadimm32 rd n k) rs m k rs' m /\ rs'#rd = Vint n @@ -333,13 +377,14 @@ Proof. apply Int.eqm_samerepr. apply decompose_notint_eqmod. apply Int.repr_unsigned. } destruct Nat.leb. -+ rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; omega. -+ rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; omega. ++ rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; omega. trivial. ++ rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; omega. trivial. Qed. Lemma exec_loadimm_k_x: forall (rd: ireg) k m l, - wf_decomposition l -> + wf_decomposition l -> + rd <> RA -> forall (rs: regset) accu, rs#rd = Vlong (Int64.repr accu) -> exists rs', @@ -347,9 +392,9 @@ Lemma exec_loadimm_k_x: /\ rs'#rd = Vlong (Int64.repr (recompose_int accu l)) /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - induction 1; intros rs accu ACCU; simpl. + induction 1; intros RD_NOT_RA rs accu ACCU; simpl. - exists rs; split. apply exec_straight_opt_refl. auto. -- destruct (IHwf_decomposition +- destruct (IHwf_decomposition RD_NOT_RA (nextinstr (rs#rd <- (insert_in_long rs#rd n p 16))) (Zinsert accu n p 16)) as (rs' & P & Q & R). @@ -363,19 +408,20 @@ Qed. Lemma exec_loadimm_z_x: forall rd l k rs m, wf_decomposition l -> + rd <> RA -> exists rs', exec_straight ge fn (loadimm_z X rd l k) rs m k rs' m /\ rs'#rd = Vlong (Int64.repr (recompose_int 0 l)) /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - unfold loadimm_z; destruct 1. + unfold loadimm_z; destruct 1; intro RD_NOT_RA. - econstructor; split. apply exec_straight_one. simpl; eauto. auto. split. Simpl. intros; Simpl. - set (accu0 := Zinsert 0 n p 16). set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))). - destruct (exec_loadimm_k_x rd k m l H1 rs1 accu0) as (rs2 & P & Q & R); auto. + destruct (exec_loadimm_k_x rd k m l H1 RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R); auto. unfold rs1; Simpl. exists rs2; split. eapply exec_straight_opt_step; eauto. @@ -388,12 +434,13 @@ Qed. Lemma exec_loadimm_n_x: forall rd l k rs m, wf_decomposition l -> + rd <> RA -> exists rs', exec_straight ge fn (loadimm_n X rd l k) rs m k rs' m /\ rs'#rd = Vlong (Int64.repr (Z.lnot (recompose_int 0 l))) /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - unfold loadimm_n; destruct 1. + unfold loadimm_n; destruct 1; intro RD_NOT_RA. - econstructor; split. apply exec_straight_one. simpl; eauto. auto. split. Simpl. @@ -402,7 +449,7 @@ Proof. set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))). destruct (exec_loadimm_k_x rd k m (negate_decomposition l) (negate_decomposition_wf l H1) - rs1 accu0) as (rs2 & P & Q & R). + RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R). unfold rs1; Simpl. exists rs2; split. eapply exec_straight_opt_step; eauto. @@ -415,12 +462,13 @@ Qed. Lemma exec_loadimm64: forall rd n k rs m, + rd <> RA -> exists rs', exec_straight ge fn (loadimm64 rd n k) rs m k rs' m /\ rs'#rd = Vlong n /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - unfold loadimm64, loadimm; intros. + unfold loadimm64, loadimm; intros until m; intro RD_NOT_RA. destruct (is_logical_imm64 n). - econstructor; split. apply exec_straight_one. simpl; eauto. auto. @@ -437,8 +485,8 @@ Proof. apply Int64.eqm_samerepr. apply decompose_notint_eqmod. apply Int64.repr_unsigned. } destruct Nat.leb. -+ rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; omega. -+ rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; omega. ++ rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; omega. trivial. ++ rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; omega. trivial. Qed. (** Add immediate *) @@ -450,55 +498,59 @@ Lemma exec_addimm_aux_32: Next (nextinstr (rs#rd <- (sem rs#r1 (Vint (Int.repr n))))) m) -> (forall v n1 n2, sem (sem v (Vint n1)) (Vint n2) = sem v (Vint (Int.add n1 n2))) -> forall rd r1 n k rs m, + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (addimm_aux insn rd r1 (Int.unsigned n) k) rs m k rs' m /\ rs'#rd = sem rs#r1 (Vint n) - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. - intros insn sem SEM ASSOC; intros. unfold addimm_aux. + intros insn sem SEM ASSOC; intros until m; intro RD_NOT_RA. unfold addimm_aux. set (nlo := Zzero_ext 12 (Int.unsigned n)). set (nhi := Int.unsigned n - nlo). assert (E: Int.unsigned n = nhi + nlo) by (unfold nhi; omega). rewrite <- (Int.repr_unsigned n). destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. split. Simpl. do 3 f_equal; omega. - intros; Simpl. + split; intros; Simpl. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. split. Simpl. do 3 f_equal; omega. - intros; Simpl. + split; intros; Simpl. - econstructor; split. eapply exec_straight_two. apply SEM. apply SEM. Simpl. Simpl. split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int.eqm_samerepr. rewrite E. auto with ints. - intros; Simpl. + split; intros; Simpl. Qed. Lemma exec_addimm32: forall rd r1 n k rs m, r1 <> X16 -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (addimm32 rd r1 n k) rs m k rs' m /\ rs'#rd = Val.add rs#r1 (Vint n) - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros. unfold addimm32. set (nn := Int.neg n). destruct (Int.eq n (Int.zero_ext 24 n)); [| destruct (Int.eq nn (Int.zero_ext 24 nn))]. -- apply exec_addimm_aux_32 with (sem := Val.add). auto. intros; apply Val.add_assoc. +- apply exec_addimm_aux_32 with (sem := Val.add); auto. intros; apply Val.add_assoc. - rewrite <- Val.sub_opp_add. - apply exec_addimm_aux_32 with (sem := Val.sub). auto. + apply exec_addimm_aux_32 with (sem := Val.sub); auto. intros. rewrite ! Val.sub_add_opp, Val.add_assoc. rewrite Int.neg_add_distr. auto. - destruct (Int.lt n Int.zero). + rewrite <- Val.sub_opp_add; fold nn. - edestruct (exec_loadimm32 X16 nn) as (rs1 & A & B & C). + edestruct (exec_loadimm32 X16 nn) as (rs1 & A & B & C). congruence. econstructor; split. eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. split. Simpl. rewrite B, C; eauto with asmgen. - intros; Simpl. -+ edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). + split; intros; Simpl. ++ edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). congruence. econstructor; split. eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. split. Simpl. rewrite B, C; eauto with asmgen. - intros; Simpl. + split; intros; Simpl. Qed. Lemma exec_addimm_aux_64: @@ -508,10 +560,12 @@ Lemma exec_addimm_aux_64: Next (nextinstr (rs#rd <- (sem rs#r1 (Vlong (Int64.repr n))))) m) -> (forall v n1 n2, sem (sem v (Vlong n1)) (Vlong n2) = sem v (Vlong (Int64.add n1 n2))) -> forall rd r1 n k rs m, + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (addimm_aux insn rd r1 (Int64.unsigned n) k) rs m k rs' m /\ rs'#rd = sem rs#r1 (Vlong n) - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros insn sem SEM ASSOC; intros. unfold addimm_aux. set (nlo := Zzero_ext 12 (Int64.unsigned n)). set (nhi := Int64.unsigned n - nlo). @@ -520,44 +574,46 @@ Proof. destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. split. Simpl. do 3 f_equal; omega. - intros; Simpl. + split; intros; Simpl. - econstructor; split. apply exec_straight_one. apply SEM. Simpl. split. Simpl. do 3 f_equal; omega. - intros; Simpl. + split; intros; Simpl. - econstructor; split. eapply exec_straight_two. apply SEM. apply SEM. Simpl. Simpl. split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int64.eqm_samerepr. rewrite E. auto with ints. - intros; Simpl. + split; intros; Simpl. Qed. Lemma exec_addimm64: forall rd r1 n k rs m, preg_of_iregsp r1 <> X16 -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (addimm64 rd r1 n k) rs m k rs' m /\ rs'#rd = Val.addl rs#r1 (Vlong n) - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros. unfold addimm64. set (nn := Int64.neg n). destruct (Int64.eq n (Int64.zero_ext 24 n)); [| destruct (Int64.eq nn (Int64.zero_ext 24 nn))]. -- apply exec_addimm_aux_64 with (sem := Val.addl). auto. intros; apply Val.addl_assoc. +- apply exec_addimm_aux_64 with (sem := Val.addl); auto. intros; apply Val.addl_assoc. - rewrite <- Val.subl_opp_addl. - apply exec_addimm_aux_64 with (sem := Val.subl). auto. + apply exec_addimm_aux_64 with (sem := Val.subl); auto. intros. rewrite ! Val.subl_addl_opp, Val.addl_assoc. rewrite Int64.neg_add_distr. auto. - destruct (Int64.lt n Int64.zero). + rewrite <- Val.subl_opp_addl; fold nn. - edestruct (exec_loadimm64 X16 nn) as (rs1 & A & B & C). + edestruct (exec_loadimm64 X16 nn) as (rs1 & A & B & C). congruence. econstructor; split. eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. - intros; Simpl. -+ edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). + split; intros; Simpl. ++ edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). congruence. econstructor; split. eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. - intros; Simpl. + split; intros; Simpl. Qed. (** Logical immediate *) @@ -574,22 +630,25 @@ Lemma exec_logicalimm32: Next (nextinstr (rs#rd <- (sem rs##r1 (eval_shift_op_int rs#r2 s)))) m) -> forall rd r1 n k rs m, r1 <> X16 -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (logicalimm32 insn1 insn2 rd r1 n k) rs m k rs' m /\ rs'#rd = sem rs#r1 (Vint n) - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros until sem; intros SEM1 SEM2; intros. unfold logicalimm32. destruct (is_logical_imm32 n). - econstructor; split. apply exec_straight_one. apply SEM1. reflexivity. - split. Simpl. rewrite Int.repr_unsigned; auto. intros; Simpl. -- edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). + split. Simpl. rewrite Int.repr_unsigned; auto. + split; intros; Simpl. +- edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). congruence. econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. apply SEM2. reflexivity. split. Simpl. f_equal; auto. apply C; auto with asmgen. - intros; Simpl. + split; intros; Simpl. Qed. Lemma exec_logicalimm64: @@ -604,50 +663,58 @@ Lemma exec_logicalimm64: Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) -> forall rd r1 n k rs m, r1 <> X16 -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (logicalimm64 insn1 insn2 rd r1 n k) rs m k rs' m /\ rs'#rd = sem rs#r1 (Vlong n) - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros until sem; intros SEM1 SEM2; intros. unfold logicalimm64. destruct (is_logical_imm64 n). - econstructor; split. apply exec_straight_one. apply SEM1. reflexivity. - split. Simpl. rewrite Int64.repr_unsigned. auto. intros; Simpl. -- edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). + split. Simpl. rewrite Int64.repr_unsigned. auto. + split; intros; Simpl. +- edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). congruence. econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. apply SEM2. reflexivity. split. Simpl. f_equal; auto. apply C; auto with asmgen. - intros; Simpl. + split; intros; Simpl. Qed. (** Load address of symbol *) Lemma exec_loadsymbol: forall rd s ofs k rs m, - rd <> X16 \/ Archi.pic_code tt = false -> + rd <> X16 \/ Archi.pic_code tt = false -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (loadsymbol rd s ofs k) rs m k rs' m /\ rs'#rd = Genv.symbol_address ge s ofs - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs'#RA = rs#RA. Proof. unfold loadsymbol; intros. destruct (Archi.pic_code tt). - predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero. + subst ofs. econstructor; split. apply exec_straight_one; [simpl; eauto | reflexivity]. - split. Simpl. intros; Simpl. + split. Simpl. split; intros; Simpl. + + exploit exec_addimm64. instantiate (1 := rd). simpl. destruct H; congruence. - intros (rs1 & A & B & C). + instantiate (1 := rd). assumption. + intros (rs1 & A & B & C & D). econstructor; split. econstructor. simpl; eauto. auto. eexact A. split. simpl in B; rewrite B. Simpl. rewrite <- Genv.shift_symbol_address_64 by auto. rewrite Ptrofs.add_zero_l, Ptrofs.of_int64_to_int64 by auto. auto. - intros. rewrite C by auto. Simpl. + split; intros. rewrite C by auto; Simpl. + rewrite D. Simpl. - econstructor; split. eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. split. Simpl. rewrite symbol_high_low; auto. - intros; Simpl. + split; intros; Simpl. Qed. (** Shifted operands *) @@ -756,23 +823,25 @@ Lemma exec_arith_extended: Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) -> forall (rd r1 r2: ireg) (ex: extension) (a: amount64) (k: code) rs m, r1 <> X16 -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (arith_extended insnX insnS rd r1 r2 ex a k) rs m k rs' m /\ rs'#rd = sem rs#r1 (Op.eval_extend ex rs#r2 a) - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros sem insnX insnS EX ES; intros. unfold arith_extended. destruct (Int.ltu a (Int.repr 5)). - econstructor; split. apply exec_straight_one. rewrite EX; eauto. auto. split. Simpl. f_equal. destruct ex; auto. - intros; Simpl. + split; intros; Simpl. - exploit (exec_move_extended_base X16 r2 ex). intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. rewrite ES. eauto. auto. split. Simpl. unfold ir0x. rewrite C by eauto with asmgen. f_equal. rewrite B. destruct ex; auto. - intros; Simpl. + split; intros; Simpl. Qed. (** Extended right shift *) @@ -780,41 +849,49 @@ Qed. Lemma exec_shrx32: forall (rd r1: ireg) (n: int) k v (rs: regset) m, Val.shrx rs#r1 (Vint n) = Some v -> r1 <> X16 -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (shrx32 rd r1 n k) rs m k rs' m /\ rs'#rd = v - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. unfold shrx32; intros. apply Val.shrx_shr_2 in H. destruct (Int.eq n Int.zero) eqn:E. - econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. - split. Simpl. subst v; auto. intros; Simpl. + split. Simpl. subst v; auto. + split; intros; Simpl. - econstructor; split. eapply exec_straight_three. unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. simpl; eauto. unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. auto. auto. auto. - split. subst v; Simpl. intros; Simpl. + split. subst v; Simpl. + split; intros; Simpl. Qed. Lemma exec_shrx64: forall (rd r1: ireg) (n: int) k v (rs: regset) m, Val.shrxl rs#r1 (Vint n) = Some v -> r1 <> X16 -> + (IR RA) <> (preg_of_iregsp (RR1 rd)) -> exists rs', exec_straight ge fn (shrx64 rd r1 n k) rs m k rs' m /\ rs'#rd = v - /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. unfold shrx64; intros. apply Val.shrxl_shrl_2 in H. destruct (Int.eq n Int.zero) eqn:E. - econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. - split. Simpl. subst v; auto. intros; Simpl. + split. Simpl. subst v; auto. + split; intros; Simpl. - econstructor; split. eapply exec_straight_three. unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. simpl; eauto. unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. auto. auto. auto. - split. subst v; Simpl. intros; Simpl. + split. subst v; Simpl. + split; intros; Simpl. Qed. (** Condition bits *) @@ -1070,6 +1147,56 @@ Ltac ArgsInv := | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * end). +Lemma compare_int_RA: + forall rs a b m, + compare_int rs a b m X30 = rs X30. +Proof. + unfold compare_int. + intros. + repeat rewrite Pregmap.gso by congruence. + trivial. +Qed. + +Hint Resolve compare_int_RA : asmgen. + +Lemma compare_long_RA: + forall rs a b m, + compare_long rs a b m X30 = rs X30. +Proof. + unfold compare_long. + intros. + repeat rewrite Pregmap.gso by congruence. + trivial. +Qed. + +Hint Resolve compare_long_RA : asmgen. + +Lemma compare_float_RA: + forall rs a b, + compare_float rs a b X30 = rs X30. +Proof. + unfold compare_float. + intros. + destruct a; destruct b. + all: repeat rewrite Pregmap.gso by congruence; trivial. +Qed. + +Hint Resolve compare_float_RA : asmgen. + + +Lemma compare_single_RA: + forall rs a b, + compare_single rs a b X30 = rs X30. +Proof. + unfold compare_single. + intros. + destruct a; destruct b. + all: repeat rewrite Pregmap.gso by congruence; trivial. +Qed. + +Hint Resolve compare_single_RA : asmgen. + + Lemma transl_cond_correct: forall cond args k c rs m, transl_cond cond args k = OK c -> @@ -1078,185 +1205,218 @@ Lemma transl_cond_correct: /\ (forall b, eval_condition cond (map rs (map preg_of args)) m = Some b -> eval_testcond (cond_for_cond cond) rs' = Some b) - /\ forall r, data_preg r = true -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros until m; intros TR. destruct cond; simpl in TR; ArgsInv. - (* Ccomp *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. apply eval_testcond_compare_sint; auto. + repeat split; intros. apply eval_testcond_compare_sint; auto. destruct r; reflexivity || discriminate. - (* Ccompu *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. apply eval_testcond_compare_uint; auto. + repeat split; intros. apply eval_testcond_compare_uint; auto. destruct r; reflexivity || discriminate. - (* Ccompimm *) destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_sint; auto. + repeat split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_sint; auto. destruct r; reflexivity || discriminate. + econstructor; split. apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. - split; intros. apply eval_testcond_compare_sint; auto. + repeat split; intros. apply eval_testcond_compare_sint; auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). ++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply eval_testcond_compare_sint; auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + repeat split; intros. apply eval_testcond_compare_sint; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. + auto with asmgen. + Simpl. rewrite compare_int_RA. + apply C; congruence. - (* Ccompuimm *) destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_uint; auto. + repeat split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_uint; auto. destruct r; reflexivity || discriminate. + econstructor; split. apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. - split; intros. apply eval_testcond_compare_uint; auto. + repeat split; intros. apply eval_testcond_compare_uint; auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). ++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply eval_testcond_compare_uint; auto. + repeat split; intros. apply eval_testcond_compare_uint; auto. transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + Simpl. rewrite compare_int_RA. + apply C; congruence. - (* Ccompshift *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_sint; auto. + repeat split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_sint; auto. destruct r; reflexivity || discriminate. - (* Ccompushift *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_uint; auto. + repeat split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_uint; auto. destruct r; reflexivity || discriminate. - (* Cmaskzero *) destruct (is_logical_imm32 n). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Ceq); auto. + repeat split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Ceq); auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). ++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply (eval_testcond_compare_sint Ceq); auto. + repeat split; intros. apply (eval_testcond_compare_sint Ceq); auto. transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + Simpl. rewrite compare_int_RA. + apply C; congruence. + - (* Cmasknotzero *) destruct (is_logical_imm32 n). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Cne); auto. + repeat split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Cne); auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + ++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply (eval_testcond_compare_sint Cne); auto. + repeat split; intros. apply (eval_testcond_compare_sint Cne); auto. transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + Simpl. rewrite compare_int_RA. + apply C; congruence. + - (* Ccompl *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. apply eval_testcond_compare_slong; auto. + repeat split; intros. apply eval_testcond_compare_slong; auto. destruct r; reflexivity || discriminate. - (* Ccomplu *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. apply eval_testcond_compare_ulong; auto. + repeat split; intros. apply eval_testcond_compare_ulong; auto. destruct r; reflexivity || discriminate. - (* Ccomplimm *) destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_slong; auto. + repeat split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_slong; auto. destruct r; reflexivity || discriminate. + econstructor; split. apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto. - split; intros. apply eval_testcond_compare_slong; auto. + repeat split; intros. apply eval_testcond_compare_slong; auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). ++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply eval_testcond_compare_slong; auto. + repeat split; intros. apply eval_testcond_compare_slong; auto. transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + Simpl. rewrite compare_long_RA. + apply C; congruence. + - (* Ccompluimm *) destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_ulong; auto. + repeat split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_ulong; auto. destruct r; reflexivity || discriminate. + econstructor; split. apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto. - split; intros. apply eval_testcond_compare_ulong; auto. + repeat split; intros. apply eval_testcond_compare_ulong; auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). ++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply eval_testcond_compare_ulong; auto. + repeat split; intros. apply eval_testcond_compare_ulong; auto. transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + Simpl. rewrite compare_long_RA. + apply C; congruence. + - (* Ccomplshift *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_slong; auto. + repeat split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_slong; auto. destruct r; reflexivity || discriminate. - (* Ccomplushift *) econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_ulong; auto. + repeat split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_ulong; auto. destruct r; reflexivity || discriminate. - (* Cmasklzero *) destruct (is_logical_imm64 n). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Ceq); auto. + repeat split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Ceq); auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). ++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply (eval_testcond_compare_slong Ceq); auto. + repeat split; intros. apply (eval_testcond_compare_slong Ceq); auto. transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + Simpl. rewrite compare_long_RA. + apply C; congruence. + - (* Cmasknotzero *) destruct (is_logical_imm64 n). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Cne); auto. + repeat split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Cne); auto. destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). ++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - split; intros. apply (eval_testcond_compare_slong Cne); auto. + repeat split; intros. apply (eval_testcond_compare_slong Cne); auto. transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + Simpl. rewrite compare_long_RA. + apply C; congruence. + - (* Ccompf *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_float_inv; auto. - split; intros. apply eval_testcond_compare_float; auto. + repeat split; intros. apply eval_testcond_compare_float; auto. destruct r; discriminate || rewrite compare_float_inv; auto. + Simpl. - (* Cnotcompf *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_float_inv; auto. - split; intros. apply eval_testcond_compare_not_float; auto. + repeat split; intros. apply eval_testcond_compare_not_float; auto. destruct r; discriminate || rewrite compare_float_inv; auto. + Simpl. - (* Ccompfzero *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_float_inv; auto. - split; intros. apply eval_testcond_compare_float; auto. + repeat split; intros. apply eval_testcond_compare_float; auto. destruct r; discriminate || rewrite compare_float_inv; auto. + Simpl. - (* Cnotcompfzero *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_float_inv; auto. - split; intros. apply eval_testcond_compare_not_float; auto. + repeat split; intros. apply eval_testcond_compare_not_float; auto. destruct r; discriminate || rewrite compare_float_inv; auto. + Simpl. - (* Ccompfs *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_single_inv; auto. - split; intros. apply eval_testcond_compare_single; auto. + repeat split; intros. apply eval_testcond_compare_single; auto. destruct r; discriminate || rewrite compare_single_inv; auto. + Simpl. - (* Cnotcompfs *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_single_inv; auto. - split; intros. apply eval_testcond_compare_not_single; auto. + repeat split; intros. apply eval_testcond_compare_not_single; auto. destruct r; discriminate || rewrite compare_single_inv; auto. + Simpl. - (* Ccompfszero *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_single_inv; auto. - split; intros. apply eval_testcond_compare_single; auto. + repeat split; intros. apply eval_testcond_compare_single; auto. destruct r; discriminate || rewrite compare_single_inv; auto. + Simpl. - (* Cnotcompfszero *) econstructor; split. apply exec_straight_one. simpl; eauto. rewrite compare_single_inv; auto. - split; intros. apply eval_testcond_compare_not_single; auto. + repeat split; intros. apply eval_testcond_compare_not_single; auto. destruct r; discriminate || rewrite compare_single_inv; auto. + Simpl. Qed. (** Translation of conditional branches *) @@ -1379,7 +1539,7 @@ Ltac TranslOpSimpl := | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; apply Val.lessdef_same; Simpl; fail | split; [ intros; Simpl; fail - | intros; Simpl; eapply RA_not_written2; eauto] ]]. + | intros; Simpl; eauto with asmgen; fail] ]]. Ltac TranslOpBase := econstructor; split; @@ -1405,11 +1565,19 @@ Local Opaque Int.eq Int64.eq Val.add Val.addl Int.zwordsize Int64.zwordsize. destruct (preg_of res) eqn:RR; try discriminate; destruct (preg_of m0) eqn:R1; inv TR. all: TranslOpSimpl. - (* intconst *) - exploit exec_loadimm32. intros (rs' & A & B & C). - exists rs'; split. eexact A. split. rewrite B; auto. intros; auto with asmgen. + exploit exec_loadimm32. apply (ireg_of_not_RA res); eassumption. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. + split. intros; auto with asmgen. + apply C. congruence. + eapply ireg_of_not_RA''; eauto. - (* longconst *) - exploit exec_loadimm64. intros (rs' & A & B & C). - exists rs'; split. eexact A. split. rewrite B; auto. intros; auto with asmgen. + exploit exec_loadimm64. apply (ireg_of_not_RA res); eassumption. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. + split. intros; auto with asmgen. + apply C. congruence. + eapply ireg_of_not_RA''; eauto. - (* floatconst *) destruct (Float.eq_dec n Float.zero). + subst n. TranslOpSimpl. @@ -1419,11 +1587,15 @@ Local Opaque Int.eq Int64.eq Val.add Val.addl Int.zwordsize Int64.zwordsize. + subst n. TranslOpSimpl. + TranslOpSimpl. - (* loadsymbol *) - exploit (exec_loadsymbol x id ofs). eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split. eexact A. split. rewrite B; auto. auto. + exploit (exec_loadsymbol x id ofs). eauto with asmgen. + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). + exists rs'; split. eexact A. split. rewrite B; auto. + split; auto. - (* addrstack *) exploit (exec_addimm64 x XSP (Ptrofs.to_int64 ofs)). simpl; eauto with asmgen. - intros (rs' & A & B & C). + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). exists rs'; split. eexact A. split. simpl in B; rewrite B. Local Transparent Val.addl. destruct (rs SP); simpl; auto. rewrite Ptrofs.of_int64_to_int64 by auto. auto. @@ -1431,7 +1603,8 @@ Local Transparent Val.addl. - (* shift *) rewrite <- transl_eval_shift'. TranslOpSimpl. - (* addimm *) - exploit (exec_addimm32 x x0 n). eauto with asmgen. intros (rs' & A & B & C). + exploit (exec_addimm32 x x0 n). eauto with asmgen. eapply ireg_of_not_RA''; eassumption. + intros (rs' & A & B & C & D). exists rs'; split. eexact A. split. rewrite B; auto. auto. - (* mul *) TranslOpBase. @@ -1439,18 +1612,20 @@ Local Transparent Val.add. destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int.add_zero_l; auto. - (* andimm *) exploit (exec_logicalimm32 (Pandimm W) (Pand W)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split. eexact A. split. rewrite B; auto. auto. + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). + exists rs'; split. eexact A. split. rewrite B; auto. + split; auto. - (* orimm *) exploit (exec_logicalimm32 (Porrimm W) (Porr W)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split. eexact A. split. rewrite B; auto. auto. + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). + exists rs'; split. eexact A. split. rewrite B; auto. + split; auto. - (* xorimm *) exploit (exec_logicalimm32 (Peorimm W) (Peor W)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - intros (rs' & A & B & C). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). exists rs'; split. eexact A. split. rewrite B; auto. auto. - (* not *) TranslOpBase. @@ -1459,8 +1634,10 @@ Local Transparent Val.add. TranslOpBase. destruct (eval_shift s (rs x0) a); auto. simpl. rewrite Int.or_zero_l; auto. - (* shrx *) - exploit (exec_shrx32 x x0 n); eauto with asmgen. intros (rs' & A & B & C). - econstructor; split. eexact A. split. rewrite B; auto. auto. + exploit (exec_shrx32 x x0 n); eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). + econstructor; split. eexact A. split. rewrite B; auto. + split; auto. - (* zero-ext *) TranslOpBase. destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto. @@ -1484,36 +1661,47 @@ Local Transparent Val.add. - (* extend *) exploit (exec_move_extended x0 x1 x a k). intros (rs' & A & B & C). econstructor; split. eexact A. - split. rewrite B; auto. eauto with asmgen. + split. rewrite B; auto. + split; eauto with asmgen. - (* addext *) exploit (exec_arith_extended Val.addl Paddext (Padd X)). - auto. auto. instantiate (1 := x1). eauto with asmgen. intros (rs' & A & B & C). - econstructor; split. eexact A. split. rewrite B; auto. auto. + auto. auto. instantiate (1 := x1). eauto with asmgen. + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). + econstructor; split. eexact A. split. rewrite B; auto. + split; auto. - (* addlimm *) exploit (exec_addimm64 x x0 n). simpl. generalize (ireg_of_not_X16 _ _ EQ1). congruence. - intros (rs' & A & B & C). + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). exists rs'; split. eexact A. split. simpl in B; rewrite B; auto. auto. - (* subext *) exploit (exec_arith_extended Val.subl Psubext (Psub X)). - auto. auto. instantiate (1 := x1). eauto with asmgen. intros (rs' & A & B & C). - econstructor; split. eexact A. split. rewrite B; auto. auto. + auto. auto. instantiate (1 := x1). eauto with asmgen. + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). + econstructor; split. eexact A. split. rewrite B; auto. + split; auto. - (* mull *) TranslOpBase. destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int64.add_zero_l; auto. - (* andlimm *) exploit (exec_logicalimm64 (Pandimm X) (Pand X)). intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - intros (rs' & A & B & C). + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). exists rs'; split. eexact A. split. rewrite B; auto. auto. - (* orlimm *) exploit (exec_logicalimm64 (Porrimm X) (Porr X)). intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - intros (rs' & A & B & C). + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). exists rs'; split. eexact A. split. rewrite B; auto. auto. - (* xorlimm *) exploit (exec_logicalimm64 (Peorimm X) (Peor X)). intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - intros (rs' & A & B & C). + apply (ireg_of_not_RA'' res); eassumption. + intros (rs' & A & B & C & D). exists rs'; split. eexact A. split. rewrite B; auto. auto. - (* notl *) TranslOpBase. @@ -1522,7 +1710,8 @@ Local Transparent Val.add. TranslOpBase. destruct (eval_shiftl s (rs x0) a); auto. simpl. rewrite Int64.or_zero_l; auto. - (* shrx *) - exploit (exec_shrx64 x x0 n); eauto with asmgen. intros (rs' & A & B & C). + exploit (exec_shrx64 x x0 n); eauto with asmgen. + apply (ireg_of_not_RA'' res); eassumption. intros (rs' & A & B & C & D ). econstructor; split. eexact A. split. rewrite B; auto. auto. - (* zero-ext-l *) TranslOpBase. -- cgit From 6d5718dae13e8db5fc85feb86395dd3dc785dfda Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Mar 2020 23:46:19 +0100 Subject: transl_op_correct --- aarch64/Asmgenproof1.v | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 96561da7..1471ee4f 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -1429,7 +1429,8 @@ Lemma transl_cond_branch_correct: exec_straight_opt ge fn c rs m (insn :: k) rs' m /\ exec_instr ge fn insn rs' m = (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m) - /\ forall r, data_preg r = true -> rs'#r = rs#r. + /\ (forall r, data_preg r = true -> rs'#r = rs#r) + /\ rs' # RA = rs # RA. Proof. intros until b; intros TR EV. assert (DFL: @@ -1438,13 +1439,14 @@ Proof. exec_straight_opt ge fn c rs m (insn :: k) rs' m /\ exec_instr ge fn insn rs' m = (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m) - /\ forall r, data_preg r = true -> rs'#r = rs#r). + /\ (forall r, data_preg r = true -> rs'#r = rs#r) + /\ rs' # RA = rs # RA ). { unfold transl_cond_branch_default; intros. - exploit transl_cond_correct; eauto. intros (rs' & A & B & C). + exploit transl_cond_correct; eauto. intros (rs' & A & B & C & D). exists rs', (Pbc (cond_for_cond cond) lbl); split. apply exec_straight_opt_intro. eexact A. - split; auto. simpl. rewrite (B b) by auto. auto. + repeat split; auto. simpl. rewrite (B b) by auto. auto. } Local Opaque transl_cond transl_cond_branch_default. destruct args as [ | a1 args]; simpl in TR; auto. @@ -1732,35 +1734,37 @@ Local Transparent Val.add. TranslOpBase. destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.sign_ext_shr'_min; auto using a64_range. - (* condition *) - exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. rewrite (B b) by auto. auto. auto. - intros; Simpl. + split; intros; Simpl. - (* select *) destruct (preg_of res) eqn:RES; monadInv TR. + (* integer *) generalize (ireg_of_eq _ _ EQ) (ireg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. - exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. auto. - intros; Simpl. + split; intros; Simpl. + rewrite <- D. + eapply RA_not_written2; eassumption. + (* FP *) generalize (freg_of_eq _ _ EQ) (freg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. - exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. auto. - intros; Simpl. + split; intros; Simpl. Qed. (** Translation of addressing modes, loads, stores *) -- cgit From 2729bdeb4aced04a1301d5696574ff8610072395 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Mar 2020 23:52:22 +0100 Subject: transl_addressing_correct --- aarch64/Asmgenproof1.v | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 1471ee4f..4da1b52b 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -1784,7 +1784,7 @@ Proof. destruct (offset_representable sz ofs); inv EQ0. + econstructor; econstructor; split. apply exec_straight_opt_refl. auto. -+ exploit (exec_loadimm64 X16 ofs). intros (rs' & A & B & C). ++ exploit (exec_loadimm64 X16 ofs). congruence. intros (rs' & A & B & C). econstructor; exists rs'; split. apply exec_straight_opt_intro; eexact A. split. simpl. rewrite B, C by eauto with asmgen. auto. eauto with asmgen. @@ -1810,7 +1810,8 @@ Proof. split; auto. destruct x; auto. + exploit (exec_arith_extended Val.addl Paddext (Padd X)); auto. instantiate (1 := x0). eauto with asmgen. - intros (rs' & A & B & C). + instantiate (1 := X16). simpl. congruence. + intros (rs' & A & B & C & D). econstructor; exists rs'; split. apply exec_straight_opt_intro. eexact A. split. simpl. rewrite B. rewrite Val.addl_assoc. f_equal. @@ -1823,7 +1824,9 @@ Proof. apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. split. simpl. Simpl. rewrite symbol_high_low. simpl in EV. congruence. intros; Simpl. -+ exploit (exec_loadsymbol X16 id ofs). auto. intros (rs' & A & B & C). ++ exploit (exec_loadsymbol X16 id ofs). auto. + simpl. congruence. + intros (rs' & A & B & C & D). econstructor; exists rs'; split. apply exec_straight_opt_intro. eexact A. split. simpl. @@ -1837,7 +1840,9 @@ Proof. destruct (offset_representable sz (Ptrofs.to_int64 ofs)); inv TR. + econstructor; econstructor; split. apply exec_straight_opt_refl. auto. -+ exploit (exec_loadimm64 X16 (Ptrofs.to_int64 ofs)). intros (rs' & A & B & C). ++ exploit (exec_loadimm64 X16 (Ptrofs.to_int64 ofs)). + simpl. congruence. + intros (rs' & A & B & C). econstructor; exists rs'; split. apply exec_straight_opt_intro. eexact A. split. simpl. rewrite B, C by eauto with asmgen. auto. -- cgit From 6a05fbf4b55dfdf2884c3e0b2cb57d707ad1598d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 24 Mar 2020 23:53:42 +0100 Subject: Asmgenproof1 --- aarch64/Asmgenproof1.v | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 4da1b52b..bd1474b6 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -1932,7 +1932,9 @@ Proof. { destruct (rs base); try discriminate. simpl in *. rewrite Ptrofs.of_int64_to_int64 by auto. auto. } destruct offset_representable. - econstructor; econstructor; split. apply exec_straight_opt_refl. auto. -- exploit (exec_loadimm64 X16); eauto. intros (rs' & A & B & C). +- exploit (exec_loadimm64 X16); eauto. + simpl. congruence. + intros (rs' & A & B & C). econstructor; econstructor; split. apply exec_straight_opt_intro; eexact A. split. simpl. rewrite B, C by eauto with asmgen. auto. auto. Qed. -- cgit From ef9c9d4eb1e6e4ed1db4b57d647d60b0491e63ca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 25 Mar 2020 00:13:38 +0100 Subject: proof forward --- aarch64/Asmgenproof.v | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index 0dc37f36..0b863162 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -716,7 +716,7 @@ Opaque loadind. exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + exploit transl_op_correct; eauto. intros [rs2 [P [Q [R S]]]]. exists rs2; split. eauto. split. apply agree_set_undef_mreg with rs0; auto. apply Val.lessdef_trans with v'; auto. @@ -724,7 +724,8 @@ Opaque loadind. rewrite R; auto. apply preg_of_not_X29; auto. Local Transparent destroyed_by_op. destruct op; try exact I; simpl; congruence. - + rewrite S. + auto. - (* Mload *) assert (Op.eval_addressing tge sp addr (map rs args) = Some a). { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. } @@ -732,10 +733,11 @@ Local Transparent destroyed_by_op. intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. + exploit transl_load_correct; eauto. intros [rs2 [P [Q [R S]]]]. exists rs2; split. eauto. split. eapply agree_set_undef_mreg; eauto. congruence. - simpl; congruence. + split. simpl; congruence. + rewrite S. assumption. - (* Mstore *) assert (Op.eval_addressing tge sp addr (map rs args) = Some a). @@ -745,10 +747,11 @@ Local Transparent destroyed_by_op. assert (Val.lessdef (rs src) (rs0 (preg_of src))) by (eapply preg_val; eauto). exploit Mem.storev_extends; eauto. intros [m2' [C D]]. left; eapply exec_straight_steps; eauto. - intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P [Q R]]]. exists rs2; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. - simpl; congruence. + split. simpl; congruence. + rewrite R. assumption. - (* Mcall *) assert (f0 = f) by congruence. subst f0. @@ -857,6 +860,18 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. congruence. + Simpl. + rewrite set_res_other by trivial. + rewrite undef_regs_other. + assumption. + intro. + rewrite in_map_iff. + intros (x0 & PREG & IN). + subst r'. + intro. + apply (preg_of_not_RA x0). + congruence. + - (* Mgoto *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H4. @@ -870,6 +885,9 @@ Local Transparent destroyed_by_op. eapply agree_exten; eauto with asmgen. congruence. + rewrite INV by congruence. + assumption. + - (* Mcond true *) assert (f0 = f) by congruence. subst f0. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. -- cgit From 0e42b14d8e3c1a87a0242468bb5ace8ec8f9ef9a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 25 Mar 2020 00:25:05 +0100 Subject: proof forward --- aarch64/Asmgenproof.v | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index 0b863162..e7b13cc9 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -893,20 +893,25 @@ Local Transparent destroyed_by_op. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_opt_steps_goto; eauto. intros. simpl in TR. - exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C). + exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C & D). exists jmp; exists k; exists rs'. split. eexact A. split. apply agree_exten with rs0; auto with asmgen. - exact B. + split. + exact B. + rewrite D. exact LEAF. - (* Mcond false *) exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C). + exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C & D). econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. eexact B. auto. split. apply agree_exten with rs0; auto. intros. Simpl. + split. simpl; congruence. + Simpl. rewrite D. + exact LEAF. - (* Mjumptable *) assert (f0 = f) by congruence. subst f0. @@ -928,6 +933,10 @@ Local Transparent destroyed_by_op. simpl. intros. rewrite C; auto with asmgen. Simpl. congruence. + rewrite C by congruence. + repeat rewrite Pregmap.gso by congruence. + assumption. + - (* Mreturn *) assert (f0 = f) by congruence. subst f0. inversion AT; subst. simpl in H6; monadInv H6. @@ -970,7 +979,7 @@ Local Transparent destroyed_by_op. simpl preg_of_iregsp. change (rs2 X30) with (rs0 X30). rewrite ATLR. change (rs2 X2) with sp. eexact P. simpl; congruence. congruence. - intros (rs3 & U & V). + intros (rs3 & U & V & W). assert (EXEC_PROLOGUE: exec_straight tge tf tf.(fn_code) rs0 m' @@ -996,7 +1005,8 @@ Local Transparent destroyed_at_function_entry. simpl. simpl; intros; Simpl. unfold sp; congruence. intros. rewrite V by auto with asmgen. reflexivity. - + intro IS_LEAF. + - (* external function *) exploit functions_translated; eauto. intros [tf [A B]]. simpl in B. inv B. -- cgit From eb6e959c60a799c368faf3a59b565217d52376f1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 25 Mar 2020 00:33:10 +0100 Subject: proof forward --- aarch64/Asmgenproof.v | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index e7b13cc9..1e443486 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -1005,7 +1005,10 @@ Local Transparent destroyed_at_function_entry. simpl. simpl; intros; Simpl. unfold sp; congruence. intros. rewrite V by auto with asmgen. reflexivity. - intro IS_LEAF. + + rewrite W. + unfold rs2. + Simpl. - (* external function *) exploit functions_translated; eauto. -- cgit From b096dac760b7d306c85e2b6b9b56779018596916 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 25 Mar 2020 00:40:01 +0100 Subject: RA is preserved --- aarch64/Asmgenproof.v | 22 ++++++++++++++++------ aarch64/Asmgenproof1.v | 32 ++++++++++++++++++++------------ 2 files changed, 36 insertions(+), 18 deletions(-) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index 1e443486..5f88b99b 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -636,7 +636,7 @@ Qed. Theorem step_simulation: forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), + forall S1' (MS: match_states S1 S1') (WF: wf_state ge 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. @@ -1029,6 +1029,10 @@ Local Transparent destroyed_at_function_entry. simpl. right. split. omega. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. + inv WF. + inv STACK. + inv H1. + congruence. Qed. Lemma transf_initial_states: @@ -1064,11 +1068,17 @@ Qed. Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. - eapply forward_simulation_star with (measure := measure). - apply senv_preserved. - eexact transf_initial_states. - eexact transf_final_states. - exact step_simulation. + eapply forward_simulation_star with (measure := measure) + (match_states := fun S1 S2 => match_states S1 S2 /\ wf_state ge S1). + - apply senv_preserved. + - simpl; intros. exploit transf_initial_states; eauto. + intros (s2 & A & B). + exists s2; intuition auto. apply wf_initial; auto. + - simpl; intros. destruct H as [MS WF]. eapply transf_final_states; eauto. + - simpl; intros. destruct H0 as [MS WF]. + exploit step_simulation; eauto. intros [ (s2' & A & B) | (A & B & C) ]. + + left; exists s2'; intuition auto. eapply wf_step; eauto. + + right; intuition auto. eapply wf_step; eauto. Qed. End PRESERVATION. diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index bd1474b6..b851966d 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -1776,7 +1776,8 @@ Lemma transl_addressing_correct: exists ad rs', exec_straight_opt ge fn c rs m (insn ad :: k) rs' m /\ Asm.eval_addressing ge ad rs' = Vptr b o - /\ forall r, data_preg r = true -> rs' r = rs r. + /\ (forall r, data_preg r = true -> rs' r = rs r) + /\ rs' # RA = rs # RA. Proof. intros until o; intros TR EV. unfold transl_addressing in TR; destruct addr; ArgsInv; SimplEval EV. @@ -1787,7 +1788,7 @@ Proof. + exploit (exec_loadimm64 X16 ofs). congruence. intros (rs' & A & B & C). econstructor; exists rs'; split. apply exec_straight_opt_intro; eexact A. split. simpl. rewrite B, C by eauto with asmgen. auto. - eauto with asmgen. + split; eauto with asmgen. - (* Aindexed2 *) econstructor; econstructor; split. apply exec_straight_opt_refl. auto. @@ -1803,7 +1804,7 @@ Proof. + econstructor; econstructor; split. apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. split. simpl. Simpl. rewrite H0. simpl. rewrite Ptrofs.add_zero. auto. - intros; Simpl. + split; intros; Simpl. - (* Aindexed2ext *) destruct (Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz)); inv EQ2. + econstructor; econstructor; split. apply exec_straight_opt_refl. @@ -1817,13 +1818,15 @@ Proof. split. simpl. rewrite B. rewrite Val.addl_assoc. f_equal. unfold Op.eval_extend; destruct x, (rs x1); simpl; auto; rewrite ! a64_range; simpl; rewrite Int64.add_zero; auto. - intros. apply C; eauto with asmgen. + split; intros. + apply C; eauto with asmgen. + trivial. - (* Aglobal *) destruct (Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz); inv TR. + econstructor; econstructor; split. apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. split. simpl. Simpl. rewrite symbol_high_low. simpl in EV. congruence. - intros; Simpl. + split; intros; Simpl. + exploit (exec_loadsymbol X16 id ofs). auto. simpl. congruence. intros (rs' & A & B & C & D). @@ -1832,7 +1835,7 @@ Proof. split. simpl. rewrite B. rewrite <- Genv.shift_symbol_address_64, Ptrofs.add_zero by auto. simpl in EV. congruence. - auto with asmgen. + split; auto with asmgen. - (* Ainstrack *) assert (E: Val.addl (rs SP) (Vlong (Ptrofs.to_int64 ofs)) = Vptr b o). { simpl in EV. inv EV. destruct (rs SP); simpl in H1; inv H1. simpl. @@ -1857,7 +1860,8 @@ Lemma transl_load_correct: exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of dst) = v - /\ forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r. + /\ (forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r) + /\ rs' # RA = rs # RA. Proof. intros. destruct vaddr; try discriminate. assert (A: exists sz insn, @@ -1870,14 +1874,17 @@ Proof. do 2 econstructor; (split; [eassumption|auto]). } destruct A as (sz & insn & B & C). - exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R). + exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R & S). assert (X: exec_load ge chunk (fun v => v) ad (preg_of dst) rs' m = Next (nextinstr (rs'#(preg_of dst) <- v)) m). { unfold exec_load. rewrite Q, H1. auto. } econstructor; split. eapply exec_straight_opt_right. eexact P. apply exec_straight_one. rewrite C, X; eauto. Simpl. - split. Simpl. intros; Simpl. + split. Simpl. + split; intros; Simpl. + rewrite <- S. + apply RA_not_written. Qed. Lemma transl_store_correct: @@ -1887,7 +1894,8 @@ Lemma transl_store_correct: Mem.storev chunk m vaddr rs#(preg_of src) = Some m' -> exists rs', exec_straight ge fn c rs m k rs' m' - /\ forall r, data_preg r = true -> rs' r = rs r. + /\ (forall r, data_preg r = true -> rs' r = rs r) + /\ rs' # RA = rs # RA. Proof. intros. destruct vaddr; try discriminate. set (chunk' := match chunk with Mint8signed => Mint8unsigned @@ -1903,7 +1911,7 @@ Proof. do 2 econstructor; (split; [eassumption|auto]). } destruct A as (sz & insn & B & C). - exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R). + exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R & S). assert (X: Mem.storev chunk' m (Vptr b i) rs#(preg_of src) = Some m'). { rewrite <- H1. unfold chunk'. destruct chunk; auto; simpl; symmetry. apply Mem.store_signed_unsigned_8. @@ -1914,7 +1922,7 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact P. apply exec_straight_one. rewrite C, Y; eauto. Simpl. - intros; Simpl. + split; intros; Simpl. Qed. (** Translation of indexed memory accesses *) -- cgit From 469a282add58074e2bc1a2822125d18e4dc6a80d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 25 Mar 2020 00:57:57 +0100 Subject: removed RA restoration --- aarch64/Asmgen.v | 6 ++++-- aarch64/Asmgenproof.v | 7 ++++++- aarch64/Asmgenproof1.v | 18 +++++++++++++++++- 3 files changed, 27 insertions(+), 4 deletions(-) diff --git a/aarch64/Asmgen.v b/aarch64/Asmgen.v index 875f3fd1..fc083223 100644 --- a/aarch64/Asmgen.v +++ b/aarch64/Asmgen.v @@ -1050,8 +1050,10 @@ Definition storeptr (src: ireg) (base: iregsp) (ofs: ptrofs) (k: code) := (** Function epilogue *) Definition make_epilogue (f: Mach.function) (k: code) := - loadptr XSP f.(fn_retaddr_ofs) RA - (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). + if is_leaf_function f + then Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k + else loadptr XSP f.(fn_retaddr_ofs) RA + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). (** Translation of a Mach instruction. *) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index 5f88b99b..90a06144 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -337,7 +337,12 @@ Qed. Remark make_epilogue_label: forall f k, tail_nolabel k (make_epilogue f k). Proof. - unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadptr_label. TailNoLabel. + unfold make_epilogue; intros. + destruct is_leaf_function. + { TailNoLabel. } + eapply tail_nolabel_trans. + apply loadptr_label. + TailNoLabel. Qed. Lemma transl_instr_label: diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index b851966d..91c5c306 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -2044,6 +2044,7 @@ Qed. Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, + (is_leaf_function f = true -> rs # (IR RA) = parent_ra cs) -> load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> @@ -2058,7 +2059,7 @@ Lemma make_epilogue_correct: /\ rs'#SP = parent_sp cs /\ (forall r, r <> PC -> r <> SP -> r <> RA -> r <> X16 -> rs'#r = rs#r). Proof. - intros until tm; intros LP LRA FREE AG MEXT MCS. + intros until tm; intros LEAF_RA 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'. @@ -2068,6 +2069,21 @@ Proof. exploit (loadptr_correct XSP (fn_retaddr_ofs f)). instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence. intros (rs1 & A1 & B1 & C1). + destruct (is_leaf_function f). + { + econstructor; econstructor; split. + apply exec_straight_one. simpl. + rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. + rewrite FREE'. eauto. auto. + split. apply agree_nextinstr. apply agree_set_other; auto. + apply agree_change_sp with (Vptr stk soff). + apply agree_exten with rs; auto. + eapply parent_sp_def; eauto. + split. auto. + split. Simpl. + split. Simpl. + intros. Simpl. + } econstructor; econstructor; split. eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl. simpl; rewrite (C1 SP) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. -- cgit From e991d17839bf1c4736bdb5d8cbbd956be6fb2a1e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 25 Mar 2020 07:38:07 +0100 Subject: better epilogue proof --- aarch64/Asmgenproof1.v | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 91c5c306..48c7f4e6 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -2046,7 +2046,7 @@ Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, (is_leaf_function f = true -> rs # (IR RA) = parent_ra cs) -> load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + (is_leaf_function f = false -> 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 -> @@ -2060,17 +2060,14 @@ Lemma make_epilogue_correct: /\ (forall r, r <> PC -> r <> SP -> r <> RA -> r <> X16 -> rs'#r = rs#r). Proof. intros until tm; intros LEAF_RA LP LRA FREE AG MEXT MCS. + destruct (is_leaf_function f) eqn:IS_LEAF. + { 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. - exploit (loadptr_correct XSP (fn_retaddr_ofs f)). - instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence. - intros (rs1 & A1 & B1 & C1). - destruct (is_leaf_function f). - { + rewrite IS_LEAF. + econstructor; econstructor; split. apply exec_straight_one. simpl. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. @@ -2084,6 +2081,19 @@ Proof. split. Simpl. intros. Simpl. } + lapply LRA. 2: reflexivity. + clear LRA. intro LRA. + 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 IS_LEAF. + exploit (loadptr_correct XSP (fn_retaddr_ofs f)). + instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence. + intros (rs1 & A1 & B1 & C1). + econstructor; econstructor; split. eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl. simpl; rewrite (C1 SP) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. -- cgit From ed399d8dcb3b41dfacf8257c22c608061503fd3d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 25 Mar 2020 16:49:29 +0100 Subject: Loop heuristic > Call heuristic --- backend/Duplicateaux.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index fedb63fe..54d60d24 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -269,8 +269,9 @@ let get_directions code entrypoint = begin match (get_some @@ PTree.get n code) with | Icond (cond, lr, ifso, ifnot, _) -> (* Printf.printf "Analyzing %d.." (P.to_int n); *) - let heuristics = [ do_call_heuristic; do_opcode_heuristic; - do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; (* do_store_heuristic *) ] in + 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); -- cgit From 36589dd043392d4d8672a82f24975371c102c286 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 25 Mar 2020 16:49:46 +0100 Subject: Linearize: Scheduling based on maxpc instead of dependencies --- backend/Linearizeaux.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 3f207d9e..605a5db5 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -419,9 +419,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; *) Array.iteri (fun i deps -> depmap.(i) <- ISet.remove s_id deps - ) depmap + ) depmap; + (* Printf.printf "Final depmap: "; print_depmap depmap; *) end in let choose_best_of candidates = let current_best_id = ref None in @@ -451,8 +455,10 @@ let order_sequences code entry fs = begin Array.iteri (fun i deps -> begin - (* Printf.printf "Deps: "; print_iset deps; Printf.printf "\n"; *) - if (deps == ISet.empty && not fs_evaluated.(i)) then candidates := i :: !candidates + (* Printf.printf "Deps of %d: " i; print_iset deps; Printf.printf "\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 end ) depmap; if not (List.length !candidates > 0) then begin -- cgit From b46cdc3ade397a57a7b748946fb58e16e95bf42b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 16:53:59 +0100 Subject: fix broken test Makefile fix math.h so that it does special things only on K1C --- runtime/include/math.h | 7 +++++++ test/Makefile | 4 +++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/runtime/include/math.h b/runtime/include/math.h index d6475df1..01b8d8d8 100644 --- a/runtime/include/math.h +++ b/runtime/include/math.h @@ -1,6 +1,8 @@ #ifndef _COMPCERT_MATH_H #define _COMPCERT_MATH_H +#ifdef __K1C__ + #define isfinite(__y) (fpclassify((__y)) >= FP_ZERO) #include_next @@ -16,4 +18,9 @@ #define fmaf(x, y, z) __builtin_fmaf((x),(y),(z)) #endif +#else + +#include_next + +#endif #endif diff --git a/test/Makefile b/test/Makefile index 7efcd8f1..e9c5d6a1 100644 --- a/test/Makefile +++ b/test/Makefile @@ -4,7 +4,9 @@ include ../Makefile.config # Kalray note - removing compression, raytracer and spass that cannot be executed by the simulator in reasonable time ifeq ($(ARCH),mppa_k1c) - DIRS:=c regression + DIRS=c regression +else + DIRS=c compression raytracer spass regression endif ifeq ($(CLIGHTGEN),true) -- cgit From a12c5d99df634bec3f95f2e10664b429173e49aa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 17:13:08 +0100 Subject: fix issues in Mandelbrot due to modifications in the source code --- test/c/mandelbrot.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/test/c/mandelbrot.c b/test/c/mandelbrot.c index fb8b929c..548c3ffa 100644 --- a/test/c/mandelbrot.c +++ b/test/c/mandelbrot.c @@ -59,7 +59,6 @@ int main (int argc, char **argv) if(bit_num == 8) { - printf("%c", byte_acc); putc(byte_acc,stdout); #ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster fflush(stdout); @@ -70,7 +69,6 @@ int main (int argc, char **argv) else if(x == w-1) { byte_acc <<= (8-w%8); - printf("%c", byte_acc); putc(byte_acc,stdout); #ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster fflush(stdout); -- cgit From e0a48d116d222425bf40d1fc5f79b68c7ce9a37f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 17:24:02 +0100 Subject: disable some tests --- test/regression/Makefile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/regression/Makefile b/test/regression/Makefile index 3447d6a5..ad3ffd99 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -26,18 +26,18 @@ TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ varargs1 varargs2 varargs3 sections alias aligned\ packedstruct1 packedstruct2 -ifeq ($(ARCH),mppa_k1c) +# FIXME ifeq ($(ARCH),mppa_k1c) TESTS_COMP:=$(filter-out packedstruct1,$(TESTS_COMP)) TESTS_COMP:=$(filter-out packedstruct2,$(TESTS_COMP)) -endif +# endif # Can run, both in compiled mode and in interpreter mode, # but produce processor-dependent results, so no reference output in Results TESTS_DIFF=NaNs -ifeq ($(ARCH),mppa_k1c) +# FIXME ifeq ($(ARCH),mppa_k1c) TESTS_DIFF:=$(filter-out NaNs,$(TESTS_DIFF)) -endif +# endif endif # Other tests: should compile to .s without errors (but expect warnings) -- cgit From 210541294da0f718be67a427426f2ee4c353e858 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 17:29:41 +0100 Subject: run tests on aarch64 --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ad684229..0d07db41 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -44,13 +44,14 @@ build_aarch64: 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 + - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user-binfmt - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_aarch64.sh - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 3a81fb827a35577f13bcc6594a503449a1d180f8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 17:47:15 +0100 Subject: do not use binfmt --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0d07db41..2bcd99ca 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -44,14 +44,14 @@ build_aarch64: 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-binfmt + - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_aarch64.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static all test + - cd test && make CCOMPOPTS=-static SIMU='/opt/qemu/4.2.0/bin/qemu-aarch64' EXECUTE='/opt/qemu/4.2.0/bin/qemu-aarch64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From d77f715cf71e7afd71f374d41a1b158362af4f62 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 18:00:38 +0100 Subject: call standard qemu not mine! --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2bcd99ca..c57a5a84 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -51,7 +51,7 @@ build_aarch64: script: - ./config_aarch64.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='/opt/qemu/4.2.0/bin/qemu-aarch64' EXECUTE='/opt/qemu/4.2.0/bin/qemu-aarch64' all test + - cd test && make CCOMPOPTS=-static SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 4583f92b71edf48b47fadba06e60137870ffd003 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 18:29:01 +0100 Subject: build and execute tests on other architectures than aarch64 --- .gitlab-ci.yml | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c57a5a84..1623d1ba 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -11,6 +11,7 @@ build_x86_64: script: - ./config_x86_64.sh - make -j "$NJOBS" + - cd test && make all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -30,6 +31,7 @@ build_ia32: script: - ./config_ia32.sh - make -j "$NJOBS" + - cd test && make all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -66,13 +68,14 @@ build_arm: 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 + - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_arm.sh - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -87,13 +90,14 @@ build_ppc: 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 + - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_ppc.sh - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static SIMU='qemu-ppc' EXECUTE='qemu-ppc' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -108,13 +112,14 @@ build_rv64: 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 + - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_rv64.sh - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -129,13 +134,14 @@ build_rv32: 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 + - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_rv32.sh -no-runtime-lib - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static SIMU='qemu-riscv32' EXECUTE='qemu-riscv32' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -163,3 +169,4 @@ build_k1c: - if: '$CI_COMMIT_BRANCH == "master"' when: always - when: manual + - cd test && make CCOMPOPTS=-static all -- cgit From 4799ad6121055c7a95c5a9c3c76d15706abafb6d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 18:30:16 +0100 Subject: wrong line --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1623d1ba..aa215d38 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -161,6 +161,7 @@ build_k1c: script: - ./config_k1c.sh -no-runtime-lib - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static all rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -169,4 +170,3 @@ build_k1c: - if: '$CI_COMMIT_BRANCH == "master"' when: always - when: manual - - cd test && make CCOMPOPTS=-static all -- cgit From 2a92e61c7469e4ce4340b64fad59508a71b6efb1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 18:56:16 +0100 Subject: fix config for K1C PPC RV32 for CI --- .gitlab-ci.yml | 4 ++-- config_rv32.sh | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index aa215d38..1e392b2c 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -25,6 +25,7 @@ build_ia32: stage: build image: "coqorg/coq" before_script: + - sudo apt-get -y install gcc-multilib - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir @@ -90,7 +91,7 @@ build_ppc: 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 + - sudo apt-get -y install gcc-multilib-powerpc qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir @@ -161,7 +162,6 @@ build_k1c: script: - ./config_k1c.sh -no-runtime-lib - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static all rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always diff --git a/config_rv32.sh b/config_rv32.sh index 654cacfa..a5a5cf1c 100755 --- a/config_rv32.sh +++ b/config_rv32.sh @@ -1 +1 @@ -exec ./config_simple.sh rv32-linux --toolprefix riscv64-unknown-elf- "$@" +exec ./config_simple.sh rv32-linux --toolprefix riscv64-linux-gnu- "$@" -- cgit From 99f90f43d7942c8e9c2667c448a7bc876f5c72cc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 18:59:46 +0100 Subject: various fixes for multilib --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1e392b2c..0ac47449 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -25,6 +25,7 @@ build_ia32: stage: build 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 - opam switch 4.07.1+flambda - eval `opam config env` @@ -91,7 +92,7 @@ build_ppc: 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-powerpc qemu-user + - sudo apt-get -y install gcc-multilib-powerpc-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir -- cgit From 7eb27df1b3f682bef18e58783f4ed866183d4303 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 19:11:14 +0100 Subject: fixes --- .gitlab-ci.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0ac47449..6aca7a8c 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -143,7 +143,6 @@ build_rv32: script: - ./config_rv32.sh -no-runtime-lib - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-riscv32' EXECUTE='qemu-riscv32' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From f939375d5074fc9af004a4c3a3f51a7cb2b26caf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 19:29:34 +0100 Subject: more config --- .gitlab-ci.yml | 25 +++++++++++++++++++++++-- config_ppc64.sh | 1 + 2 files changed, 24 insertions(+), 2 deletions(-) create mode 100644 config_ppc64.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6aca7a8c..e67a7508 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -92,14 +92,35 @@ build_ppc: 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-powerpc-linux-gnu qemu-user + - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_ppc.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-ppc' EXECUTE='qemu-ppc' all test + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual + +build_ppc64: + stage: build + 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 qemu-user + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_ppc64.sh + - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static SIMU='qemu-ppc64' EXECUTE='qemu-ppc64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always diff --git a/config_ppc64.sh b/config_ppc64.sh new file mode 100644 index 00000000..df31c18f --- /dev/null +++ b/config_ppc64.sh @@ -0,0 +1 @@ +exec ./config_simple.sh ppc64-linux --toolprefix powerpc64-linux-gnu- "$@" -- cgit From ebab676bc779c533d408e65b3f8a42b77cb17f9e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 19:35:28 +0100 Subject: temporarily disable raytracer test on ARM https://github.com/AbsInt/CompCert/issues/342 --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e67a7508..2dd70e21 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -77,7 +77,7 @@ build_arm: script: - ./config_arm.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test + - cd test && make DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 9536534a099fb95ae8eeef37b3ba10e03e31e823 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 19:38:56 +0100 Subject: +x --- config_ppc64.sh | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 config_ppc64.sh diff --git a/config_ppc64.sh b/config_ppc64.sh old mode 100644 new mode 100755 -- cgit From cef775c724e819c01d25cc1d461112c7a12a3227 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 19:49:45 +0100 Subject: disable testing on ppc64 --- .gitlab-ci.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2dd70e21..9ee14292 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -113,14 +113,12 @@ build_ppc64: 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 qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_ppc64.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-ppc64' EXECUTE='qemu-ppc64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 63b547484630fc774be06cf02033e3f0ecbfc26f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 20:00:56 +0100 Subject: we still need a ppc64 compiler --- .gitlab-ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9ee14292..17228f76 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -113,6 +113,7 @@ build_ppc64: 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 - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir -- cgit From 96482f7df095e6244c414a14b07771dbaef67aec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 20:13:49 +0100 Subject: Run tests on various targets in addition to compiling --- .gitlab-ci.yml | 38 +++++++++++++++++++++++++++++++++----- config_ppc64.sh | 1 + config_rv32.sh | 2 +- runtime/include/math.h | 7 +++++++ test/Makefile | 4 +++- test/c/mandelbrot.c | 2 -- test/regression/Makefile | 8 ++++---- 7 files changed, 49 insertions(+), 13 deletions(-) create mode 100755 config_ppc64.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ad684229..17228f76 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -11,6 +11,7 @@ build_x86_64: script: - ./config_x86_64.sh - make -j "$NJOBS" + - cd test && make all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -24,12 +25,15 @@ build_ia32: stage: build 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 - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_ia32.sh - make -j "$NJOBS" + - cd test && make all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -44,13 +48,14 @@ build_aarch64: 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 + - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_aarch64.sh - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -65,13 +70,14 @@ build_arm: 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 + - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_arm.sh - make -j "$NJOBS" + - cd test && make DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -86,7 +92,7 @@ build_ppc: 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 + - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir @@ -102,18 +108,40 @@ build_ppc: when: always - when: manual +build_ppc64: + stage: build + 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 + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_ppc64.sh + - make -j "$NJOBS" + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual + build_rv64: stage: build 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 + - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_rv64.sh - make -j "$NJOBS" + - cd test && make CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -128,7 +156,7 @@ build_rv32: 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 + - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir diff --git a/config_ppc64.sh b/config_ppc64.sh new file mode 100755 index 00000000..df31c18f --- /dev/null +++ b/config_ppc64.sh @@ -0,0 +1 @@ +exec ./config_simple.sh ppc64-linux --toolprefix powerpc64-linux-gnu- "$@" diff --git a/config_rv32.sh b/config_rv32.sh index 654cacfa..a5a5cf1c 100755 --- a/config_rv32.sh +++ b/config_rv32.sh @@ -1 +1 @@ -exec ./config_simple.sh rv32-linux --toolprefix riscv64-unknown-elf- "$@" +exec ./config_simple.sh rv32-linux --toolprefix riscv64-linux-gnu- "$@" diff --git a/runtime/include/math.h b/runtime/include/math.h index d6475df1..01b8d8d8 100644 --- a/runtime/include/math.h +++ b/runtime/include/math.h @@ -1,6 +1,8 @@ #ifndef _COMPCERT_MATH_H #define _COMPCERT_MATH_H +#ifdef __K1C__ + #define isfinite(__y) (fpclassify((__y)) >= FP_ZERO) #include_next @@ -16,4 +18,9 @@ #define fmaf(x, y, z) __builtin_fmaf((x),(y),(z)) #endif +#else + +#include_next + +#endif #endif diff --git a/test/Makefile b/test/Makefile index 7efcd8f1..e9c5d6a1 100644 --- a/test/Makefile +++ b/test/Makefile @@ -4,7 +4,9 @@ include ../Makefile.config # Kalray note - removing compression, raytracer and spass that cannot be executed by the simulator in reasonable time ifeq ($(ARCH),mppa_k1c) - DIRS:=c regression + DIRS=c regression +else + DIRS=c compression raytracer spass regression endif ifeq ($(CLIGHTGEN),true) diff --git a/test/c/mandelbrot.c b/test/c/mandelbrot.c index fb8b929c..548c3ffa 100644 --- a/test/c/mandelbrot.c +++ b/test/c/mandelbrot.c @@ -59,7 +59,6 @@ int main (int argc, char **argv) if(bit_num == 8) { - printf("%c", byte_acc); putc(byte_acc,stdout); #ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster fflush(stdout); @@ -70,7 +69,6 @@ int main (int argc, char **argv) else if(x == w-1) { byte_acc <<= (8-w%8); - printf("%c", byte_acc); putc(byte_acc,stdout); #ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster fflush(stdout); diff --git a/test/regression/Makefile b/test/regression/Makefile index 3447d6a5..ad3ffd99 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -26,18 +26,18 @@ TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ varargs1 varargs2 varargs3 sections alias aligned\ packedstruct1 packedstruct2 -ifeq ($(ARCH),mppa_k1c) +# FIXME ifeq ($(ARCH),mppa_k1c) TESTS_COMP:=$(filter-out packedstruct1,$(TESTS_COMP)) TESTS_COMP:=$(filter-out packedstruct2,$(TESTS_COMP)) -endif +# endif # Can run, both in compiled mode and in interpreter mode, # but produce processor-dependent results, so no reference output in Results TESTS_DIFF=NaNs -ifeq ($(ARCH),mppa_k1c) +# FIXME ifeq ($(ARCH),mppa_k1c) TESTS_DIFF:=$(filter-out NaNs,$(TESTS_DIFF)) -endif +# endif endif # Other tests: should compile to .s without errors (but expect warnings) -- cgit From e0843c84d1aa69ed0176cf44109b3bbdd4019504 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 20:37:03 +0100 Subject: disable leaf function removal of return address restoration due to memcpy overwriting the return address register --- aarch64/Asmgen.v | 7 +++++-- aarch64/Asmgenproof.v | 4 ++-- aarch64/Asmgenproof1.v | 9 ++++++--- 3 files changed, 13 insertions(+), 7 deletions(-) diff --git a/aarch64/Asmgen.v b/aarch64/Asmgen.v index f4446696..024c9a17 100644 --- a/aarch64/Asmgen.v +++ b/aarch64/Asmgen.v @@ -1061,9 +1061,12 @@ Definition storeptr (src: ireg) (base: iregsp) (ofs: ptrofs) (k: code) := (** Function epilogue *) Definition make_epilogue (f: Mach.function) (k: code) := - if is_leaf_function f + (* FIXME + Cannot be used because memcpy destroys X30; + issue being discussed with X. Leroy *) + (* if is_leaf_function f then Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k - else loadptr XSP f.(fn_retaddr_ofs) RA + else*) loadptr XSP f.(fn_retaddr_ofs) RA (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). (** Translation of a Mach instruction. *) diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index 0d3179d4..6831509f 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -338,8 +338,8 @@ Remark make_epilogue_label: forall f k, tail_nolabel k (make_epilogue f k). Proof. unfold make_epilogue; intros. - destruct is_leaf_function. - { TailNoLabel. } + (* FIXME destruct is_leaf_function. + { TailNoLabel. } *) eapply tail_nolabel_trans. apply loadptr_label. TailNoLabel. diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v index 2b89723f..0e36bd05 100644 --- a/aarch64/Asmgenproof1.v +++ b/aarch64/Asmgenproof1.v @@ -2070,7 +2070,7 @@ Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, (is_leaf_function f = true -> rs # (IR RA) = parent_ra cs) -> load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> - (is_leaf_function f = false -> load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs)) -> + ((* FIXME is_leaf_function f = false -> *) 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 -> @@ -2084,6 +2084,9 @@ Lemma make_epilogue_correct: /\ (forall r, r <> PC -> r <> SP -> r <> RA -> r <> X16 -> rs'#r = rs#r). Proof. intros until tm; intros LEAF_RA LP LRA FREE AG MEXT MCS. + + (* FIXME + Cannot be used at this point destruct (is_leaf_function f) eqn:IS_LEAF. { exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). @@ -2106,14 +2109,14 @@ Proof. intros. Simpl. } lapply LRA. 2: reflexivity. - clear LRA. intro LRA. + clear LRA. intro LRA. *) 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 IS_LEAF. + (* FIXME rewrite IS_LEAF. *) exploit (loadptr_correct XSP (fn_retaddr_ofs f)). instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence. intros (rs1 & A1 & B1 & C1). -- cgit From b5deca576e000cb8cabd9c3c036e8de83cbe2e37 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 08:08:47 +0100 Subject: Makefile for CI --- test/monniaux/yarpgen/Makefile | 65 ++++++++++++++++++++++++-------------- test/monniaux/yarpgen/Makefile.old | 52 ++++++++++++++++++++++++++++++ 2 files changed, 93 insertions(+), 24 deletions(-) create mode 100644 test/monniaux/yarpgen/Makefile.old diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 9da82deb..a320a7e8 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -1,37 +1,54 @@ +TARGET_CCOMP=../../../ccomp + YARPGEN=yarpgen MAX=300 PREFIX=ran%06.f -include ../rules.mk -K1C_CCOMPFLAGS += -funprototyped -fbitfields -CCOMPFLAGS += -funprototyped -fbitfields +CCOMPOPTS += -funprototyped -fbitfields -TARGETS_C=$(shell seq --format $(PREFIX)/func.c 0 $(MAX)) \ +TESTS_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_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)) \ +TESTS_CCOMP_TARGET_S=$(shell seq --format $(PREFIX)/func.ccomp.target.s 0 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.ccomp.target.s 0 $(MAX)) +TESTS_GCC_TARGET_S=$(shell seq --format $(PREFIX)/func.gcc.target.s 0 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.gcc.target.s 0 $(MAX)) +TESTS_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_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)) +TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 0 $(MAX)) +TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 0 $(MAX)) +TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 0 $(MAX)) +TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 0 $(MAX)) + +all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) + +tests_c: $(TESTS_C) + +%.ccomp.target.s : %.c + $(TARGET_CCOMP) $(CCOMPOPTS) -S -o $@ $< + +%.gcc.target.s : %.c + $(TARGET_CC) $(CCOMPOPTS) -S -o $@ $< + +%.gcc.host.s : %.c + $(CC) $(CFLAGS) -S -o $@ $< + +%.target.o : %.target.s + $(TARGET_CCOMP) $(CCOMPOPTS) -c -o $@ $< + +%.target.out : %.target + $(EXECUTE) $< > $@ -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) +%.host.out : %.host + ./$< > $@ -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.target.s ran%/func.gcc.target.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.target: ran%/func.ccomp.target.o ran%/driver.ccomp.target.o + $(TARGET_CCOMP) $(CCOMPOPTS) $+ -o $@ -ran%/example.gcc.k1c: ran%/func.gcc.k1c.o ran%/driver.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ +ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o + $(TARGET_CC) $(TARGET_CFLAGS) $+ -o $@ ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o $(CC) $(CFLAGS) $+ -o $@ @@ -43,10 +60,10 @@ 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.target.cmp : ran%/example.gcc.target.out ran%/example.ccomp.target.out cmp $+ > $@ -.PHONY: all clean +.PHONY: all clean tests_c clean: -rm -rf ran* diff --git a/test/monniaux/yarpgen/Makefile.old b/test/monniaux/yarpgen/Makefile.old new file mode 100644 index 00000000..9da82deb --- /dev/null +++ b/test/monniaux/yarpgen/Makefile.old @@ -0,0 +1,52 @@ +YARPGEN=yarpgen +MAX=300 +PREFIX=ran%06.f +include ../rules.mk + +K1C_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_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_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)) + +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) + +ran%/func.ccomp.k1c.s ran%/func.gcc.k1c.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.gcc.k1c: ran%/func.gcc.k1c.o ran%/driver.gcc.k1c.o + $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ + +ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o + $(CC) $(CFLAGS) $+ -o $@ + +ran%/example.ccomp.host: ran%/func.ccomp.host.o ran%/driver.ccomp.host.o + $(CCOMP) $(CCOMPFLAGS) $+ -o $@ + +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 + cmp $+ > $@ + +.PHONY: all clean + +clean: + -rm -rf ran* -- cgit From 575a56ce631090624041db36ddb2747be907d091 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 08:12:12 +0100 Subject: cleaner make invocation --- .gitlab-ci.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 17228f76..16055618 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -11,7 +11,7 @@ build_x86_64: script: - ./config_x86_64.sh - make -j "$NJOBS" - - cd test && make all test + - make -C test all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -33,7 +33,7 @@ build_ia32: script: - ./config_ia32.sh - make -j "$NJOBS" - - cd test && make all test + - make -C test all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -55,7 +55,7 @@ build_aarch64: script: - ./config_aarch64.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test + - make -C test CCOMPOPTS=-static SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -77,7 +77,7 @@ build_arm: script: - ./config_arm.sh - make -j "$NJOBS" - - cd test && make DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test + - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -141,7 +141,7 @@ build_rv64: script: - ./config_rv64.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test + - make -C test CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 292241f51df20ee0f057f5d3f7cc00f1425f1727 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 09:23:51 +0100 Subject: set up for autogeneration of yarpgen --- test/monniaux/yarpgen/Makefile | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index a320a7e8..02564fef 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -1,14 +1,21 @@ TARGET_CCOMP=../../../ccomp -YARPGEN=yarpgen +ifndef YARPGEN +YARPGEN=./yarpgen +generator: yarpgen +endif + MAX=300 PREFIX=ran%06.f -CCOMPOPTS += -funprototyped -fbitfields +CCOMPFLAGS+=-funprototyped -fbitfields TESTS_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)) + +$(TESTS_C): generator + TESTS_CCOMP_TARGET_S=$(shell seq --format $(PREFIX)/func.ccomp.target.s 0 $(MAX)) \ $(shell seq --format $(PREFIX)/driver.ccomp.target.s 0 $(MAX)) TESTS_GCC_TARGET_S=$(shell seq --format $(PREFIX)/func.gcc.target.s 0 $(MAX)) \ @@ -24,8 +31,10 @@ all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(T tests_c: $(TESTS_C) +tests_s: $(TESTS_CCOMP_TARGET_S) + %.ccomp.target.s : %.c - $(TARGET_CCOMP) $(CCOMPOPTS) -S -o $@ $< + $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) -S -o $@ $< %.gcc.target.s : %.c $(TARGET_CC) $(CCOMPOPTS) -S -o $@ $< @@ -34,7 +43,7 @@ tests_c: $(TESTS_C) $(CC) $(CFLAGS) -S -o $@ $< %.target.o : %.target.s - $(TARGET_CCOMP) $(CCOMPOPTS) -c -o $@ $< + $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) -c -o $@ $< %.target.out : %.target $(EXECUTE) $< > $@ @@ -45,7 +54,7 @@ tests_c: $(TESTS_C) ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s : ran%/init.h ran%/example.ccomp.target: ran%/func.ccomp.target.o ran%/driver.ccomp.target.o - $(TARGET_CCOMP) $(CCOMPOPTS) $+ -o $@ + $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) $+ -o $@ ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o $(TARGET_CC) $(TARGET_CFLAGS) $+ -o $@ @@ -57,13 +66,19 @@ ran%/example.ccomp.host: ran%/func.ccomp.host.o ran%/driver.ccomp.host.o $(CCOMP) $(CCOMPFLAGS) $+ -o $@ ran%/driver.c ran%/func.c ran%/init.h: - -mkdir ran$* + mkdir -p ran$* $(YARPGEN) --seed=$* --out-dir=ran$*/ --std=c99 ran%/example.target.cmp : ran%/example.gcc.target.out ran%/example.ccomp.target.out cmp $+ > $@ -.PHONY: all clean tests_c +yarpgen: + curl -L -o yarpgen_v1.1.tar.gz https://github.com/intel/yarpgen/archive/v1.1.tar.gz + tar xfz yarpgen_v1.1.tar.gz + $(MAKE) CXX=g++ -C yarpgen-1.1 + cp yarpgen-1.1/yarpgen $@ + +.PHONY: all clean tests_c tests_c generator clean: -rm -rf ran* -- cgit From 6dc7548e1e8dad708ad3348ecc324e02cd5f3472 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 09:34:22 +0100 Subject: fix Makefile for not remaking the generator --- test/monniaux/yarpgen/Makefile | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 02564fef..7a62ef61 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -2,7 +2,7 @@ TARGET_CCOMP=../../../ccomp ifndef YARPGEN YARPGEN=./yarpgen -generator: yarpgen +GENERATOR=yarpgen endif MAX=300 @@ -14,18 +14,18 @@ TESTS_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)) -$(TESTS_C): generator +$(TESTS_C): $(GENERATOR) -TESTS_CCOMP_TARGET_S=$(shell seq --format $(PREFIX)/func.ccomp.target.s 0 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.ccomp.target.s 0 $(MAX)) -TESTS_GCC_TARGET_S=$(shell seq --format $(PREFIX)/func.gcc.target.s 0 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.gcc.target.s 0 $(MAX)) -TESTS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 0 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.gcc.host.s 0 $(MAX)) -TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 0 $(MAX)) -TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 0 $(MAX)) -TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 0 $(MAX)) -TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 0 $(MAX)) +TESTS_CCOMP_TARGET_S=$(shell seq --format $(PREFIX)/func.ccomp.target.s 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.ccomp.target.s 1 $(MAX)) +TESTS_GCC_TARGET_S=$(shell seq --format $(PREFIX)/func.gcc.target.s 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.gcc.target.s 1 $(MAX)) +TESTS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.gcc.host.s 1 $(MAX)) +TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) +TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) +TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) +TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) @@ -78,7 +78,7 @@ yarpgen: $(MAKE) CXX=g++ -C yarpgen-1.1 cp yarpgen-1.1/yarpgen $@ -.PHONY: all clean tests_c tests_c generator +.PHONY: all clean tests_c tests_c clean: -rm -rf ran* -- cgit From 3e5fcc7e1bea051e2f14f7b3a20d4e78cb23e539 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 10:03:26 +0100 Subject: fix Makefile (again) --- test/monniaux/yarpgen/Makefile | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 7a62ef61..ffa58172 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -1,4 +1,7 @@ TARGET_CCOMP=../../../ccomp +TARGET_CC=gcc + +all: ifndef YARPGEN YARPGEN=./yarpgen @@ -10,9 +13,10 @@ PREFIX=ran%06.f CCOMPFLAGS+=-funprototyped -fbitfields -TESTS_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)) +TESTS_C=$(shell seq --format $(PREFIX)/func.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/init.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/init.h 1 $(MAX)) $(TESTS_C): $(GENERATOR) @@ -53,18 +57,15 @@ tests_s: $(TESTS_CCOMP_TARGET_S) ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s : ran%/init.h -ran%/example.ccomp.target: ran%/func.ccomp.target.o ran%/driver.ccomp.target.o +ran%/example.ccomp.target: ran%/func.ccomp.target.o ran%/driver.ccomp.target.o ran%/init.ccomp.target.o ran%/check.ccomp.target.o ran%/hash.ccomp.target.o $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) $+ -o $@ -ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o +ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o ran%/init.ccomp.target.o ran%/check.gcc.target.o ran%/hash.gcc.target.o $(TARGET_CC) $(TARGET_CFLAGS) $+ -o $@ -ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o +ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o ran%/init.gcc.host.o ran%/check.gcc.host.o ran%/hash.gcc.host.o $(CC) $(CFLAGS) $+ -o $@ -ran%/example.ccomp.host: ran%/func.ccomp.host.o ran%/driver.ccomp.host.o - $(CCOMP) $(CCOMPFLAGS) $+ -o $@ - ran%/driver.c ran%/func.c ran%/init.h: mkdir -p ran$* $(YARPGEN) --seed=$* --out-dir=ran$*/ --std=c99 -- cgit From 0024edef4ce251a154733a241868ecc3119c8adf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 10:19:25 +0100 Subject: fix targets for proper generation --- test/monniaux/yarpgen/Makefile | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index ffa58172..8023902b 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -29,7 +29,7 @@ TESTS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 1 $(MAX)) \ TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) -TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) +TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) @@ -66,13 +66,16 @@ ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o ran%/in ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o ran%/init.gcc.host.o ran%/check.gcc.host.o ran%/hash.gcc.host.o $(CC) $(CFLAGS) $+ -o $@ -ran%/driver.c ran%/func.c ran%/init.h: +ran%/driver.c ran%/func.c ran%/init.c ran%/check.c ran%/hash.c ran%/init.h: mkdir -p ran$* $(YARPGEN) --seed=$* --out-dir=ran$*/ --std=c99 ran%/example.target.cmp : ran%/example.gcc.target.out ran%/example.ccomp.target.out cmp $+ > $@ +ran%/example.host_target.cmp : ran%/example.gcc.host.out ran%/example.gcc.target.out + cmp $+ > $@ + yarpgen: curl -L -o yarpgen_v1.1.tar.gz https://github.com/intel/yarpgen/archive/v1.1.tar.gz tar xfz yarpgen_v1.1.tar.gz -- cgit From e1fb8ff636881054d7223129d61b214cce36acf7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 10:48:51 +0100 Subject: some more Makefile fixes (disable cse2 it's too slow) --- test/monniaux/yarpgen/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 8023902b..f94dffce 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -11,7 +11,7 @@ endif MAX=300 PREFIX=ran%06.f -CCOMPFLAGS+=-funprototyped -fbitfields +CCOMPFLAGS+=-funprototyped -fbitfields -fno-cse2 # FIXME TESTS_C=$(shell seq --format $(PREFIX)/func.c 1 $(MAX)) \ $(shell seq --format $(PREFIX)/driver.c 1 $(MAX)) \ -- cgit From 5fe8b78a18f3bd8b4ad80c7318115d5d2ebe932f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 11:07:09 +0100 Subject: run yarpgen test on aarch64 --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 16055618..ee50b751 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -55,7 +55,8 @@ build_aarch64: script: - ./config_aarch64.sh - make -j "$NJOBS" - - make -C test CCOMPOPTS=-static SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test + - make -C test CCOMPOPTS='-static' SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test + - make -C test/monniaux/yarpgen -k TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 2569e84cd235045e4419e8d65c0e69bb3f2ffb60 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 11:26:22 +0100 Subject: stdlib path --- test/monniaux/yarpgen/Makefile | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index f94dffce..bdb7cb63 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -11,7 +11,8 @@ endif MAX=300 PREFIX=ran%06.f -CCOMPFLAGS+=-funprototyped -fbitfields -fno-cse2 # FIXME +CCOMPOPTS=-static +CCOMPFLAGS+=-funprototyped -fbitfields -fno-cse2 -stdlib ../../../runtime # FIXME TESTS_C=$(shell seq --format $(PREFIX)/func.c 1 $(MAX)) \ $(shell seq --format $(PREFIX)/driver.c 1 $(MAX)) \ @@ -29,7 +30,7 @@ TESTS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 1 $(MAX)) \ TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) -TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) +TESTS_CMP=$(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) $(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) @@ -73,7 +74,7 @@ ran%/driver.c ran%/func.c ran%/init.c ran%/check.c ran%/hash.c ran%/init.h: ran%/example.target.cmp : ran%/example.gcc.target.out ran%/example.ccomp.target.out cmp $+ > $@ -ran%/example.host_target.cmp : ran%/example.gcc.host.out ran%/example.gcc.target.out +ran%/example.host_target.cmp : ran%/example.gcc.host.out ran%/example.ccomp.target.out cmp $+ > $@ yarpgen: @@ -83,6 +84,7 @@ yarpgen: cp yarpgen-1.1/yarpgen $@ .PHONY: all clean tests_c tests_c +.SECONDARY: .s .target .out clean: -rm -rf ran* -- cgit From aa52be6e57fb0627113cfcaf26340e323f58b3bc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 11:55:04 +0100 Subject: fix limitxy --- test/monniaux/yarpgen/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index bdb7cb63..2aafd394 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -8,7 +8,7 @@ YARPGEN=./yarpgen GENERATOR=yarpgen endif -MAX=300 +MAX=170 PREFIX=ran%06.f CCOMPOPTS=-static -- cgit From dd76ee0e14acbff78b6cd575e53d9c9d59fa6747 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 12:17:41 +0100 Subject: better assemble with gcc --- test/monniaux/yarpgen/Makefile | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 2aafd394..9800d9f0 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -17,6 +17,8 @@ CCOMPFLAGS+=-funprototyped -fbitfields -fno-cse2 -stdlib ../../../runtime # FIXM TESTS_C=$(shell seq --format $(PREFIX)/func.c 1 $(MAX)) \ $(shell seq --format $(PREFIX)/driver.c 1 $(MAX)) \ $(shell seq --format $(PREFIX)/init.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/hash.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/check.c 1 $(MAX)) \ $(shell seq --format $(PREFIX)/init.h 1 $(MAX)) $(TESTS_C): $(GENERATOR) @@ -48,7 +50,7 @@ tests_s: $(TESTS_CCOMP_TARGET_S) $(CC) $(CFLAGS) -S -o $@ $< %.target.o : %.target.s - $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) -c -o $@ $< + $(TARGET_CC) -c -o $@ $< %.target.out : %.target $(EXECUTE) $< > $@ @@ -84,7 +86,6 @@ yarpgen: cp yarpgen-1.1/yarpgen $@ .PHONY: all clean tests_c tests_c -.SECONDARY: .s .target .out clean: -rm -rf ran* -- cgit From 8beb9b73085b2ad49dfa68a74ac3812b78d6e558 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 12:33:54 +0100 Subject: fix inconsistency --- test/monniaux/yarpgen/Makefile | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 9800d9f0..af586ac4 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -3,6 +3,8 @@ TARGET_CC=gcc all: +.SECONDARY: + ifndef YARPGEN YARPGEN=./yarpgen GENERATOR=yarpgen @@ -23,12 +25,9 @@ TESTS_C=$(shell seq --format $(PREFIX)/func.c 1 $(MAX)) \ $(TESTS_C): $(GENERATOR) -TESTS_CCOMP_TARGET_S=$(shell seq --format $(PREFIX)/func.ccomp.target.s 1 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.ccomp.target.s 1 $(MAX)) -TESTS_GCC_TARGET_S=$(shell seq --format $(PREFIX)/func.gcc.target.s 1 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.gcc.target.s 1 $(MAX)) -TESTS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 1 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.gcc.host.s 1 $(MAX)) +TESTS_CCOMP_TARGET_S=$(TEST_C:.c=.ccomp.target.s) +TESTS_GCC_TARGET_S=$(TEST_C:.c=.gcc.target.s) +TESTS_GCC_HOST_S=$(TEST_C:.c=.gcc.host.s) TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) @@ -58,12 +57,12 @@ tests_s: $(TESTS_CCOMP_TARGET_S) %.host.out : %.host ./$< > $@ -ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s : ran%/init.h +ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s ran%/init.gcc.host.s : ran%/init.h ran%/example.ccomp.target: ran%/func.ccomp.target.o ran%/driver.ccomp.target.o ran%/init.ccomp.target.o ran%/check.ccomp.target.o ran%/hash.ccomp.target.o $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) $+ -o $@ -ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o ran%/init.ccomp.target.o ran%/check.gcc.target.o ran%/hash.gcc.target.o +ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o ran%/init.gcc.target.o ran%/check.gcc.target.o ran%/hash.gcc.target.o $(TARGET_CC) $(TARGET_CFLAGS) $+ -o $@ ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o ran%/init.gcc.host.o ran%/check.gcc.host.o ran%/hash.gcc.host.o -- cgit From 520ac43fdfaa6ecef14fc93b68034e03112e12fd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 13:23:51 +0100 Subject: run yarpgen on other architectures --- .gitlab-ci.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ee50b751..bf7361f8 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -12,6 +12,7 @@ build_x86_64: - ./config_x86_64.sh - make -j "$NJOBS" - make -C test all test + - make -C test/monniaux/yarpgen rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -34,6 +35,7 @@ build_ia32: - ./config_ia32.sh - make -j "$NJOBS" - make -C test all test + - make -C test/monniaux/yarpgen rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -79,6 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test + - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnu-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -143,6 +146,7 @@ build_rv64: - ./config_rv64.sh - make -j "$NJOBS" - make -C test CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test + - make -C test/monniaux/yarpgen -k TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From d0b8ed2ab2979bfef689c5c801a73434b0abab51 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 13:56:19 +0100 Subject: more fixes for CI --- .gitlab-ci.yml | 4 ++-- test/monniaux/yarpgen/Makefile | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index bf7361f8..119fa44e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -35,7 +35,7 @@ build_ia32: - ./config_ia32.sh - make -j "$NJOBS" - make -C test all test - - make -C test/monniaux/yarpgen +# - make -C test/monniaux/yarpgen disabled due to -m32/-m64 issues rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -81,7 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnu-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index af586ac4..fc524d92 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -10,7 +10,7 @@ YARPGEN=./yarpgen GENERATOR=yarpgen endif -MAX=170 +MAX=169 PREFIX=ran%06.f CCOMPOPTS=-static -- cgit From 69247e1024f99f628f9b00eb9ecc30ef30e51d3f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 14:27:13 +0100 Subject: limit due to stack overflows --- test/monniaux/yarpgen/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index fc524d92..dbd6ae75 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -10,7 +10,7 @@ YARPGEN=./yarpgen GENERATOR=yarpgen endif -MAX=169 +MAX=129 PREFIX=ran%06.f CCOMPOPTS=-static -- cgit From 567b0fae43cfe39cfbc15adaf5c31c62a02190ae Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 15:14:02 +0100 Subject: rm yarpgen on arm --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 119fa44e..5f696257 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -81,7 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' +# - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' disabled; mysterious differences between gcc/clang and compcert rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 35c545b3b2711645452b747b3d75b4f46a078776 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 15:27:25 +0100 Subject: Run Yarpgen in CI --- .gitlab-ci.yml | 15 +++-- test/monniaux/yarpgen/Makefile | 122 ++++++++++++++++++++++++------------- test/monniaux/yarpgen/Makefile.old | 52 ++++++++++++++++ 3 files changed, 142 insertions(+), 47 deletions(-) create mode 100644 test/monniaux/yarpgen/Makefile.old diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 17228f76..5f696257 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -11,7 +11,8 @@ build_x86_64: script: - ./config_x86_64.sh - make -j "$NJOBS" - - cd test && make all test + - make -C test all test + - make -C test/monniaux/yarpgen rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -33,7 +34,8 @@ build_ia32: script: - ./config_ia32.sh - make -j "$NJOBS" - - cd test && make all test + - make -C test all test +# - make -C test/monniaux/yarpgen disabled due to -m32/-m64 issues rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -55,7 +57,8 @@ build_aarch64: script: - ./config_aarch64.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test + - make -C test CCOMPOPTS='-static' SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test + - make -C test/monniaux/yarpgen -k TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -77,7 +80,8 @@ build_arm: script: - ./config_arm.sh - make -j "$NJOBS" - - cd test && make DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test + - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test +# - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' disabled; mysterious differences between gcc/clang and compcert rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -141,7 +145,8 @@ build_rv64: script: - ./config_rv64.sh - make -j "$NJOBS" - - cd test && make CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test + - make -C test CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test + - make -C test/monniaux/yarpgen -k TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 9da82deb..dbd6ae75 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -1,52 +1,90 @@ -YARPGEN=yarpgen -MAX=300 +TARGET_CCOMP=../../../ccomp +TARGET_CC=gcc + +all: + +.SECONDARY: + +ifndef YARPGEN +YARPGEN=./yarpgen +GENERATOR=yarpgen +endif + +MAX=129 PREFIX=ran%06.f -include ../rules.mk - -K1C_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_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_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)) - -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) - -ran%/func.ccomp.k1c.s ran%/func.gcc.k1c.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.gcc.k1c: ran%/func.gcc.k1c.o ran%/driver.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ - -ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o - $(CC) $(CFLAGS) $+ -o $@ -ran%/example.ccomp.host: ran%/func.ccomp.host.o ran%/driver.ccomp.host.o - $(CCOMP) $(CCOMPFLAGS) $+ -o $@ +CCOMPOPTS=-static +CCOMPFLAGS+=-funprototyped -fbitfields -fno-cse2 -stdlib ../../../runtime # FIXME + +TESTS_C=$(shell seq --format $(PREFIX)/func.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/init.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/hash.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/check.c 1 $(MAX)) \ + $(shell seq --format $(PREFIX)/init.h 1 $(MAX)) + +$(TESTS_C): $(GENERATOR) + +TESTS_CCOMP_TARGET_S=$(TEST_C:.c=.ccomp.target.s) +TESTS_GCC_TARGET_S=$(TEST_C:.c=.gcc.target.s) +TESTS_GCC_HOST_S=$(TEST_C:.c=.gcc.host.s) +TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) +TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) +TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) +TESTS_CMP=$(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) $(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) + +all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) + +tests_c: $(TESTS_C) + +tests_s: $(TESTS_CCOMP_TARGET_S) + +%.ccomp.target.s : %.c + $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) -S -o $@ $< + +%.gcc.target.s : %.c + $(TARGET_CC) $(CCOMPOPTS) -S -o $@ $< -ran%/driver.c ran%/func.c ran%/init.h: - -mkdir ran$* +%.gcc.host.s : %.c + $(CC) $(CFLAGS) -S -o $@ $< + +%.target.o : %.target.s + $(TARGET_CC) -c -o $@ $< + +%.target.out : %.target + $(EXECUTE) $< > $@ + +%.host.out : %.host + ./$< > $@ + +ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s ran%/init.gcc.host.s : ran%/init.h + +ran%/example.ccomp.target: ran%/func.ccomp.target.o ran%/driver.ccomp.target.o ran%/init.ccomp.target.o ran%/check.ccomp.target.o ran%/hash.ccomp.target.o + $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) $+ -o $@ + +ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o ran%/init.gcc.target.o ran%/check.gcc.target.o ran%/hash.gcc.target.o + $(TARGET_CC) $(TARGET_CFLAGS) $+ -o $@ + +ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o ran%/init.gcc.host.o ran%/check.gcc.host.o ran%/hash.gcc.host.o + $(CC) $(CFLAGS) $+ -o $@ + +ran%/driver.c ran%/func.c ran%/init.c ran%/check.c ran%/hash.c ran%/init.h: + mkdir -p ran$* $(YARPGEN) --seed=$* --out-dir=ran$*/ --std=c99 -ran%/example.k1c.cmp : ran%/example.gcc.k1c.out ran%/example.ccomp.k1c.out +ran%/example.target.cmp : ran%/example.gcc.target.out ran%/example.ccomp.target.out cmp $+ > $@ -.PHONY: all clean +ran%/example.host_target.cmp : ran%/example.gcc.host.out ran%/example.ccomp.target.out + cmp $+ > $@ + +yarpgen: + curl -L -o yarpgen_v1.1.tar.gz https://github.com/intel/yarpgen/archive/v1.1.tar.gz + tar xfz yarpgen_v1.1.tar.gz + $(MAKE) CXX=g++ -C yarpgen-1.1 + cp yarpgen-1.1/yarpgen $@ + +.PHONY: all clean tests_c tests_c clean: -rm -rf ran* diff --git a/test/monniaux/yarpgen/Makefile.old b/test/monniaux/yarpgen/Makefile.old new file mode 100644 index 00000000..9da82deb --- /dev/null +++ b/test/monniaux/yarpgen/Makefile.old @@ -0,0 +1,52 @@ +YARPGEN=yarpgen +MAX=300 +PREFIX=ran%06.f +include ../rules.mk + +K1C_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_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_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)) + +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) + +ran%/func.ccomp.k1c.s ran%/func.gcc.k1c.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.gcc.k1c: ran%/func.gcc.k1c.o ran%/driver.gcc.k1c.o + $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ + +ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o + $(CC) $(CFLAGS) $+ -o $@ + +ran%/example.ccomp.host: ran%/func.ccomp.host.o ran%/driver.ccomp.host.o + $(CCOMP) $(CCOMPFLAGS) $+ -o $@ + +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 + cmp $+ > $@ + +.PHONY: all clean + +clean: + -rm -rf ran* -- cgit From 5e84a1aea751e8c4c46a2899a2901bb59a1f049b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 16:29:34 +0100 Subject: run yarpgen correctly on arm --- .gitlab-ci.yml | 2 +- test/monniaux/yarpgen/Makefile | 14 +++++++++++--- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 119fa44e..bf83a026 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -81,7 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index dbd6ae75..339d6808 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -10,6 +10,11 @@ YARPGEN=./yarpgen GENERATOR=yarpgen endif +ifdef BITS +YARPGEN+=-m $(BITS) +CFLAGS+=-m$(BITS) +endif + MAX=129 PREFIX=ran%06.f @@ -49,13 +54,16 @@ tests_s: $(TESTS_CCOMP_TARGET_S) $(CC) $(CFLAGS) -S -o $@ $< %.target.o : %.target.s - $(TARGET_CC) -c -o $@ $< + $(TARGET_CC) $(CFLAGS) -c -o $@ $< + +%.host.o : %.host.s + $(CC) $(CFLAGS) -c -o $@ $< %.target.out : %.target - $(EXECUTE) $< > $@ + $(EXECUTE) $< | tee $@ %.host.out : %.host - ./$< > $@ + ./$< | tee $@ ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s ran%/init.gcc.host.s : ran%/init.h -- cgit From ad5c72c2bf72e11eeb58e95842879c272077e669 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 16:30:34 +0100 Subject: run also on IA32 remove -k --- .gitlab-ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index bf83a026..7de12153 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -35,7 +35,7 @@ build_ia32: - ./config_ia32.sh - make -j "$NJOBS" - make -C test all test -# - make -C test/monniaux/yarpgen disabled due to -m32/-m64 issues + - make -C test/monniaux/yarpgen BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -58,7 +58,7 @@ build_aarch64: - ./config_aarch64.sh - make -j "$NJOBS" - make -C test CCOMPOPTS='-static' SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - make -C test/monniaux/yarpgen TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -81,7 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 + - make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -146,7 +146,7 @@ build_rv64: - ./config_rv64.sh - make -j "$NJOBS" - make -C test CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - make -C test/monniaux/yarpgen TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From d3fe2c1d8a05b5124395cca3de0cf91470424e55 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 16:43:10 +0100 Subject: enlarge stack size --- .gitlab-ci.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7de12153..2294d090 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -12,7 +12,7 @@ build_x86_64: - ./config_x86_64.sh - make -j "$NJOBS" - make -C test all test - - make -C test/monniaux/yarpgen + - ulimit -s65536 && make -C test/monniaux/yarpgen rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -35,7 +35,7 @@ build_ia32: - ./config_ia32.sh - make -j "$NJOBS" - make -C test all test - - make -C test/monniaux/yarpgen BITS=32 + - ulimit -s65536 && make -C test/monniaux/yarpgen BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -58,7 +58,7 @@ build_aarch64: - ./config_aarch64.sh - make -j "$NJOBS" - make -C test CCOMPOPTS='-static' SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test - - make -C test/monniaux/yarpgen TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -81,7 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test - - make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -146,7 +146,7 @@ build_rv64: - ./config_rv64.sh - make -j "$NJOBS" - make -C test CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test - - make -C test/monniaux/yarpgen TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 55b7716fa59b7b3c1b16f64b5b9debbd1736a974 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 17:01:49 +0100 Subject: fixup for arm --- test/monniaux/yarpgen/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 339d6808..a9f62eb7 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -54,7 +54,7 @@ tests_s: $(TESTS_CCOMP_TARGET_S) $(CC) $(CFLAGS) -S -o $@ $< %.target.o : %.target.s - $(TARGET_CC) $(CFLAGS) -c -o $@ $< + $(TARGET_CC) -c -o $@ $< %.host.o : %.host.s $(CC) $(CFLAGS) -c -o $@ $< -- cgit From dc9a19346eb6bb69b30381beb703a4b8c2a7c59b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 17:33:53 +0100 Subject: yet another problem with 32-bit arm --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2294d090..9d2103b1 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -73,7 +73,7 @@ build_arm: 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 + - sudo apt-get -y install gcc-multilib gcc-multilib-arm-linux-gnueabihf qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir -- cgit From 6008cab1fad50f61cf76075664e6c8bada818509 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 17:38:38 +0100 Subject: Debian is not like Ubuntu on multilib! --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9d2103b1..d4b1385e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -73,7 +73,7 @@ build_arm: 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 gcc-multilib-arm-linux-gnueabihf qemu-user + - sudo apt-get -y install gcc-multilib gcc-arm-linux-gnueabihf qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir -- cgit From 2bf8878a4b424e0481e9931c9047f6450e7ba0fd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 17:49:30 +0100 Subject: remove tests wrt host --- .gitlab-ci.yml | 2 +- test/monniaux/yarpgen/Makefile | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d4b1385e..2294d090 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -73,7 +73,7 @@ build_arm: 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 gcc-arm-linux-gnueabihf qemu-user + - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index a9f62eb7..65759f1e 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -36,7 +36,7 @@ TESTS_GCC_HOST_S=$(TEST_C:.c=.gcc.host.s) TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) -TESTS_CMP=$(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) $(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) +TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) # $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) -- cgit From bd432c88df63a21dfd3cfbf038f25781fa8b0ee5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 18:06:16 +0100 Subject: use gcc -m32 on ia32 --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2294d090..fd5dffe5 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -35,7 +35,7 @@ build_ia32: - ./config_ia32.sh - make -j "$NJOBS" - make -C test all test - - ulimit -s65536 && make -C test/monniaux/yarpgen BITS=32 + - ulimit -s65536 && make -C test/monniaux/yarpgen BITS=32 TARGET_CC='gcc -m32' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From 80078dcafb07578878a3d0ed2a52c08b4ee12e4a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 18:25:25 +0100 Subject: remove host .s generation --- test/monniaux/yarpgen/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 65759f1e..28bd5ae0 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -38,7 +38,7 @@ TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(M TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) # $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) -all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) +all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_CMP) $(TESTS_C) tests_c: $(TESTS_C) -- cgit From 39d53bf1d57c6ce9c78cbc42521ad96a783e6896 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 19:09:55 +0100 Subject: More Yarpgen --- .gitlab-ci.yml | 10 +++++----- test/monniaux/yarpgen/Makefile | 25 +++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5f696257..fd5dffe5 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -12,7 +12,7 @@ build_x86_64: - ./config_x86_64.sh - make -j "$NJOBS" - make -C test all test - - make -C test/monniaux/yarpgen + - ulimit -s65536 && make -C test/monniaux/yarpgen rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -35,7 +35,7 @@ build_ia32: - ./config_ia32.sh - make -j "$NJOBS" - make -C test all test -# - make -C test/monniaux/yarpgen disabled due to -m32/-m64 issues + - ulimit -s65536 && make -C test/monniaux/yarpgen BITS=32 TARGET_CC='gcc -m32' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -58,7 +58,7 @@ build_aarch64: - ./config_aarch64.sh - make -j "$NJOBS" - make -C test CCOMPOPTS='-static' SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -81,7 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test -# - make -C test/monniaux/yarpgen -k TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' disabled; mysterious differences between gcc/clang and compcert + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always @@ -146,7 +146,7 @@ build_rv64: - ./config_rv64.sh - make -j "$NJOBS" - make -C test CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test - - make -C test/monniaux/yarpgen -k TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index dbd6ae75..30080855 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -10,6 +10,14 @@ YARPGEN=./yarpgen GENERATOR=yarpgen endif +<<<<<<< HEAD +======= +ifdef BITS +YARPGEN+=-m $(BITS) +CFLAGS+=-m$(BITS) +endif + +>>>>>>> origin/mppa-ci MAX=129 PREFIX=ran%06.f @@ -31,9 +39,15 @@ TESTS_GCC_HOST_S=$(TEST_C:.c=.gcc.host.s) TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) +<<<<<<< HEAD TESTS_CMP=$(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) $(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) +======= +TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) # $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) + +all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_CMP) $(TESTS_C) +>>>>>>> origin/mppa-ci tests_c: $(TESTS_C) @@ -51,11 +65,22 @@ tests_s: $(TESTS_CCOMP_TARGET_S) %.target.o : %.target.s $(TARGET_CC) -c -o $@ $< +<<<<<<< HEAD %.target.out : %.target $(EXECUTE) $< > $@ %.host.out : %.host ./$< > $@ +======= +%.host.o : %.host.s + $(CC) $(CFLAGS) -c -o $@ $< + +%.target.out : %.target + $(EXECUTE) $< | tee $@ + +%.host.out : %.host + ./$< | tee $@ +>>>>>>> origin/mppa-ci ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s ran%/init.gcc.host.s : ran%/init.h -- cgit From e0fcc8d9023d962ec3921d8c6f09c8baa69bca32 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 19:33:37 +0100 Subject: fix Makefile --- test/monniaux/yarpgen/Makefile | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 30080855..28bd5ae0 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -10,14 +10,11 @@ YARPGEN=./yarpgen GENERATOR=yarpgen endif -<<<<<<< HEAD -======= ifdef BITS YARPGEN+=-m $(BITS) CFLAGS+=-m$(BITS) endif ->>>>>>> origin/mppa-ci MAX=129 PREFIX=ran%06.f @@ -39,15 +36,9 @@ TESTS_GCC_HOST_S=$(TEST_C:.c=.gcc.host.s) TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX)) TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX)) TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) -<<<<<<< HEAD -TESTS_CMP=$(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) $(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) - -all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_GCC_HOST_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_GCC_HOST_S) $(TESTS_CMP) $(TESTS_C) -======= TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) # $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_CMP) $(TESTS_C) ->>>>>>> origin/mppa-ci tests_c: $(TESTS_C) @@ -65,13 +56,6 @@ tests_s: $(TESTS_CCOMP_TARGET_S) %.target.o : %.target.s $(TARGET_CC) -c -o $@ $< -<<<<<<< HEAD -%.target.out : %.target - $(EXECUTE) $< > $@ - -%.host.out : %.host - ./$< > $@ -======= %.host.o : %.host.s $(CC) $(CFLAGS) -c -o $@ $< @@ -80,7 +64,6 @@ tests_s: $(TESTS_CCOMP_TARGET_S) %.host.out : %.host ./$< | tee $@ ->>>>>>> origin/mppa-ci ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s ran%/init.gcc.host.s : ran%/init.h -- cgit From 14f89bf9c397a4268d2b47418de234992b008d6c Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 29 Mar 2020 11:35:58 +0200 Subject: Explicit error messages for ill-formed section attributes (#232) Introduce an error message for section attributes with non string arguments,and another for multiple, ambiguous section attributes. This is more consistent with the handling of other attributes, like packed, than the old behavior of silently ignoring them. --- cfrontend/C2C.ml | 4 ++-- common/Sections.ml | 29 +++++++++++++++++++++-------- common/Sections.mli | 4 ++-- 3 files changed, 25 insertions(+), 12 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 293e79f0..7f796fe3 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1234,7 +1234,7 @@ let convertFundef loc env fd = { a_storage = fd.fd_storage; a_alignment = None; a_size = None; - a_sections = Sections.for_function env id' fd.fd_attrib; + a_sections = Sections.for_function env loc id' fd.fd_attrib; a_access = Sections.Access_default; a_inline = inline; a_loc = loc }; @@ -1311,7 +1311,7 @@ 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 loc id' ty (optinit <> None) 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..839128a5 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -160,9 +160,22 @@ let gcc_section name readonly exec = sec_writable = not readonly; sec_executable = exec; sec_access = Access_default } +(* Check and extract whether a section was given as attribute *) + +let get_attr_section loc attr = + match Cutil.find_custom_attributes ["section"; "__section__"] attr with + | [] -> None + | [[C.AString name]] -> Some name + | [[_]] -> + Diagnostics.error loc "'section' attribute requires a string"; + None + | _ -> + Diagnostics.error loc "ambiguous 'section' attribute"; + None + (* Determine section for a variable definition *) -let for_variable env id ty init = +let for_variable env loc id ty init = 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 = @@ -170,11 +183,11 @@ let for_variable env id ty init = (* 1- Section explicitly associated with #use_section *) Hashtbl.find use_section_table id with Not_found -> - match Cutil.find_custom_attributes ["section"; "__section__"] attr with - | [[C.AString name]] -> + match get_attr_section loc attr with + | Some name -> (* 2- Section given as an attribute, gcc-style *) gcc_section name readonly false - | _ -> + | None -> (* 3- Default section appropriate for size and const-ness *) let size = match Cutil.sizeof env ty with Some sz -> sz | None -> max_int in @@ -190,17 +203,17 @@ let for_variable env id ty init = (* Determine sections for a function definition *) -let for_function env id attr = +let for_function env loc id attr = let si_code = try (* 1- Section explicitly associated with #use_section *) Hashtbl.find use_section_table id with Not_found -> - match Cutil.find_custom_attributes ["section"; "__section__"] attr with - | [[C.AString name]] -> + match get_attr_section loc attr with + | Some name -> (* 2- Section given as an attribute, gcc-style *) gcc_section name true true - | _ -> + | None -> (* 3- Default section *) try Hashtbl.find current_section_table "CODE" diff --git a/common/Sections.mli b/common/Sections.mli index bc97814d..d9fd9239 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -46,7 +46,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 -> C.location -> AST.ident -> C.typ -> bool -> section_name * access_mode -val for_function: Env.t -> AST.ident -> C.attributes -> section_name list +val for_function: Env.t -> C.location -> AST.ident -> C.attributes -> section_name list val for_stringlit: unit -> section_name -- cgit From ac16e9fd0fde714464fbef4719e1a341208d5a93 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 29 Mar 2020 12:29:03 +0200 Subject: fix mismatch between hardware FP and software FP on ARM --- .gitlab-ci.yml | 28 ++++++++++++++++++++++++++-- config_arm.sh | 2 +- config_armhf.sh | 1 + 3 files changed, 28 insertions(+), 3 deletions(-) create mode 100755 config_armhf.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fd5dffe5..eaa313f1 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -73,14 +73,38 @@ build_arm: 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 + - sudo apt-get -y install gcc-arm-linux-gnueabi qemu-user - opam switch 4.07.1+flambda - eval `opam config env` - opam install -y menhir script: - ./config_arm.sh - make -j "$NJOBS" - - make -C test DIRS="c compression spass regression" CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test + - make -C test CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual + + +build_armhf: + stage: build + 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 + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir + script: + - ./config_armhf.sh + - make -j "$NJOBS" + - make -C test CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' diff --git a/config_arm.sh b/config_arm.sh index eed55fab..1861e029 100755 --- a/config_arm.sh +++ b/config_arm.sh @@ -1 +1 @@ -exec ./config_simple.sh arm-linux --toolprefix arm-linux-gnueabihf- "$@" +exec ./config_simple.sh arm-linux --toolprefix arm-linux-gnueabi- "$@" diff --git a/config_armhf.sh b/config_armhf.sh new file mode 100755 index 00000000..8a1302bd --- /dev/null +++ b/config_armhf.sh @@ -0,0 +1 @@ +exec ./config_simple.sh arm-eabihf --toolprefix arm-linux-gnueabihf- "$@" -- cgit From aa4dcf296521ebe5be4aee5ee29aa678b8325c46 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 29 Mar 2020 12:46:56 +0200 Subject: fix typo in hf --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index eaa313f1..79a32b25 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -81,7 +81,7 @@ build_arm: - ./config_arm.sh - make -j "$NJOBS" - make -C test CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test - - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 + - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabi-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32 rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always -- cgit From b52ebb5aaaf9838310d1b7e68b9198c388cab74a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 30 Mar 2020 15:24:40 +0200 Subject: Fixing heuristics too sure of themselves --- backend/Duplicateaux.ml | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 54d60d24..28ad4266 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -159,8 +159,11 @@ let do_call_heuristic code cond ifso ifnot is_loop_header = let predicate n = (function | Icall _ -> true | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then Some false - else if (look_ahead code ifnot is_loop_header predicate) then Some true + in let ifso_call = look_ahead code ifso is_loop_header predicate + in let ifnot_call = look_ahead code ifnot is_loop_header predicate + in if ifso_call && ifnot_call then None + else if ifso_call then Some false + else if ifnot_call then Some true else None end @@ -176,8 +179,11 @@ let do_return_heuristic code cond ifso ifnot is_loop_header = let predicate n = (function | Ireturn _ -> true | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then Some false - else if (look_ahead code ifnot is_loop_header predicate) then Some true + in let ifso_return = look_ahead code ifso is_loop_header predicate + in let ifnot_return = look_ahead code ifnot is_loop_header predicate + in if ifso_return && ifnot_return then None + else if ifso_return then Some false + else if ifnot_return then Some true else None end @@ -187,8 +193,11 @@ let do_store_heuristic code cond ifso ifnot is_loop_header = let predicate n = (function | Istore _ -> true | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then Some false - else if (look_ahead code ifnot is_loop_header predicate) then Some true + in let ifso_store = look_ahead code ifso is_loop_header predicate + in let ifnot_store = look_ahead code ifnot is_loop_header predicate + in if ifso_store && ifnot_store then None + else if ifso_store then Some false + else if ifnot_store then Some true else None end -- cgit From f2de2518509f198c5ce958ec06c18e78e896f814 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 30 Mar 2020 12:59:24 +0200 Subject: Add a test for int64 -> float32 conversion This is a special value that causes double rounding with the naive conversion schema int64 -> float64 -> float32. --- test/regression/Results/int64 | 874 ++++++++++++++++++++++++++++++++++++++++-- test/regression/int64.c | 3 +- 2 files changed, 838 insertions(+), 39 deletions(-) diff --git a/test/regression/Results/int64 b/test/regression/Results/int64 index af444cf6..ae8a3cc1 100644 --- a/test/regression/Results/int64 +++ b/test/regression/Results/int64 @@ -334,6 +334,48 @@ dtos f = 0 utof x = 0 stof x = 0 +x = 0 +y = 52ce6b4000000063 +-x = 0 +x + y = 52ce6b4000000063 +x - y = ad3194bfffffff9d +x * y = 0 +x /u y = 0 +x %u y = 0 +x /s y = 0 +x %s y = 0 +x /u y2 = 0 +x %u y2 = 0 +x /s y3 = 0 +x %s y3 = 0 +x /u 3 = 0 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = 0 +x /u 5 = 0 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = 0 +x /u 11 = 0 +x %u 11 = 0 +x /s 11 = 0 +x %s 11 = 0 +~x = ffffffffffffffff +x & y = 0 +x | y = 52ce6b4000000063 +x ^ y = 52ce6b4000000063 +x << i = 0 +x >>u i = 0 +x >>s i = 0 +x cmpu y = lt +x cmps y = lt +utod x = 0 +dtou f = 0 +stod x = 0 +dtos f = 0 +utof x = 0 +stof x = 0 + x = 0 y = 14057b7ef767814f -x = 0 @@ -754,6 +796,48 @@ dtos f = 0 utof x = 3f800000 stof x = 3f800000 +x = 1 +y = 52ce6b4000000063 +-x = ffffffffffffffff +x + y = 52ce6b4000000064 +x - y = ad3194bfffffff9e +x * y = 52ce6b4000000063 +x /u y = 0 +x %u y = 1 +x /s y = 0 +x %s y = 1 +x /u y2 = 0 +x %u y2 = 1 +x /s y3 = 0 +x %s y3 = 1 +x /u 3 = 0 +x %u 3 = 1 +x /s 3 = 0 +x %s 3 = 1 +x /u 5 = 0 +x %u 5 = 1 +x /s 5 = 0 +x %s 5 = 1 +x /u 11 = 0 +x %u 11 = 1 +x /s 11 = 0 +x %s 11 = 1 +~x = fffffffffffffffe +x & y = 1 +x | y = 52ce6b4000000063 +x ^ y = 52ce6b4000000062 +x << i = 800000000 +x >>u i = 0 +x >>s i = 0 +x cmpu y = lt +x cmps y = lt +utod x = 3ff0000000000000 +dtou f = 0 +stod x = 3ff0000000000000 +dtos f = 0 +utof x = 3f800000 +stof x = 3f800000 + x = 1 y = 9af678222e728119 -x = ffffffffffffffff @@ -1174,6 +1258,48 @@ dtos f = 0 utof x = 5f800000 stof x = bf800000 +x = ffffffffffffffff +y = 52ce6b4000000063 +-x = 1 +x + y = 52ce6b4000000062 +x - y = ad3194bfffffff9c +x * y = ad3194bfffffff9d +x /u y = 3 +x %u y = 794be3ffffffed6 +x /s y = 0 +x %s y = ffffffffffffffff +x /u y2 = 3176fe836 +x %u y2 = 3683607f +x /s y3 = 0 +x %s y3 = ffffffffffffffff +x /u 3 = 5555555555555555 +x %u 3 = 0 +x /s 3 = 0 +x %s 3 = ffffffffffffffff +x /u 5 = 3333333333333333 +x %u 5 = 0 +x /s 5 = 0 +x %s 5 = ffffffffffffffff +x /u 11 = 1745d1745d1745d1 +x %u 11 = 4 +x /s 11 = 0 +x %s 11 = ffffffffffffffff +~x = 0 +x & y = 52ce6b4000000063 +x | y = ffffffffffffffff +x ^ y = ad3194bfffffff9c +x << i = fffffff800000000 +x >>u i = 1fffffff +x >>s i = ffffffffffffffff +x cmpu y = gt +x cmps y = lt +utod x = 43f0000000000000 +dtou f = 68db8bac710cb +stod x = bff0000000000000 +dtos f = 0 +utof x = 5f800000 +stof x = bf800000 + x = ffffffffffffffff y = 62354cda6226d1f3 -x = 1 @@ -1594,6 +1720,48 @@ dtos f = 346dc utof x = 4f000000 stof x = 4f000000 +x = 7fffffff +y = 52ce6b4000000063 +-x = ffffffff80000001 +x + y = 52ce6b4080000062 +x - y = ad3194c07fffff9c +x * y = ad3194f17fffff9d +x /u y = 0 +x %u y = 7fffffff +x /s y = 0 +x %s y = 7fffffff +x /u y2 = 1 +x %u y2 = 2d3194bf +x /s y3 = 1 +x %s y3 = 2d3194bf +x /u 3 = 2aaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaa +x %s 3 = 1 +x /u 5 = 19999999 +x %u 5 = 2 +x /s 5 = 19999999 +x %s 5 = 2 +x /u 11 = ba2e8ba +x %u 11 = 1 +x /s 11 = ba2e8ba +x %s 11 = 1 +~x = ffffffff80000000 +x & y = 63 +x | y = 52ce6b407fffffff +x ^ y = 52ce6b407fffff9c +x << i = fffffff800000000 +x >>u i = 0 +x >>s i = 0 +x cmpu y = lt +x cmps y = lt +utod x = 41dfffffffc00000 +dtou f = 346dc +stod x = 41dfffffffc00000 +dtos f = 346dc +utof x = 4f000000 +stof x = 4f000000 + x = 7fffffff y = 144093704fadba5d -x = ffffffff80000001 @@ -2014,6 +2182,48 @@ dtos f = 346dc utof x = 4f000000 stof x = 4f000000 +x = 80000000 +y = 52ce6b4000000063 +-x = ffffffff80000000 +x + y = 52ce6b4080000063 +x - y = ad3194c07fffff9d +x * y = 3180000000 +x /u y = 0 +x %u y = 80000000 +x /s y = 0 +x %s y = 80000000 +x /u y2 = 1 +x %u y2 = 2d3194c0 +x /s y3 = 1 +x %s y3 = 2d3194c0 +x /u 3 = 2aaaaaaa +x %u 3 = 2 +x /s 3 = 2aaaaaaa +x %s 3 = 2 +x /u 5 = 19999999 +x %u 5 = 3 +x /s 5 = 19999999 +x %s 5 = 3 +x /u 11 = ba2e8ba +x %u 11 = 2 +x /s 11 = ba2e8ba +x %s 11 = 2 +~x = ffffffff7fffffff +x & y = 0 +x | y = 52ce6b4080000063 +x ^ y = 52ce6b4080000063 +x << i = 0 +x >>u i = 0 +x >>s i = 0 +x cmpu y = lt +x cmps y = lt +utod x = 41e0000000000000 +dtou f = 346dc +stod x = 41e0000000000000 +dtos f = 346dc +utof x = 4f000000 +stof x = 4f000000 + x = 80000000 y = 7b985bc1e7bce4d7 -x = ffffffff80000000 @@ -2434,6 +2644,48 @@ dtos f = 346dc5d638865 utof x = 5f000000 stof x = 5f000000 +x = 7fffffffffffffff +y = 52ce6b4000000063 +-x = 8000000000000001 +x + y = d2ce6b4000000062 +x - y = 2d3194bfffffff9c +x * y = 2d3194bfffffff9d +x /u y = 1 +x %u y = 2d3194bfffffff9c +x /s y = 1 +x %s y = 2d3194bfffffff9c +x /u y2 = 18bb7f41b +x %u y2 = 1b41b03f +x /s y3 = 18bb7f41b +x %s y3 = 1b41b03f +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 1 +x /s 3 = 2aaaaaaaaaaaaaaa +x %s 3 = 1 +x /u 5 = 1999999999999999 +x %u 5 = 2 +x /s 5 = 1999999999999999 +x %s 5 = 2 +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 7 +x /s 11 = ba2e8ba2e8ba2e8 +x %s 11 = 7 +~x = 8000000000000000 +x & y = 52ce6b4000000063 +x | y = 7fffffffffffffff +x ^ y = 2d3194bfffffff9c +x << i = fffffff800000000 +x >>u i = fffffff +x >>s i = fffffff +x cmpu y = gt +x cmps y = gt +utod x = 43e0000000000000 +dtou f = 346dc5d638865 +stod x = 43e0000000000000 +dtos f = 346dc5d638865 +utof x = 5f000000 +stof x = 5f000000 + x = 7fffffffffffffff y = a220229ec164ffe1 -x = 8000000000000001 @@ -2854,6 +3106,48 @@ dtos f = fffcb923a29c779b utof x = 5f000000 stof x = df000000 +x = 8000000000000000 +y = 52ce6b4000000063 +-x = 8000000000000000 +x + y = d2ce6b4000000063 +x - y = 2d3194bfffffff9d +x * y = 8000000000000000 +x /u y = 1 +x %u y = 2d3194bfffffff9d +x /s y = ffffffffffffffff +x %s y = d2ce6b4000000063 +x /u y2 = 18bb7f41b +x %u y2 = 1b41b040 +x /s y3 = fffffffe74480be5 +x %s y3 = ffffffffe4be4fc0 +x /u 3 = 2aaaaaaaaaaaaaaa +x %u 3 = 2 +x /s 3 = d555555555555556 +x %s 3 = fffffffffffffffe +x /u 5 = 1999999999999999 +x %u 5 = 3 +x /s 5 = e666666666666667 +x %s 5 = fffffffffffffffd +x /u 11 = ba2e8ba2e8ba2e8 +x %u 11 = 8 +x /s 11 = f45d1745d1745d18 +x %s 11 = fffffffffffffff8 +~x = 7fffffffffffffff +x & y = 0 +x | y = d2ce6b4000000063 +x ^ y = d2ce6b4000000063 +x << i = 0 +x >>u i = 10000000 +x >>s i = fffffffff0000000 +x cmpu y = gt +x cmps y = lt +utod x = 43e0000000000000 +dtou f = 346dc5d638865 +stod x = c3e0000000000000 +dtos f = fffcb923a29c779b +utof x = 5f000000 +stof x = df000000 + x = 8000000000000000 y = c73aa0d9a415dfb -x = 8000000000000000 @@ -3274,6 +3568,48 @@ dtos f = 68db8 utof x = 4f800000 stof x = 4f800000 +x = 100000003 +y = 52ce6b4000000063 +-x = fffffffefffffffd +x + y = 52ce6b4100000066 +x - y = ad3194c0ffffffa0 +x * y = f86b422300000129 +x /u y = 0 +x %u y = 100000003 +x /s y = 0 +x %s y = 100000003 +x /u y2 = 3 +x %u y2 = 794be43 +x /s y3 = 3 +x %s y3 = 794be43 +x /u 3 = 55555556 +x %u 3 = 1 +x /s 3 = 55555556 +x %s 3 = 1 +x /u 5 = 33333333 +x %u 5 = 4 +x /s 5 = 33333333 +x %s 5 = 4 +x /u 11 = 1745d174 +x %u 11 = 7 +x /s 11 = 1745d174 +x %s 11 = 7 +~x = fffffffefffffffc +x & y = 3 +x | y = 52ce6b4100000063 +x ^ y = 52ce6b4100000060 +x << i = 1800000000 +x >>u i = 0 +x >>s i = 0 +x cmpu y = lt +x cmps y = lt +utod x = 41f0000000300000 +dtou f = 68db8 +stod x = 41f0000000300000 +dtos f = 68db8 +utof x = 4f800000 +stof x = 4f800000 + x = 100000003 y = e9bcd26890f095a5 -x = fffffffefffffffd @@ -3358,47 +3694,467 @@ dtos f = 14bb101261e18 utof x = 5e4a72c9 stof x = 5e4a72c9 -x = 8362aa9340fe215f -y = f986342416ec8002 --x = 7c9d556cbf01dea1 -x + y = 7ce8deb757eaa161 -x - y = 89dc766f2a11a15d -x * y = e4a2b426803fc2be +x = 52ce6b4000000063 +y = 0 +-x = ad3194bfffffff9d +x + y = 52ce6b4000000063 +x - y = 52ce6b4000000063 +x * y = 0 x /u y = 0 -x %u y = 8362aa9340fe215f -x /s y = 13 -x %s y = fe6ccbe58d70a139 -x /u y2 = 86cb918b -x %u y2 = 910b6dd3 -x /s y3 = 133e437097 -x %s y3 = fffffffffe99a023 -x /u 3 = 2bcb8e3115aa0b1f -x %u 3 = 2 -x /s 3 = d67638dbc054b5cb -x %s 3 = fffffffffffffffe -x /u 5 = 1a46eeea4032d379 -x %u 5 = 2 -x /s 5 = e713bbb70cffa047 -x %s 5 = fffffffffffffffc -x /u 11 = bf1b26a7a45a5f1 -x %u 11 = 4 -x /s 11 = f4abe0f61d2e6020 -x %s 11 = ffffffffffffffff -~x = 7c9d556cbf01dea0 -x & y = 8102200000ec0002 -x | y = fbe6beb756fea15f -x ^ y = 7ae49eb75612a15d -x << i = d8aaa4d03f8857c -x >>u i = 20d8aaa4d03f8857 -x >>s i = e0d8aaa4d03f8857 +x %u y = 0 +x /s y = 0 +x %s y = 0 +x /u y2 = 0 +x %u y2 = 0 +x /s y3 = 0 +x %s y3 = 0 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 0 +x | y = 52ce6b4000000063 +x ^ y = 52ce6b4000000063 +x << i = 52ce6b4000000063 +x >>u i = 52ce6b4000000063 +x >>s i = 52ce6b4000000063 +x cmpu y = gt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 1 +-x = ad3194bfffffff9d +x + y = 52ce6b4000000064 +x - y = 52ce6b4000000062 +x * y = 52ce6b4000000063 +x /u y = 52ce6b4000000063 +x %u y = 0 +x /s y = 52ce6b4000000063 +x %s y = 0 +x /u y2 = 0 +x %u y2 = 0 +x /s y3 = 0 +x %s y3 = 0 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 1 +x | y = 52ce6b4000000063 +x ^ y = 52ce6b4000000062 +x << i = a59cd680000000c6 +x >>u i = 296735a000000031 +x >>s i = 296735a000000031 +x cmpu y = gt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = ffffffffffffffff +-x = ad3194bfffffff9d +x + y = 52ce6b4000000062 +x - y = 52ce6b4000000064 +x * y = ad3194bfffffff9d +x /u y = 0 +x %u y = 52ce6b4000000063 +x /s y = ad3194bfffffff9d +x %s y = 0 +x /u y2 = 52ce6b40 +x %u y2 = 52ce6ba3 +x /s y3 = ad3194bfffffff9d +x %s y3 = 0 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 52ce6b4000000063 +x | y = ffffffffffffffff +x ^ y = ad3194bfffffff9c +x << i = 8000000000000000 +x >>u i = 0 +x >>s i = 0 +x cmpu y = lt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 7fffffff +-x = ad3194bfffffff9d +x + y = 52ce6b4080000062 +x - y = 52ce6b3f80000064 +x * y = ad3194f17fffff9d +x /u y = a59cd681 +x %u y = 259cd6e4 +x /s y = a59cd681 +x %s y = 259cd6e4 +x /u y2 = 0 +x %u y2 = 0 +x /s y3 = 0 +x %s y3 = 0 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 63 +x | y = 52ce6b407fffffff +x ^ y = 52ce6b407fffff9c +x << i = 8000000000000000 +x >>u i = 0 +x >>s i = 0 +x cmpu y = gt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 80000000 +-x = ad3194bfffffff9d +x + y = 52ce6b4080000063 +x - y = 52ce6b3f80000063 +x * y = 3180000000 +x /u y = a59cd680 +x %u y = 63 +x /s y = a59cd680 +x %s y = 63 +x /u y2 = 0 +x %u y2 = 0 +x /s y3 = 0 +x %s y3 = 0 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 0 +x | y = 52ce6b4080000063 +x ^ y = 52ce6b4080000063 +x << i = 52ce6b4000000063 +x >>u i = 52ce6b4000000063 +x >>s i = 52ce6b4000000063 +x cmpu y = gt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 7fffffffffffffff +-x = ad3194bfffffff9d +x + y = d2ce6b4000000062 +x - y = d2ce6b4000000064 +x * y = 2d3194bfffffff9d +x /u y = 0 +x %u y = 52ce6b4000000063 +x /s y = 0 +x %s y = 52ce6b4000000063 +x /u y2 = a59cd681 +x %u y2 = 259cd6e4 +x /s y3 = a59cd681 +x %s y3 = 259cd6e4 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 52ce6b4000000063 +x | y = 7fffffffffffffff +x ^ y = 2d3194bfffffff9c +x << i = 8000000000000000 +x >>u i = 0 +x >>s i = 0 x cmpu y = lt x cmps y = lt -utod x = 43e06c5552681fc4 -dtou f = 35d0c262d14d7 -stod x = c3df27555b2fc078 -dtos f = fffccf536b66040d -utof x = 5f0362ab -stof x = def93aab +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 8000000000000000 +-x = ad3194bfffffff9d +x + y = d2ce6b4000000063 +x - y = d2ce6b4000000063 +x * y = 8000000000000000 +x /u y = 0 +x %u y = 52ce6b4000000063 +x /s y = 0 +x %s y = 52ce6b4000000063 +x /u y2 = a59cd680 +x %u y2 = 63 +x /s y3 = ffffffff5a632980 +x %s y3 = 63 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 0 +x | y = d2ce6b4000000063 +x ^ y = d2ce6b4000000063 +x << i = 52ce6b4000000063 +x >>u i = 52ce6b4000000063 +x >>s i = 52ce6b4000000063 +x cmpu y = lt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 100000003 +-x = ad3194bfffffff9d +x + y = 52ce6b4100000066 +x - y = 52ce6b3f00000060 +x * y = f86b422300000129 +x /u y = 52ce6b3f +x %u y = 794bea6 +x /s y = 52ce6b3f +x %s y = 794bea6 +x /u y2 = 52ce6b4000000063 +x %u y2 = 0 +x /s y3 = 52ce6b4000000063 +x %s y3 = 0 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 3 +x | y = 52ce6b4100000063 +x ^ y = 52ce6b4100000060 +x << i = 96735a0000000318 +x >>u i = a59cd680000000c +x >>s i = a59cd680000000c +x cmpu y = gt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 52ce6b4000000063 +-x = ad3194bfffffff9d +x + y = a59cd680000000c6 +x - y = 0 +x * y = ba6f38000002649 +x /u y = 1 +x %u y = 0 +x /s y = 1 +x %s y = 0 +x /u y2 = 100000000 +x %u y2 = 63 +x /s y3 = 100000000 +x %s y3 = 63 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 52ce6b4000000063 +x | y = 52ce6b4000000063 +x ^ y = 0 +x << i = 31800000000 +x >>u i = a59cd68 +x >>s i = a59cd68 +x cmpu y = eq +x cmps y = eq +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = 52ce6b4000000063 +y = 8362aa9340fe215f +-x = ad3194bfffffff9d +x + y = d63115d340fe21c2 +x - y = cf6bc0acbf01df04 +x * y = 8f1503b22246e7bd +x /u y = 0 +x %u y = 52ce6b4000000063 +x /s y = 0 +x %s y = 52ce6b4000000063 +x /u y2 = a158656f +x %u y2 = 5640ba6 +x /s y3 = ffffffff55e35d11 +x %s y3 = 5f2245a0 +x /u 3 = 1b9a23c000000021 +x %u 3 = 0 +x /s 3 = 1b9a23c000000021 +x %s 3 = 0 +x /u 5 = 108faf0ccccccce0 +x %u 5 = 3 +x /s 5 = 108faf0ccccccce0 +x %s 5 = 3 +x /u 11 = 7872105d1745d20 +x %u 11 = 3 +x /s 11 = 7872105d1745d20 +x %s 11 = 3 +~x = ad3194bfffffff9c +x & y = 2422a0000000043 +x | y = d3eeebd340fe217f +x ^ y = d1acc1d340fe213c +x << i = 3180000000 +x >>u i = a59cd680 +x >>s i = a59cd680 +x cmpu y = lt +x cmps y = gt +utod x = 43d4b39ad0000000 +dtou f = 21eadf559b3d0 +stod x = 43d4b39ad0000000 +dtos f = 21eadf559b3d0 +utof x = 5ea59cd7 +stof x = 5ea59cd7 + +x = f986342416ec8002 +y = 52ce6b4000000063 +-x = 679cbdbe9137ffe +x + y = 4c549f6416ec8065 +x - y = a6b7c8e416ec7f9f +x * y = b9230074dd7580c6 +x /u y = 3 +x %u y = 11af26416ec7ed9 +x /s y = 0 +x %s y = f986342416ec8002 +x /u y2 = 3036abea3 +x %u y2 = 164b642 +x /s y3 = ffffffffebfad66d +x %s y3 = ffffffffcae155c2 +x /u 3 = 532cbc0c07a42aab +x %u 3 = 1 +x /s 3 = fdd766b6b24ed556 +x %s 3 = 0 +x /u 5 = 31e7a40737c8e666 +x %u 5 = 4 +x /s 5 = feb470d40495b334 +x %s 5 = fffffffffffffffe +x /u 11 = 16af1c0347e6f45d +x %u 11 = 3 +x /s 11 = ff694a8eeacfae8c +x %s 11 = fffffffffffffffe +~x = 679cbdbe9137ffd +x & y = 5086200000000002 +x | y = fbce7f6416ec8063 +x ^ y = ab485f6416ec8061 +x << i = b764001000000000 +x >>u i = 1f30c684 +x >>s i = ffffffffff30c684 +x cmpu y = gt +x cmps y = lt +utod x = 43ef30c68482dd90 +dtou f = 6634832136daf +stod x = c399e72f6fa44e00 +dtos f = ffffd58f774c5ce4 +utof x = 5f798634 +stof x = dccf397b x = 368083376ba4ffa9 y = 6912b247b79a4904 @@ -7558,3 +8314,45 @@ dtos f = b3fdf698d581 utof x = 5ddbb784 stof x = 5ddbb784 +x = ca9a47c1649d27a7 +y = d56d650045e652aa +-x = 3565b83e9b62d859 +x + y = a007acc1aa837a51 +x - y = f52ce2c11eb6d4fd +x * y = 630e3c88ca19d2e6 +x /u y = 0 +x %u y = ca9a47c1649d27a7 +x /s y = 1 +x %s y = f52ce2c11eb6d4fd +x /u y2 = f3042098 +x %u y2 = 6b092fa7 +x /s y3 = 141176486 +x %s y3 = ffffffffdee649a7 +x /u 3 = 4388c295cc34628d +x %u 3 = 0 +x /s 3 = ee336d4076df0d38 +x %s 3 = ffffffffffffffff +x /u 5 = 2885418d141f6e54 +x %u 5 = 3 +x /s 5 = f5520e59e0ec3b22 +x %s 5 = fffffffffffffffd +x /u 11 = 126b1dcbc3541ae0 +x %u 11 = 7 +x /s 11 = fb254c57663cd510 +x %s 11 = fffffffffffffff7 +~x = 3565b83e9b62d858 +x & y = c0084500448402a2 +x | y = dfff67c165ff77af +x ^ y = 1ff722c1217b750d +x << i = 749e9c0000000000 +x >>u i = 32a691 +x >>s i = fffffffffff2a691 +x cmpu y = lt +x cmps y = lt +utod x = 43e95348f82c93a5 +dtou f = 52fc6dac31674 +stod x = c3cab2dc1f4db16c +dtos f = fffea20e1ffc05aa +utof x = 5f4a9a48 +stof x = de5596e1 + diff --git a/test/regression/int64.c b/test/regression/int64.c index d9785e95..0da9602d 100644 --- a/test/regression/int64.c +++ b/test/regression/int64.c @@ -103,7 +103,8 @@ u64 special_values[] = { 0x80000000LLU, 0x7FFFFFFFFFFFFFFFLLU, 0x8000000000000000LLU, - 0x100000003LLU + 0x100000003LLU, + 0x52ce6b4000000063LLU }; #define NUM_SPECIAL_VALUES (sizeof(special_values) / sizeof(u64)) -- cgit From f1abe04e503f1c54c5a50f7b3f3906beca15a760 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 29 Mar 2020 11:20:01 +0200 Subject: Double rounding error in int64->float32 conversions on PowerPC and ARM The "stof" and "utof" runtime functions contain a round-to-odd step that avoids double rounding. However, this step was incorrectly coded on PowerPC (stof and utof), PowerPC64 (utof), and ARM (stof), making round-to-odd ineffective and causing double rounding. Closes: #343 --- runtime/arm/i64_stof.S | 9 ++++----- runtime/powerpc/i64_stof.s | 17 ++++++++--------- runtime/powerpc/i64_utof.s | 10 +++++----- runtime/powerpc64/i64_utof.s | 10 +++++----- 4 files changed, 22 insertions(+), 24 deletions(-) diff --git a/runtime/arm/i64_stof.S b/runtime/arm/i64_stof.S index bcfa471c..11e00a2a 100644 --- a/runtime/arm/i64_stof.S +++ b/runtime/arm/i64_stof.S @@ -39,12 +39,11 @@ @@@ Conversion from signed 64-bit integer to single float FUNCTION(__compcert_i64_stof) - @ Check whether -2^53 <= X < 2^53 - ASR r2, Reg0HI, #21 - ASR r3, Reg0HI, #31 @ (r2,r3) = X >> 53 + @ Check whether -2^53 <= X < 2^53 + ASR r2, Reg0HI, #21 @ r2 = high 32 bits of X >> 53 + @ -2^53 <= X < 2^53 iff r2 is -1 or 0, that is, iff r2 + 1 is 0 or 1 adds r2, r2, #1 - adc r3, r3, #0 @ (r2,r3) = X >> 53 + 1 - cmp r3, #2 + cmp r2, #2 blo 1f @ X is large enough that double rounding can occur. @ Avoid it by nudging X away from the points where double rounding diff --git a/runtime/powerpc/i64_stof.s b/runtime/powerpc/i64_stof.s index 97fa6bb8..ea23a1c8 100644 --- a/runtime/powerpc/i64_stof.s +++ b/runtime/powerpc/i64_stof.s @@ -43,20 +43,19 @@ __compcert_i64_stof: mflr r9 # Check whether -2^53 <= X < 2^53 - srawi r5, r3, 31 - srawi r6, r3, 21 # (r5,r6) = X >> 53 - addic r6, r6, 1 - addze r5, r5 # (r5,r6) = (X >> 53) + 1 + srawi r5, r3, 21 # r5 = high 32 bits of X >> 53 + # -2^53 <= X < 2^53 iff r5 is -1 or 0, that is, iff r5 + 1 is 0 or 1 + addi r5, r5, 1 cmplwi r5, 2 blt 1f # X is large enough that double rounding can occur. # Avoid it by nudging X away from the points where double rounding # occurs (the "round to odd" technique) - rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X - addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF - # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise - # bits 13-31 of r0 are 0 - or r4, r4, r0 # correct bit number 12 of X + rlwinm r5, r4, 0, 21, 31 # extract bits 0 to 11 of X + addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF + # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-31 of r5 are 0 + or r4, r4, r5 # correct bit number 12 of X rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X # Convert to double, then round to single 1: bl __compcert_i64_stod diff --git a/runtime/powerpc/i64_utof.s b/runtime/powerpc/i64_utof.s index cdb2f867..4a2a172b 100644 --- a/runtime/powerpc/i64_utof.s +++ b/runtime/powerpc/i64_utof.s @@ -48,11 +48,11 @@ __compcert_i64_utof: # X is large enough that double rounding can occur. # Avoid it by nudging X away from the points where double rounding # occurs (the "round to odd" technique) - rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X - addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF - # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise - # bits 13-31 of r0 are 0 - or r4, r4, r0 # correct bit number 12 of X + rlwinm r5, r4, 0, 21, 31 # extract bits 0 to 11 of X + addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF + # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-31 of r5 are 0 + or r4, r4, r5 # correct bit number 12 of X rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X # Convert to double, then round to single 1: bl __compcert_i64_utod diff --git a/runtime/powerpc64/i64_utof.s b/runtime/powerpc64/i64_utof.s index cdb2f867..4a2a172b 100644 --- a/runtime/powerpc64/i64_utof.s +++ b/runtime/powerpc64/i64_utof.s @@ -48,11 +48,11 @@ __compcert_i64_utof: # X is large enough that double rounding can occur. # Avoid it by nudging X away from the points where double rounding # occurs (the "round to odd" technique) - rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X - addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF - # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise - # bits 13-31 of r0 are 0 - or r4, r4, r0 # correct bit number 12 of X + rlwinm r5, r4, 0, 21, 31 # extract bits 0 to 11 of X + addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF + # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise + # bits 13-31 of r5 are 0 + or r4, r4, r5 # correct bit number 12 of X rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X # Convert to double, then round to single 1: bl __compcert_i64_utod -- cgit From 144f466e3baa41e67d1fa908836a74536d52c201 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 31 Mar 2020 11:06:51 +0200 Subject: Update Changelog --- Changelog | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/Changelog b/Changelog index 08586da5..9dc858ca 100644 --- a/Changelog +++ b/Changelog @@ -1,7 +1,38 @@ -Coq development: -- Compatibility with Coq version 8.11.0 (#316) +ISO C conformance: +- Functions declared `extern` then implemented `inline` remain `extern` +- The type of a wide char constant is `wchar_t`, not `int` +- Support vertical tabs and treat them as whitespace +- Define the semantics of `free(NULL)` + +Bug fixing: +- Take sign into account for conversions from 32-bit integers to 64-bit pointers +- PowerPC: more precise determination of small data accesses +- AArch64: when addressing global variables, check for correct alignment +- PowerPC, ARM: double rounding error in int64->float32 conversions + +ABI conformance: +- x86, AArch64: re-normalize values of small integer types returned by + function calls +- PowerPC: `float` arguments passed on stack are passed in 64-bit format +- RISC-V: use the new ELF psABI instead of the old ABI from ISA 2.1 + +Usability and diagnostics: +- Unknown builtin functions trigger a specific error message +- Improved error messages + +Coq formalization: +- Revised modeling of the PowerPC/EREF `isel` instruction +- Weaker `ec_readonly` condition over external calls + (permissions can be dropped on read-only locations) + +Coq and OCaml development: +- Compatibility with Coq version 8.10.1, 8.10.2, 8.11.0 +- Compatibility with OCaml 4.10 and up +- Compatibility with Menhir 20200123 and up +- Coq versions prior to 8.8.0 are no longer supported +- OCaml versions prior to 4.05.0 are no longer supported + - Release 3.6, 2019-09-17 ======================= -- cgit From 6dace9be5f4760882f879d3026c168cc9112e150 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 31 Mar 2020 17:48:34 +0200 Subject: Updates for release 3.7 --- Changelog | 3 +++ doc/index.html | 4 +++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/Changelog b/Changelog index 9dc858ca..8cf4e548 100644 --- a/Changelog +++ b/Changelog @@ -1,3 +1,6 @@ +Release 3.7, 2020-03-31 +======================= + ISO C conformance: - Functions declared `extern` then implemented `inline` remain `extern` - The type of a wide char constant is `wchar_t`, not `int` diff --git a/doc/index.html b/doc/index.html index 3a4cf6ba..631c5d99 100644 --- a/doc/index.html +++ b/doc/index.html @@ -24,7 +24,7 @@ a:active {color : Red; text-decoration : underline; }

The CompCert verified compiler

Commented Coq development

-

Version 3.6, 2019-09-17

+

Version 3.7, 2020-03-31

Introduction

@@ -101,6 +101,8 @@ See also: Memdata (in-memory rep
  • Determinism: determinism properties of small-step semantics.
  • Op: operators, addressing modes and their semantics. +
  • Builtins: semantics of built-in functions.
    +See also: Builtins0 (target-independent part), Builtins1 (target-dependent part).
  • Unityping: a solver for atomic unification constraints. -- cgit From 76a4ff8f5b37429a614a2a97f628d9d862c93f46 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Tue, 31 Mar 2020 18:24:12 +0200 Subject: Updates for release 3.7 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 92686b06..b60e8d9b 100644 --- a/VERSION +++ b/VERSION @@ -1,3 +1,3 @@ -version=3.6 +version=3.7 buildnr= tag= -- cgit From 47f10ace41f8fb8ef818dbf1ca1d846b91b753c9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:10:14 +0200 Subject: forgot an 'Admitted' --- backend/CSE2proof.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index fc980fb4..309ccce1 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1680,7 +1680,7 @@ Proof. econstructor; split. eapply exec_return; eauto. constructor; auto. -Admitted. +Qed. Lemma transf_initial_states: -- cgit From aad09479f2ae3e008cbe38ca4fa0e8e3e04daec9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:18:49 +0200 Subject: add check-admitted --- .gitlab-ci.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 79a32b25..4c00848f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,6 +1,12 @@ stages: + - check-admitted - build +check-admitted: + stage: check-admitted + script: + - make check-admitted + build_x86_64: stage: build image: "coqorg/coq" -- cgit From 00b000ac303bf41434fae2765d10b0b719260d0c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:20:05 +0200 Subject: forgot image --- .gitlab-ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4c00848f..7d4578ef 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -4,6 +4,7 @@ stages: check-admitted: stage: check-admitted + image: "coqorg/coq" script: - make check-admitted -- cgit From 746cee9d2ea090c0b91dc358844f3456b8e91da8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:22:26 +0200 Subject: move check-admitted elsewhere --- .gitlab-ci.yml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7d4578ef..ed3cb261 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,11 +1,15 @@ stages: - - check-admitted - build check-admitted: - stage: check-admitted + stage: build image: "coqorg/coq" + before_script: + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam install -y menhir script: + - ./config_x86_64.sh - make check-admitted build_x86_64: -- cgit From 6bfbd278803e14ddd8c74ae582e76607cca69591 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 20:28:50 +0200 Subject: do not run check-admitted always --- .gitlab-ci.yml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ed3cb261..1f854fc3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -11,6 +11,14 @@ check-admitted: script: - ./config_x86_64.sh - make check-admitted + rules: + - if: '$CI_COMMIT_BRANCH == "mppa-work"' + when: always + - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + when: always + - if: '$CI_COMMIT_BRANCH == "master"' + when: always + - when: manual build_x86_64: stage: build -- cgit From c974b25682251da237dbbe8ef3af218c6d175ae2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 1 Apr 2020 10:34:57 +0200 Subject: Removing 8.8.* versions of coq in configure --- configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure b/configure index f13d1af3..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.8.0|8.8.1|8.8.2|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) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" -- cgit From 027c5f9b643c554bef742bf907e725f8ad949429 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 1 Apr 2020 10:35:16 +0200 Subject: Fix cutrewrite deprecated --- mppa_k1c/PostpassSchedulingproof.v | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 3b123c75..8cc7f0ab 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -61,9 +61,9 @@ Proof. - subst. repeat (rewrite Pregmap.gss); auto. destruct v; simpl; auto. rewrite Ptrofs.add_assoc. - cutrewrite (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)); auto. + enough (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)) as ->; auto. unfold Ptrofs.add. - cutrewrite (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)); auto. + enough (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)) as ->; auto. repeat (rewrite Ptrofs.unsigned_repr); auto. - repeat (rewrite Pregmap.gso; auto). Qed. @@ -220,7 +220,8 @@ Proof. destruct (zeq pos 0). + inv H. exists lbb. constructor; auto. + apply IHlbb in H. destruct H as (c & TAIL). exists c. - cutrewrite (pos = pos - size a + size a). apply code_tail_S; auto. + enough (pos = pos - size a + size a) as ->. + apply code_tail_S; auto. omega. Qed. -- cgit From 7ad6991534ba4ab10fe29d5456393f45cb4e5605 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 1 Apr 2020 10:35:42 +0200 Subject: -fduplicate -1 really desactivates the pass in Coq now --- driver/Compiler.v | 10 +++++----- driver/Compopts.v | 3 +-- extraction/extraction.v | 2 ++ 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/driver/Compiler.v b/driver/Compiler.v index da19a0b9..499feff2 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -134,7 +134,7 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 2) @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 3) - @@@ time "Tail-duplicating" Duplicate.transf_program + @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) @@ print (print_RTL 4) @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 5) @@ -254,7 +254,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog ::: mkpass Renumberproof.match_prog - ::: mkpass Duplicateproof.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_constprop Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) @@ -301,7 +301,7 @@ 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 (p9 := Renumber.transf_program p8) in *. - destruct (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; 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. @@ -326,7 +326,7 @@ Proof. 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 p10; split. apply Duplicateproof.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. 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. @@ -412,7 +412,7 @@ Ltac DestructM := eapply Inliningproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. eapply compose_forward_simulations. - eapply Duplicateproof.transf_program_correct; eassumption. + 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. diff --git a/driver/Compopts.v b/driver/Compopts.v index b4b9f30d..848657e5 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -27,8 +27,7 @@ Parameter generate_float_constants: unit -> bool. (** For value analysis. Currently always false. *) Parameter va_strict: unit -> bool. -(** Flag -fduplicate. For tail duplication optimization. Necessary to have - * bigger superblocks *) +(** Flag -fduplicate. Branch prediction annotation + tail duplication *) Parameter optim_duplicate: unit -> bool. (** Flag -ftailcalls. For tail call optimization. *) diff --git a/extraction/extraction.v b/extraction/extraction.v index ba6b080b..9b568951 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -105,6 +105,8 @@ Extract Constant Compopts.generate_float_constants => "fun _ -> !Clflags.option_ffloatconstprop >= 2". Extract Constant Compopts.optim_tailcalls => "fun _ -> !Clflags.option_ftailcalls". +Extract Constant Compopts.optim_duplicate => + "fun _ -> (if !Clflags.option_fduplicate = -1 then false else true)". Extract Constant Compopts.optim_constprop => "fun _ -> !Clflags.option_fconstprop". Extract Constant Compopts.optim_CSE => -- cgit From c34e25a208e092aff0b7dfa931b199df0ce3bc52 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 1 Apr 2020 11:53:55 +0200 Subject: Fixing packedstruct issue --- test/regression/Makefile | 6 +++--- test/regression/packedstruct1.c | 24 ++++++++++++------------ 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/test/regression/Makefile b/test/regression/Makefile index ad3ffd99..97c25f6c 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -26,10 +26,10 @@ TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ varargs1 varargs2 varargs3 sections alias aligned\ packedstruct1 packedstruct2 -# FIXME ifeq ($(ARCH),mppa_k1c) +ifeq ($(ARCH),mppa_k1c) TESTS_COMP:=$(filter-out packedstruct1,$(TESTS_COMP)) TESTS_COMP:=$(filter-out packedstruct2,$(TESTS_COMP)) -# endif +endif # Can run, both in compiled mode and in interpreter mode, # but produce processor-dependent results, so no reference output in Results @@ -37,7 +37,7 @@ TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ TESTS_DIFF=NaNs # FIXME ifeq ($(ARCH),mppa_k1c) TESTS_DIFF:=$(filter-out NaNs,$(TESTS_DIFF)) -# endif endif +# endif # Other tests: should compile to .s without errors (but expect warnings) diff --git a/test/regression/packedstruct1.c b/test/regression/packedstruct1.c index ac68c698..b805c92a 100644 --- a/test/regression/packedstruct1.c +++ b/test/regression/packedstruct1.c @@ -23,9 +23,9 @@ void test1(void) struct s1 s1; printf("sizeof(struct s1) = %d\n", szof(s1)); printf("precomputed sizeof(struct s1) = %d\n", bszof(s1)); - printf("offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", offsetOf(s1,x), offsetOf(s1,y), offsetOf(s1,z)); - printf("precomputed offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", boffsetof(s1,x), boffsetof(s1,y), boffsetof(s1,z)); s1.x = 123; s1.y = -456; s1.z = 3.14159; printf("s1 = {x = %d, y = %d, z = %.5f}\n\n", s1.x, s1.y, s1.z); @@ -44,9 +44,9 @@ void test2(void) printf("sizeof(struct s2) = %d\n", szof(s2)); printf("precomputed sizeof(struct s2) = %d\n", bszof(s2)); printf("&s2 mod 16 = %d\n", ((int) &s2) & 0xF); - printf("offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", offsetOf(s2,x), offsetOf(s2,y), offsetOf(s2,z)); - printf("precomputed offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", boffsetof(s2,x), boffsetof(s2,y), boffsetof(s2,z)); s2.x = 12345; s2.y = -456; s2.z = 3.14159; printf("s2 = {x = %d, y = %d, z = %.5f}\n\n", s2.x, s2.y, s2.z); @@ -73,8 +73,8 @@ void test3(void) printf("sizeof(struct s3) = %d\n", szof(s3)); printf("precomputed sizeof(struct s3) = %d\n", bszof(s3)); - printf("offsetOf(s) = %d\n", offsetOf(s3,s)); - printf("precomputed offsetOf(s) = %d\n", boffsetof(s3,s)); + printf("offsetof(s) = %d\n", offsetOf(s3,s)); + printf("precomputed offsetof(s) = %d\n", boffsetof(s3,s)); s3.x = 123; s3.y = 45678; s3.z = 0x80000001U; @@ -103,9 +103,9 @@ void test4(void) printf("sizeof(struct s4) = %d\n", szof(s4)); printf("precomputed sizeof(struct s4) = %d\n", bszof(s4)); - printf("offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", offsetOf(s4,x), offsetOf(s4,y), offsetOf(s4,z)); - printf("precomputed offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", boffsetof(s4,x), boffsetof(s4,y), boffsetof(s4,z)); s4.x = 123; s4.y = -456; s4.z = 3.14159; printf("s4 = {x = %d, y = %d, z = %.5f}\n\n", s4.x, s4.y, s4.z); @@ -121,9 +121,9 @@ void test5(void) printf("sizeof(struct s5) = %d\n", szof(s5)); printf("precomputed sizeof(struct s5) = %d\n", bszof(s5)); - printf("offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", offsetOf(s5,x), offsetOf(s5,y), offsetOf(s5,z)); - printf("precomputed offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", boffsetof(s5,x), boffsetof(s5,y), boffsetof(s5,z)); s5.x = 123; s5.y = -456; s5.z = 3.14159; printf("s5 = {x = %d, y = %d, z = %.5f}\n\n", s5.x, s5.y, s5.z); @@ -139,9 +139,9 @@ void test6(void) printf("sizeof(struct s6) = %d\n", szof(s6)); printf("precomputed sizeof(struct s6) = %d\n", bszof(s6)); - printf("offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", offsetOf(s6,x), offsetOf(s6,y), offsetOf(s6,z)); - printf("precomputed offsetOf(x) = %d, offsetOf(y) = %d, offsetOf(z) = %d\n", + printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n", boffsetof(s6,x), boffsetof(s6,y), boffsetof(s6,z)); s62.x = 123; s62.y = -456; s62.z = 3.14159; printf("s62 = {x = %d, y = %d, z = %.5f}\n\n", s62.x, s62.y, s62.z); -- cgit From 6e7c693e6cfe683b7a44c4f2a3420678fcdcc36f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 1 Apr 2020 14:24:52 +0200 Subject: Stopping traces at join points --- backend/Linearizeaux.ml | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 605a5db5..bfa056ca 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -150,8 +150,27 @@ let print_plist l = Printf.printf "]" end +(* adapted from the above join_points function, but with PTree *) +let get_join_points code entry = + let reached = ref (PTree.map (fun n i -> false) code) in + let reached_twice = ref (PTree.map (fun n i -> false) code) in + let rec traverse pc = + if get_some @@ PTree.get pc !reached then begin + if not (get_some @@ PTree.get pc !reached_twice) then + reached_twice := PTree.set pc true !reached_twice + end else begin + reached := PTree.set pc true !reached; + traverse_succs (successors_block @@ get_some @@ PTree.get pc code) + end + and traverse_succs = function + | [] -> () + | [pc] -> traverse pc + | pc :: l -> traverse pc; traverse_succs l + in traverse entry; !reached_twice + let forward_sequences code entry = let visited = ref (PTree.map (fun n i -> false) code) in + 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); *) @@ -164,10 +183,14 @@ let forward_sequences code entry = | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ | Lbuiltin _ -> assert false | Ltailcall _ | Lreturn -> begin (* Printf.printf "STOP tailcall/return\n"; *) ([], []) end - | Lbranch n -> let ln, rem = traverse_fallthrough code n in (ln, rem) + | 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 - | Some false -> let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) + | 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) -- 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