Skip to content

GitLab

Commit 61171aef authored by Heiko Becker's avatar Heiko Becker
Browse files

Merge branch 'fma_proofs_merge' into 'certificates' 

Fma proofs merge

See merge request AVA/daisy!170
parents 13ae6d87 c14fe5f4
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 2427 additions and 1067 deletions
coq/ErrorBounds.v
View file @ 61171aef
......@@ -258,6 +258,75 @@ Proof.
apply Rabs_pos.
Qed.
Lemma fma_abs_err_bounded (e1:exp Q) (e1R:R) (e1F:R) (e2:exp Q) (e2R:R) (e2F:R)
(e3:exp Q) (e3R:R) (e3F:R)
(vR:R) (vF:R) (E1 E2:env) (m m1 m2 m3:mType) defVars:
eval_exp E1 (toRMap defVars) (toREval (toRExp e1)) e1R M0 ->
eval_exp E2 defVars (toRExp e1) e1F m1->
eval_exp E1 (toRMap defVars) (toREval (toRExp e2)) e2R M0 ->
eval_exp E2 defVars (toRExp e2) e2F m2 ->
eval_exp E1 (toRMap defVars) (toREval (toRExp e3)) e3R M0 ->
eval_exp E2 defVars (toRExp e3) e3F m3->
eval_exp E1 (toRMap defVars) (toREval (Fma (toRExp e1) (toRExp e2) (toRExp e3))) vR M0 ->
eval_exp (updEnv 3 e3F (updEnv 2 e2F (updEnv 1 e1F emptyEnv)))
(updDefVars 3 m3 (updDefVars 2 m2 (updDefVars 1 m1 defVars)))
(Fma (Var R 1) (Var R 2) (Var R 3)) vF m ->
(Rabs (vR - vF) <= Rabs ((e1R - e1F) + (e2R * e3R - e2F * e3F)) + Rabs (e1F + e2F * e3F) * (Q2R (mTypeToQ m)))%R.
Proof.
intros e1_real e1_float e2_real e2_float e3_real e3_float fma_real fma_float.
inversion fma_real; subst;
assert (m0 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m4 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m5 = M0) by (eapply toRMap_eval_M0; eauto).
subst; simpl in H3; rewrite Q2R0_is_0 in H3; auto.
rewrite delta_0_deterministic in fma_real; auto.
rewrite delta_0_deterministic; auto.
unfold evalFma in *; simpl in *.
clear delta H3.
rewrite (meps_0_deterministic (toRExp e1) H5 e1_real);
rewrite (meps_0_deterministic (toRExp e2) H6 e2_real);
rewrite (meps_0_deterministic (toRExp e3) H7 e3_real).
rewrite (meps_0_deterministic (toRExp e1) H5 e1_real) in fma_real.
rewrite (meps_0_deterministic (toRExp e2) H6 e2_real) in fma_real.
rewrite (meps_0_deterministic (toRExp e3) H7 e3_real) in fma_real.
clear H5 H6 v1 v2 v3 H7 H2.
inversion fma_float; subst.
unfold evalFma in *.
unfold perturb; simpl.
inversion H3; subst; inversion H6; subst; inversion H7; subst.
unfold updEnv in *; simpl in *.
inversion H5; inversion H1; inversion H9; subst.
clear fma_float H7 fma_real e1_real e1_float e2_real e2_float e3_real e3_float H6 H1 H5 H9 H3 H0 H4 H8.
repeat rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
rewrite Rsub_eq_Ropp_Rplus.
rewrite Ropp_plus_distr.
rewrite <- Rplus_assoc.
setoid_rewrite <- Rsub_eq_Ropp_Rplus at 2.
rewrite Rsub_eq_Ropp_Rplus.
rewrite Rsub_eq_Ropp_Rplus.
rewrite Rsub_eq_Ropp_Rplus.
rewrite <- Rplus_assoc.
setoid_rewrite Rplus_comm at 8.
rewrite <- Rplus_assoc.
setoid_rewrite Rplus_comm at 9.
rewrite Rplus_assoc.
setoid_rewrite Rplus_assoc at 2.
rewrite <- Rplus_assoc.
rewrite <- Rsub_eq_Ropp_Rplus.
rewrite <- Rsub_eq_Ropp_Rplus.
rewrite <- Ropp_plus_distr.
rewrite <- Rsub_eq_Ropp_Rplus.
eapply Rle_trans.
eapply Rabs_triang.
eapply Rplus_le_compat_l.
rewrite Rabs_Ropp.
repeat rewrite Rabs_mult.
eapply Rmult_le_compat_l; auto.
apply Rabs_pos.
Qed.
Lemma err_prop_inversion_pos_real nF nR err elo ehi
(float_iv_pos : (0 < elo - err)%R)
(real_iv_pos : (0 < elo)%R)
......
coq/ErrorValidation.v
View file @ 61171aef
This diff is collapsed.
coq/Expressions.v
View file @ 61171aef
......@@ -98,6 +98,9 @@ Definition evalUnop (o:unop) (v:R):=
|Inv => (/ v)%R
end .
Definition evalFma (v1:R) (v2:R) (v3:R):=
evalBinop Plus v1 (evalBinop Mult v2 v3).
(**
Define expressions parametric over some value type V.
Will ease reasoning about different instantiations later.
......@@ -107,6 +110,7 @@ Inductive exp (V:Type): Type :=
| Const: mType -> V -> exp V
| Unop: unop -> exp V -> exp V
| Binop: binop -> exp V -> exp V -> exp V
| Fma: exp V -> exp V -> exp V -> exp V
| Downcast: mType -> exp V -> exp V.
(**
......@@ -122,6 +126,8 @@ Fixpoint expEq (e1:exp Q) (e2:exp Q) :=
(unopEq o1 o2) && (expEq e11 e22)
| Binop o1 e11 e12, Binop o2 e21 e22 =>
(binopEq o1 o2) && (expEq e11 e21) && (expEq e12 e22)
| Fma e11 e12 e13, Fma e21 e22 e23 =>
(expEq e11 e21) && (expEq e12 e22) && (expEq e13 e23)
| Downcast m1 f1, Downcast m2 f2 =>
(mTypeEq m1 m2) && (expEq f1 f2)
| _, _ => false
......@@ -136,6 +142,7 @@ Proof.
- apply Qeq_bool_iff; lra.
- case u; auto.
- case b; auto.
- firstorder.
- apply mTypeEq_refl.
Qed.
......@@ -156,6 +163,9 @@ Proof.
* destruct b; auto.
* apply IHe1.
+ apply IHe2.
- f_equal.
+ f_equal; auto.
+ auto.
- f_equal.
+ apply mTypeEq_sym; auto.
+ apply IHe.
......@@ -180,6 +190,9 @@ Proof.
rewrite binopEq_refl; simpl.
apply andb_true_iff.
split; [eapply IHe1; eauto | eapply IHe2; eauto].
- rewrite andb_true_iff.
rewrite andb_true_iff.
split; [split; [eapply IHe1; eauto | eapply IHe2; eauto] | eapply IHe3; eauto].
- rewrite mTypeEq_refl; simpl.
eapply IHe; eauto.
Qed.
......@@ -206,6 +219,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
if unopEq u1 u2
then expCompare e1 e2
else (if unopEq u1 Neg then Lt else Gt)
| Unop _ _, Fma _ _ _ => Lt
| Unop _ _, Binop _ _ _ => Lt
| Unop _ _, Downcast _ _ => Lt
| Unop _ _, _ => Gt
......@@ -213,6 +227,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
if mTypeEq m1 m2
then expCompare e1 e2
else (if morePrecise m1 m2 then Lt else Gt)
| Downcast _ _, Fma _ _ _ => Lt
| Downcast _ _, Binop _ _ _ => Lt
| Downcast _ _, _ => Gt
| Binop b1 e11 e12, Binop b2 e21 e22 =>
......@@ -238,7 +253,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
end
| _ => res
end
|_ , _ => Gt
| Binop _ _ _, Fma _ _ _ => Lt
| Binop _ _ _, _ => Gt
| Fma e11 e12 e13, Fma e21 e22 e23 =>
match expCompare e11 e21 with
| Eq => match expCompare e12 e22 with
| Eq => expCompare e13 e23
| Lt => Lt
| Gt => Gt
end
| Lt => Lt
| Gt => Gt
end
| Fma _ _ _ , _ => Gt
end.
Lemma expCompare_refl e: expCompare e e = Eq.
......@@ -248,6 +275,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
- rewrite mTypeEq_refl. apply V_orderedFacts.compare_refl.
- rewrite unopEq_refl; auto.
- rewrite IHe1, IHe2. destruct b; auto.
- now rewrite IHe1, IHe2, IHe3.
- rewrite mTypeEq_refl; auto.
Qed.
......@@ -295,6 +323,11 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?;
try congruence; try erewrite IHe1_1; eauto.
- destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?;
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e2_2 e3_2) eqn:?;
try congruence; try erewrite IHe1_1, IHe1_2; eauto.
- destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?;
type_conv;
......@@ -334,6 +367,13 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
rewrite IHe1_1 in *; simpl in *;
rewrite CompOpp_iff in first_comp;
rewrite first_comp; simpl; try auto.
-
destruct (expCompare e1_1 e2_1) eqn:first_comp;
destruct (expCompare e1_2 e2_2) eqn:second_comp;
rewrite IHe1_1, IHe1_2 in *; simpl in *;
rewrite CompOpp_iff in first_comp;
rewrite CompOpp_iff in second_comp;
rewrite first_comp, second_comp; simpl; try auto.
- rewrite mTypeEq_sym.
destruct (mTypeEq m0 m) eqn:?;
type_conv; try auto.
......@@ -345,6 +385,12 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
* destruct m, m0; unfold morePrecise in *; cbv; congruence.
Qed.
Lemma expCompare_eq_sym e1 e2:
expCompare e1 e2 = Eq <-> expCompare e2 e1 = Eq.
Proof.
now split; intros H; rewrite expCompare_antisym; rewrite H.
Qed.
Lemma expCompare_lt_eq_is_lt e1:
forall e2 e3,
expCompare e1 e2 = Lt -> expCompare e2 e3 = Eq -> expCompare e1 e3 = Lt.
......@@ -377,6 +423,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try congruence;
try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
- destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?;
try congruence;
try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e2_2 e3_2) eqn:?;
try congruence;
try (erewrite IHe1_2; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
- destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?.
+ type_conv; subst. rewrite mTypeEq_refl. eapply IHe1; eauto.
......@@ -417,6 +473,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try congruence;
try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
- destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e2_1 e3_1) eqn:?;
try congruence;
try (erewrite IHe1_1; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e2_2 e3_2) eqn:?;
try congruence;
try (erewrite IHe1_2; eauto; fail "");
try erewrite expCompare_eq_trans; eauto.
- destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?.
+ type_conv; subst. rewrite mTypeEq_refl. eapply IHe1; eauto.
......@@ -449,6 +515,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
apply IHx; auto.
+ destruct b;
destruct (expCompare x1 x1) eqn:?; try congruence.
+ destruct (expCompare x1 x1) eqn:?; destruct (expCompare x2 x2) eqn:?; try congruence.
+ rewrite mTypeEq_refl in lt_x.
apply IHx; auto.
- unfold Transitive.
......@@ -502,6 +569,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try (erewrite expCompare_eq_lt_is_lt; eauto; fail);
try (erewrite expCompare_lt_eq_is_lt; eauto; fail);
try (erewrite IHe1_1; eauto).
+ destruct (expCompare e1_1 y1) eqn:?; try congruence;
destruct (expCompare y1 z1) eqn:?; try congruence;
try (erewrite expCompare_eq_lt_is_lt; eauto; fail);
try (erewrite expCompare_lt_eq_is_lt; eauto; fail);
try (erewrite IHe1_1; eauto; fail).
apply (expCompare_eq_trans _ _ _ Heqc) in Heqc0;
rewrite Heqc0.
destruct (expCompare e1_2 y2) eqn:?; try congruence;
destruct (expCompare y2 z2) eqn:?; try congruence;
try (erewrite expCompare_eq_trans; eauto; fail);
try (erewrite expCompare_eq_lt_is_lt; eauto; fail);
try (erewrite expCompare_lt_eq_is_lt; eauto; fail);
try (erewrite IHe1_2; eauto).
+ destruct (mTypeEq m m0) eqn:?;
destruct (mTypeEq m0 m1) eqn:?;
[type_conv; subst; rewrite mTypeEq_refl | | | ].
......@@ -558,6 +638,32 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try (split; try congruence; intros);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite IHe1_1 in *; congruence);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence).
- try (split; auto; fail);
destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e3_1 e4_1) eqn:?;
try congruence;
destruct (expCompare e1_1 e3_1) eqn:?;
destruct (expCompare e2_1 e4_1) eqn:?;
try (split; congruence);
try (specialize (IHe1_2 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *; rewrite IHe1_2 in *; split; auto; fail);
try (split; try congruence; intros);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite IHe1_1 in *; congruence);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence);
try (split; auto; fail);
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e3_2 e4_2) eqn:?;
try congruence;
destruct (expCompare e1_2 e3_2) eqn:?;
destruct (expCompare e2_2 e4_2) eqn:?;
try (split; congruence);
try (split; try congruence; intros);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite IHe1_2 in *; congruence);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite <- IHe1_2 in *; congruence);
try congruence;
erewrite expCompare_eq_trans; eauto;
erewrite expCompare_eq_trans; eauto;
rewrite expCompare_antisym;
now (try rewrite e3_eq_e4; try rewrite e1_eq_e2).
- destruct (mTypeEq m m0) eqn:?; destruct (mTypeEq m1 m2) eqn:?;
[type_conv | | |].
+ specialize (IHe1 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *.
......@@ -606,6 +712,38 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence);
try (rewrite (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence);
try (rewrite <- (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence).
- pose proof eq_compat as eq_comp. unfold Proper, eq in eq_comp.
destruct (expCompare e1_1 e2_1) eqn:?;
destruct (expCompare e3_1 e4_1) eqn:?;
try congruence;
destruct (expCompare e1_1 e3_1) eqn:?;
destruct (expCompare e2_1 e4_1) eqn:?;
try (split; congruence);
try (specialize (IHe1_2 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *; rewrite IHe1_2 in *; split; auto; fail);
try (split; try congruence; intros);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite IHe1_1 in *; congruence);
try (specialize (IHe1_1 _ Heqc _ _ Heqc0); simpl in *; rewrite <- IHe1_1 in *; congruence);
try (rewrite (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence);
try (rewrite <- (eq_comp _ _ Heqc _ _ Heqc0) in *; congruence);
destruct (expCompare e1_2 e2_2) eqn:?;
destruct (expCompare e3_2 e4_2) eqn:?;
try congruence;
destruct (expCompare e1_2 e3_2) eqn:?;
destruct (expCompare e2_2 e4_2) eqn:?;
try (split; congruence);
try (specialize (IHe1_3 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *; rewrite IHe1_3 in *; split; auto; fail);
try (split; try congruence; intros);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite IHe1_2 in *; congruence);
try (specialize (IHe1_2 _ Heqc3 _ _ Heqc4); simpl in *; rewrite <- IHe1_2 in *; congruence);
try (rewrite (eq_comp _ _ Heqc3 _ _ Heqc4) in *; congruence);
try (rewrite <- (eq_comp _ _ Heqc3 _ _ Heqc4) in *; congruence);
try congruence.
+ apply (expCompare_lt_eq_is_lt _ _ _ H) in e3_eq_e4;
rewrite expCompare_eq_sym in e1_eq_e2;
now apply (expCompare_eq_lt_is_lt _ _ _ e1_eq_e2).
+ rewrite expCompare_eq_sym in e3_eq_e4;
apply (expCompare_lt_eq_is_lt _ _ _ H) in e3_eq_e4;
now apply (expCompare_eq_lt_is_lt _ _ _ e1_eq_e2).
- destruct (mTypeEq m m0) eqn:?; destruct (mTypeEq m1 m2) eqn:?;
[type_conv | | |].
+ specialize (IHe1 _ e1_eq_e2 _ _ e3_eq_e4); simpl in *.
......@@ -614,7 +752,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
+ destruct (morePrecise m1 m2); congruence.
+ destruct (morePrecise m m0); congruence.
+ destruct (morePrecise m m0); congruence.
Defined.
Qed.
Lemma compare_spec : forall x y, CompSpec eq lt x y (expCompare x y).
Proof.
......@@ -685,11 +823,12 @@ End ExpOrderedType.
Fixpoint toRExp (e:exp Q) :=
match e with
|Var _ v => Var R v
|Const m n => Const m (Q2R n)
|Unop o e1 => Unop o (toRExp e1)
|Binop o e1 e2 => Binop o (toRExp e1) (toRExp e2)
|Downcast m e1 => Downcast m (toRExp e1)
| Var _ v => Var R v
| Const m n => Const m (Q2R n)
| Unop o e1 => Unop o (toRExp e1)
| Binop o e1 e2 => Binop o (toRExp e1) (toRExp e2)
| Fma e1 e2 e3 => Fma (toRExp e1) (toRExp e2) (toRExp e3)
| Downcast m e1 => Downcast m (toRExp e1)
end.
Fixpoint toREval (e:exp R) :=
......@@ -698,6 +837,7 @@ Fixpoint toREval (e:exp R) :=
| Const _ n => Const M0 n
| Unop o e1 => Unop o (toREval e1)
| Binop o e1 e2 => Binop o (toREval e1) (toREval e2)
| Fma e1 e2 e3 => Fma (toREval e1) (toREval e2) (toREval e3)
| Downcast _ e1 => Downcast M0 (toREval e1)
end.
......@@ -750,7 +890,15 @@ Inductive eval_exp (E:env) (Gamma: nat -> option mType) :(exp R) -> R -> mType -
eval_exp E Gamma f1 v1 m1 ->
eval_exp E Gamma f2 v2 m2 ->
((op = Div) -> (~ v2 = 0)%R) ->
eval_exp E Gamma (Binop op f1 f2) (perturb (evalBinop op v1 v2) delta) (join m1 m2).
eval_exp E Gamma (Binop op f1 f2) (perturb (evalBinop op v1 v2) delta) (join m1 m2)
| Fma_dist m1 m2 m3 f1 f2 f3 v1 v2 v3 delta:
Rle (Rabs delta) (Q2R (mTypeToQ (join3 m1 m2 m3))) ->
eval_exp E Gamma f1 v1 m1 ->
eval_exp E Gamma f2 v2 m2 ->
eval_exp E Gamma f3 v3 m3 ->
eval_exp E Gamma (Fma f1 f2 f3)
(perturb (evalFma v1 v2 v3) delta)
(join3 m1 m2 m3).
Hint Constructors eval_exp.
......@@ -819,6 +967,20 @@ Qed.
Hint Resolve Binop_dist'.
Lemma Fma_dist' m1 m2 m3 f1 f2 f3 v1 v2 v3 delta v m' E Gamma:
Rle (Rabs delta) (Q2R (mTypeToQ m')) ->
eval_exp E Gamma f1 v1 m1 ->
eval_exp E Gamma f2 v2 m2 ->
eval_exp E Gamma f3 v3 m3 ->
v = perturb (evalFma v1 v2 v3) delta ->
m' = join3 m1 m2 m3 ->
eval_exp E Gamma (Fma f1 f2 f3) v m'.
Proof.
intros; subst; auto.
Qed.
Hint Resolve Fma_dist'.
(**
Define the set of "used" variables of an expression to be the set of variables
occuring in it
......@@ -828,6 +990,7 @@ Fixpoint usedVars (V:Type) (e:exp V) :NatSet.t :=
| Var _ x => NatSet.singleton x
| Unop u e1 => usedVars e1
| Binop b e1 e2 => NatSet.union (usedVars e1) (usedVars e2)
| Fma e1 e2 e3 => NatSet.union (usedVars e1) (NatSet.union (usedVars e2) (usedVars e3))
| Downcast _ e1 => usedVars e1
| _ => NatSet.empty
end.
......@@ -851,6 +1014,13 @@ Proof.
assert (m2 = M0)
by (eapply IHf2; eauto);
subst; auto.
- assert (m1 = M0)
by (eapply IHf1; eauto).
assert (m2 = M0)
by (eapply IHf2; eauto).
assert (m3 = M0)
by (eapply IHf3; eauto);
subst; auto.
Qed.
(**
......@@ -899,6 +1069,20 @@ Proof.
simpl in *.
rewrite Q2R0_is_0 in *.
repeat (rewrite delta_0_deterministic; try auto).
- inversion ev1; inversion ev2; subst.
assert (m0 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m1 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m2 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m3 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m4 = M0) by (eapply toRMap_eval_M0; eauto).
assert (m5 = M0) by (eapply toRMap_eval_M0; eauto).
subst.
rewrite (IHf1 v0 v5); try auto.
rewrite (IHf2 v3 v6); try auto.
rewrite (IHf3 v4 v7); try auto.
simpl in *.
rewrite Q2R0_is_0 in *.
repeat (rewrite delta_0_deterministic; try auto).
- inversion ev1; inversion ev2; subst.
apply M0_least_precision in H1;
apply M0_least_precision in H7; subst.
......@@ -909,7 +1093,7 @@ Proof.
Qed.
(**
Helping lemma. Needed in soundness proof.
Helping lemmas. Needed in soundness proof.
For each evaluation of using an arbitrary epsilon, we can replace it by
evaluating the subexpressions and then binding the result values to different
variables in the Environment.
......@@ -928,6 +1112,19 @@ Proof.
econstructor; try auto.
Qed.
Lemma fma_unfolding f1 f2 f3 E v1 v2 v3 m1 m2 m3 Gamma delta:
(Rabs delta <= Q2R (mTypeToQ (join3 m1 m2 m3)))%R ->
eval_exp E Gamma f1 v1 m1 ->
eval_exp E Gamma f2 v2 m2 ->
eval_exp E Gamma f3 v3 m3 ->
eval_exp E Gamma (Fma f1 f2 f3) (perturb (evalFma v1 v2 v3) delta) (join3 m1 m2 m3) ->
eval_exp (updEnv 3 v3 (updEnv 2 v2 (updEnv 1 v1 emptyEnv)))
(updDefVars 3 m3 (updDefVars 2 m2 (updDefVars 1 m1 Gamma)))
(Fma (Var R 1) (Var R 2) (Var R 3)) (perturb (evalFma v1 v2 v3) delta) (join3 m1 m2 m3).
Proof.
econstructor; try auto.
Qed.
Lemma eval_eq_env e:
forall E1 E2 Gamma v m,
(forall x, E1 x = E2 x) ->
......@@ -989,4 +1186,4 @@ Qed. *)
(* Simplify arithmetic later by making > >= only abbreviations *)
(* **) *)
(* Definition gr := fun (V:Type) (f1: exp V) (f2: exp V) => less f2 f1. *)
(* Definition greq := fun (V:Type) (f1:exp V) (f2: exp V) => leq f2 f1. *)
\ No newline at end of file
(* Definition greq := fun (V:Type) (f1:exp V) (f2: exp V) => leq f2 f1. *)
coq/FPRangeValidator.v
View file @ 61171aef
......@@ -14,6 +14,10 @@ Fixpoint FPRangeValidator (e:exp Q) (A:analysisResult) typeMap dVars {struct e}
| Binop b e1 e2 =>
FPRangeValidator e1 A typeMap dVars &&
FPRangeValidator e2 A typeMap dVars
| Fma e1 e2 e3 =>
FPRangeValidator e1 A typeMap dVars &&
FPRangeValidator e2 A typeMap dVars &&
FPRangeValidator e3 A typeMap dVars
| Unop u e =>
FPRangeValidator e A typeMap dVars
| Downcast m e => FPRangeValidator e A typeMap dVars
......@@ -123,6 +127,9 @@ Proof.
- Daisy_compute; try congruence.
type_conv; subst.
prove_fprangeval (join m0 m1) v L1 R.
- Daisy_compute; try congruence.
type_conv; subst.
prove_fprangeval (join3 m0 m1 m2) v L1 R.
- Daisy_compute; try congruence.
type_conv; subst.
prove_fprangeval m v L1 R.
......@@ -238,4 +245,4 @@ Proof.
rewrite NatSet.add_spec in H4; destruct H4;
auto; subst; congruence. }
- eapply FPRangeValidator_sound; eauto.
Qed.
\ No newline at end of file
Qed.
coq/IEEE_connection.v
View file @ 61171aef
......@@ -45,6 +45,11 @@ Fixpoint eval_exp_float (e:exp (binary_float 53 1024)) (E:nat -> option fl64):=
end
|_ , _ => None
end
| Fma e1 e2 e3 =>
match eval_exp_float e1 E, eval_exp_float e2 E, eval_exp_float e3 E with
(* | Some f1, Some f2, Some f3 => Some (b64_plus dmode f1 (b64_mult dmode f2 f3)) *)
| _, _, _ => None
end
| _ => None
end.
......@@ -78,6 +83,26 @@ Fixpoint eval_exp_valid (e:exp fl64) E :=
normal_or_zero (evalBinop b v1_real v2_real))
True)
True)
| Fma e1 e2 e3 =>
(eval_exp_valid e1 E) /\ (eval_exp_valid e2 E) /\ (eval_exp_valid e3 E) /\
(let e1_res := eval_exp_float e1 E in
let e2_res := eval_exp_float e2 E in
let e3_res := eval_exp_float e3 E in
optionLift e1_res
(fun v1 =>
let v1_real := B2R 53 1024 v1 in
optionLift e2_res
(fun v2 =>
let v2_real := B2R 53 1024 v2 in
optionLift e3_res
(fun v3 =>
let v3_real := B2R 53 1024 v3 in
(* No support for fma yet *)
(* normal_or_zero (evalFma v1_real v2_real v3_real)) *)
False)
True)
True)
True)
| Downcast m e => eval_exp_valid e E
end.
......@@ -153,6 +178,7 @@ Fixpoint B2Qexp (e: exp fl64) :=
| Const m v => Const m (B2Q v)
| Unop u e => Unop u (B2Qexp e)
| Binop b e1 e2 => Binop b (B2Qexp e1) (B2Qexp e2)
| Fma e1 e2 e3 => Fma (B2Qexp e1) (B2Qexp e2) (B2Qexp e3)
| Downcast m e => Downcast m (B2Qexp e)
end.
......@@ -174,6 +200,7 @@ Fixpoint is64BitEval (V:Type) (e:exp V) :=
| Const m e => m = M64
| Unop u e => is64BitEval e
| Binop b e1 e2 => is64BitEval e1 /\ is64BitEval e2
| Fma e1 e2 e3 => is64BitEval e1 /\ is64BitEval e2 /\ is64BitEval e3
| Downcast m e => m = M64 /\ is64BitEval e
end.
......@@ -189,6 +216,7 @@ Fixpoint noDowncast (V:Type) (e:exp V) :=
| Const m e => True
| Unop u e => noDowncast e
| Binop b e1 e2 => noDowncast e1 /\ noDowncast e2
| Fma e1 e2 e3 => noDowncast e1 /\ noDowncast e2 /\ noDowncast e3
| Downcast m e => False
end.
......@@ -286,6 +314,17 @@ Proof.
* intros.
apply types_valid. set_tac.
+ intros; apply types_valid; set_tac.
- repeat (match goal with
|H: _ /\ _ |- _=> destruct H
end).
erewrite IHe1 in *; eauto; try (intros; apply types_valid; set_tac; fail).
erewrite IHe2 in *; eauto; try (intros; apply types_valid; set_tac; fail).
unfold join3, join in *.
erewrite IHe3 in *; eauto; try (intros; apply types_valid; set_tac; fail).
repeat destr_factorize.
repeat rewrite <- isMorePrecise_morePrecise.
repeat rewrite isMorePrecise_refl;
type_conv; subst; auto.
Qed.