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

Merge branch 'fma_proofs_merge' into 'certificates'

Fma proofs merge

See merge request AVA/daisy!170
parents 13ae6d87 c14fe5f4
...@@ -258,6 +258,75 @@ Proof. ...@@ -258,6 +258,75 @@ Proof.
apply Rabs_pos. apply Rabs_pos.
Qed. 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 Lemma err_prop_inversion_pos_real nF nR err elo ehi
(float_iv_pos : (0 < elo - err)%R) (float_iv_pos : (0 < elo - err)%R)
(real_iv_pos : (0 < elo)%R) (real_iv_pos : (0 < elo)%R)
......
This diff is collapsed.
This diff is collapsed.
...@@ -14,6 +14,10 @@ Fixpoint FPRangeValidator (e:exp Q) (A:analysisResult) typeMap dVars {struct e} ...@@ -14,6 +14,10 @@ Fixpoint FPRangeValidator (e:exp Q) (A:analysisResult) typeMap dVars {struct e}
| Binop b e1 e2 => | Binop b e1 e2 =>
FPRangeValidator e1 A typeMap dVars && FPRangeValidator e1 A typeMap dVars &&
FPRangeValidator e2 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 => | Unop u e =>
FPRangeValidator e A typeMap dVars FPRangeValidator e A typeMap dVars
| Downcast m e => FPRangeValidator e A typeMap dVars | Downcast m e => FPRangeValidator e A typeMap dVars
...@@ -123,6 +127,9 @@ Proof. ...@@ -123,6 +127,9 @@ Proof.
- Daisy_compute; try congruence. - Daisy_compute; try congruence.
type_conv; subst. type_conv; subst.
prove_fprangeval (join m0 m1) v L1 R. 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. - Daisy_compute; try congruence.
type_conv; subst. type_conv; subst.
prove_fprangeval m v L1 R. prove_fprangeval m v L1 R.
...@@ -238,4 +245,4 @@ Proof. ...@@ -238,4 +245,4 @@ Proof.
rewrite NatSet.add_spec in H4; destruct H4; rewrite NatSet.add_spec in H4; destruct H4;
auto; subst; congruence. } auto; subst; congruence. }
- eapply FPRangeValidator_sound; eauto. - eapply FPRangeValidator_sound; eauto.
Qed. Qed.
\ No newline at end of file
...@@ -45,6 +45,11 @@ Fixpoint eval_exp_float (e:exp (binary_float 53 1024)) (E:nat -> option fl64):= ...@@ -45,6 +45,11 @@ Fixpoint eval_exp_float (e:exp (binary_float 53 1024)) (E:nat -> option fl64):=
end end
|_ , _ => None |_ , _ => None
end 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 | _ => None
end. end.
...@@ -78,6 +83,26 @@ Fixpoint eval_exp_valid (e:exp fl64) E := ...@@ -78,6 +83,26 @@ Fixpoint eval_exp_valid (e:exp fl64) E :=
normal_or_zero (evalBinop b v1_real v2_real)) normal_or_zero (evalBinop b v1_real v2_real))
True) True)
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 | Downcast m e => eval_exp_valid e E
end. end.
...@@ -153,6 +178,7 @@ Fixpoint B2Qexp (e: exp fl64) := ...@@ -153,6 +178,7 @@ Fixpoint B2Qexp (e: exp fl64) :=
| Const m v => Const m (B2Q v) | Const m v => Const m (B2Q v)
| Unop u e => Unop u (B2Qexp e) | Unop u e => Unop u (B2Qexp e)
| Binop b e1 e2 => Binop b (B2Qexp e1) (B2Qexp e2) | 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) | Downcast m e => Downcast m (B2Qexp e)
end. end.
...@@ -174,6 +200,7 @@ Fixpoint is64BitEval (V:Type) (e:exp V) := ...@@ -174,6 +200,7 @@ Fixpoint is64BitEval (V:Type) (e:exp V) :=
| Const m e => m = M64 | Const m e => m = M64
| Unop u e => is64BitEval e | Unop u e => is64BitEval e
| Binop b e1 e2 => is64BitEval e1 /\ is64BitEval e2 | 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 | Downcast m e => m = M64 /\ is64BitEval e
end. end.
...@@ -189,6 +216,7 @@ Fixpoint noDowncast (V:Type) (e:exp V) := ...@@ -189,6 +216,7 @@ Fixpoint noDowncast (V:Type) (e:exp V) :=
| Const m e => True | Const m e => True
| Unop u e => noDowncast e | Unop u e => noDowncast e
| Binop b e1 e2 => noDowncast e1 /\ noDowncast e2 | Binop b e1 e2 => noDowncast e1 /\ noDowncast e2
| Fma e1 e2 e3 => noDowncast e1 /\ noDowncast e2 /\ noDowncast e3
| Downcast m e => False | Downcast m e => False
end. end.
...@@ -286,6 +314,17 @@ Proof. ...@@ -286,6 +314,17 @@ Proof.
* intros. * intros.
apply types_valid. set_tac. apply types_valid. set_tac.
+ 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. Qed.
Lemma typing_cmd_64_bit f: Lemma typing_cmd_64_bit f:
...@@ -326,10 +365,12 @@ Proof. ...@@ -326,10 +365,12 @@ Proof.
Daisy_compute; try congruence; type_conv; subst; try auto. Daisy_compute; try congruence; type_conv; subst; try auto.
- eapply IHe; eauto. - eapply IHe; eauto.
- eapply IHe; eauto. - eapply IHe; eauto.
- assert (m0 = m). - assert (m0 = m) by eauto using IHe1.
{ eapply IHe1; eauto. } assert (m3 = m1) by eauto using IHe2.
assert (m3 = m1). subst; auto.
{ eapply IHe2; eauto. } - assert (m0 = m) by eauto using IHe1.
assert (m3 = m1) by eauto using IHe2.
assert (m4 = m5) by eauto using IHe3.
subst; auto. subst; auto.
Qed. Qed.
...@@ -458,6 +499,7 @@ Lemma eval_exp_gives_IEEE (e:exp fl64) : ...@@ -458,6 +499,7 @@ Lemma eval_exp_gives_IEEE (e:exp fl64) :
exists v, exists v,
eval_exp_float e E2 = Some v /\ eval_exp_float e E2 = Some v /\
eval_exp (toREnv E2) Gamma (toRExp (B2Qexp e)) (Q2R (B2Q v)) M64. eval_exp (toREnv E2) Gamma (toRExp (B2Qexp e)) (Q2R (B2Q v)) M64.
Proof.
induction e; simpl in *; induction e; simpl in *;
intros * envs_eq typecheck_e approxEnv_E1_E2_real valid_rangebounds intros * envs_eq typecheck_e approxEnv_E1_E2_real valid_rangebounds
valid_roundoffs valid_float_ranges eval_e_float valid_roundoffs valid_float_ranges eval_e_float
...@@ -853,6 +895,51 @@ Lemma eval_exp_gives_IEEE (e:exp fl64) : ...@@ -853,6 +895,51 @@ Lemma eval_exp_gives_IEEE (e:exp fl64) :
repeat rewrite B2Q_B2R_eq; try auto. repeat rewrite B2Q_B2R_eq; try auto.
rewrite <- round_eq. rewrite <- div_round; auto. rewrite <- round_eq. rewrite <- div_round; auto.
- rewrite finite_e1 in finite_res; auto. } - rewrite finite_e1 in finite_res; auto. }
- repeat (match goal with
|H: _ /\ _ |- _ => destruct H
end).
assert (DaisyMap.find (B2Qexp e1) tMap = Some M64 /\
DaisyMap.find (B2Qexp e2) tMap = Some M64 /\
DaisyMap.find (B2Qexp e3) tMap = Some M64 /\
DaisyMap.find (Fma (B2Qexp e1) (B2Qexp e2) (B2Qexp e3)) tMap = Some M64)
as [tMap_e1 [tMap_e2 [tMap_e3 tMap_fma]]].
{ repeat split; apply (typing_exp_64_bit _ Gamma); simpl; auto.
- intros; apply usedVars_64bit; set_tac.
- intros; apply usedVars_64bit; set_tac.
- intros; apply usedVars_64bit; set_tac.
- rewrite Heqo, Heqo4, Heqo6, Heqo8.
apply Is_true_eq_true; apply andb_prop_intro; split.
+ apply andb_prop_intro; split.
* apply andb_prop_intro; split.
++ apply Is_true_eq_left; auto.
apply mTypeEq_refl.
++ apply Is_true_eq_left; auto.
* apply Is_true_eq_left; auto.
+ apply Is_true_eq_left; auto. }
repeat destr_factorize.
inversion Heqo; inversion Heqo0; inversion Heqo1; inversion Heqo2; subst.
assert (m1 = M64).
{ eapply (typing_agrees_exp (B2Qexp e1)); eauto. }
assert (m2 = M64).
{ eapply (typing_agrees_exp (B2Qexp e2)); eauto. }
assert (m3 = M64).
{ eapply (typing_agrees_exp (B2Qexp e3)); eauto. }
subst.
destruct (IHe1 E1 E2 E2_real Gamma tMap v1 A P fVars dVars)
as [v_e1 [eval_float_e1 eval_rel_e1]];
try auto; try set_tac;
[ intros; apply usedVars_64bit ; set_tac | ].
destruct (IHe2 E1 E2 E2_real Gamma tMap v2 A P fVars dVars)
as [v_e2 [eval_float_e2 eval_rel_e2]];
try auto; try set_tac;
[ intros; apply usedVars_64bit ; set_tac | ].
destruct (IHe3 E1 E2 E2_real Gamma tMap v3 A P fVars dVars)
as [v_e3 [eval_float_e3 eval_rel_e3]];
try auto; try set_tac;
[ intros; apply usedVars_64bit ; set_tac | ].
unfold optionLift in H4.
rewrite eval_float_e1, eval_float_e2, eval_float_e3 in H4.
contradiction H4.
- inversion noDowncast_e. - inversion noDowncast_e.
Qed. Qed.
...@@ -1224,4 +1311,4 @@ Proof. ...@@ -1224,4 +1311,4 @@ Proof.
+ destruct H7. + destruct H7.
exists x, err, vR, x0, M64. exists x, err, vR, x0, M64.
repeat split; auto. repeat split; auto.
Qed. Qed.
\ No newline at end of file
...@@ -78,7 +78,6 @@ Ltac match_factorize_asm := ...@@ -78,7 +78,6 @@ Ltac match_factorize_asm :=
=> destruct t eqn:?; cbn in H; try congruence => destruct t eqn:?; cbn in H; try congruence
end. end.
Ltac match_factorize := Ltac match_factorize :=
match_factorize_asm || match_factorize_asm ||
match goal with match goal with
......
...@@ -169,6 +169,9 @@ Qed. ...@@ -169,6 +169,9 @@ Qed.
Definition join (m1:mType) (m2:mType) := Definition join (m1:mType) (m2:mType) :=
if (morePrecise m1 m2) then m1 else m2. if (morePrecise m1 m2) then m1 else m2.
Definition join3 (m1:mType) (m2:mType) (m3:mType) :=
join m1 (join m2 m3).
(* Lemma M0_join_is_M0 m1 m2: *) (* Lemma M0_join_is_M0 m1 m2: *)
(* join m1 m2 = M0 -> m1 = M0 /\ m2 = M0. *) (* join m1 m2 = M0 -> m1 = M0 /\ m2 = M0. *)
(* Proof. *) (* Proof. *)
...@@ -238,4 +241,4 @@ Definition validValue (v:Q) (m:mType) := ...@@ -238,4 +241,4 @@ Definition validValue (v:Q) (m:mType) :=
match m with match m with
| M0 => true | M0 => true
| _ => Qle_bool (Qabs v) (maxValue m) | _ => Qle_bool (Qabs v) (maxValue m)
end. end.
\ No newline at end of file
...@@ -354,4 +354,4 @@ Proof. ...@@ -354,4 +354,4 @@ Proof.
assert (Rabs b = - b)%R as Rabs_neg_b by (apply Rabs_left; lra). assert (Rabs b = - b)%R as Rabs_neg_b by (apply Rabs_left; lra).
rewrite Rabs_neg_a, Rabs_neg_b. rewrite Rabs_neg_a, Rabs_neg_b.
rewrite Rmin_right; lra. rewrite Rmin_right; lra.
Qed. Qed.
\ No newline at end of file
...@@ -67,6 +67,18 @@ Fixpoint validIntervalbounds (e:exp Q) (A:analysisResult) (P:precond) (validVars ...@@ -67,6 +67,18 @@ Fixpoint validIntervalbounds (e:exp Q) (A:analysisResult) (P:precond) (validVars
| _, _ => false | _, _ => false
end end
else false else false
| Fma f1 f2 f3 =>
if ((validIntervalbounds f1 A P validVars) &&
(validIntervalbounds f2 A P validVars) &&
(validIntervalbounds f3 A P validVars))
then
match DaisyMap.find f1 A, DaisyMap.find f2 A, DaisyMap.find f3 A with
| Some (iv1, _), Some (iv2, _), Some (iv3, _) =>
let new_iv := addIntv iv1 (multIntv iv2 iv3) in
isSupersetIntv new_iv intv
| _, _, _ => false
end
else false
| Downcast _ f1 => | Downcast _ f1 =>
if (validIntervalbounds f1 A P validVars) if (validIntervalbounds f1 A P validVars)
then then
...@@ -118,6 +130,13 @@ Proof. ...@@ -118,6 +130,13 @@ Proof.
destruct H. destruct H.
+ apply IHf1; try auto; set_tac. + apply IHf1; try auto; set_tac.
+ apply IHf2; try auto; set_tac. + apply IHf2; try auto; set_tac.
- Daisy_compute; try congruence.
destruct H.
+ apply IHf1; try auto; set_tac.
+ set_tac.
destruct H.
* apply IHf2; try auto; set_tac.
* apply IHf3; try auto; set_tac.
- Daisy_compute; try congruence. - Daisy_compute; try congruence.
apply IHf; try auto; set_tac. apply IHf; try auto; set_tac.
Qed. Qed.
...@@ -345,6 +364,32 @@ Proof. ...@@ -345,6 +364,32 @@ Proof.
unfold perturb. unfold perturb.
lra. lra.
} }
- Daisy_compute; try congruence.
destruct IHf1 as [iv_f1 [err1 [vF1 [env1 [eval_f1 valid_f1]]]]]; try auto; set_tac.
destruct IHf2 as [iv_f2 [err2 [vF2 [env2 [eval_f2 valid_f2]]]]]; try auto; set_tac.
destruct IHf3 as [iv_f3 [err3 [vF3 [env3 [eval_f3 valid_f3]]]]]; try auto; set_tac.
assert (M0 = join3 M0 M0 M0) as M0_join by (cbv; auto);
rewrite M0_join.
kill_trivial_exists.
exists (perturb (evalFma vF1 vF2 vF3) 0); split; try auto.
inversion env1; inversion env2; inversion env3; subst.
split; [auto | ].
* econstructor; try congruence; apply Rabs_0_equiv.
* pose proof (interval_multiplication_valid (Q2R (fst iv_f2),Q2R (snd iv_f2)) (Q2R (fst iv_f3), Q2R (snd iv_f3))) as valid_mul.
specialize (valid_mul vF2 vF3 valid_f2 valid_f3).
remember (multInterval (Q2R (fst iv_f2), Q2R (snd iv_f2)) (Q2R (fst iv_f3), Q2R (snd iv_f3))) as iv_f23prod.
pose proof (interval_addition_valid (Q2R (fst iv_f1),Q2R (snd iv_f1)) (fst iv_f23prod, snd iv_f23prod)) as valid_add.
rewrite Heqiv_f23prod in valid_add, valid_mul.
unfold multIntv in valid_add.
canonize_hyps.
simpl in *.
repeat rewrite <- Q2R_mult in *;
repeat rewrite <- Q2R_min4, <- Q2R_max4 in *;
repeat rewrite <- Q2R_plus in *;
repeat rewrite <- Q2R_min4, <- Q2R_max4 in *.
specialize (valid_add vF1 (vF2 * vF3)%R valid_f1 valid_mul).
unfold evalFma, evalBinop, perturb.
lra.
- match_simpl. - match_simpl.
andb_to_prop valid_bounds. andb_to_prop valid_bounds.
match_simpl. match_simpl.
...@@ -495,4 +540,4 @@ Proof. ...@@ -495,4 +540,4 @@ Proof.
pose proof (validIntervalbounds_sound e (E:=E) (Gamma:=Gamma) valid_bounds_f dVars_sound usedVars_subset) as valid_iv_e. pose proof (validIntervalbounds_sound e (E:=E) (Gamma:=Gamma) valid_bounds_f dVars_sound usedVars_subset) as valid_iv_e.
destruct valid_iv_e as [?[?[? [? [? ?]]]]]; try auto. destruct valid_iv_e as [?[?[? [? [? ?]]]]]; try auto.
simpl in *. repeat eexists; repeat split; try eauto; [econstructor; eauto| | ]; lra. simpl in *. repeat eexists; repeat split; try eauto; [econstructor; eauto| | ]; lra.
Qed. Qed.
\ No newline at end of file
...@@ -24,7 +24,15 @@ Fixpoint typeExpression (V:Type) (Gamma:nat -> option mType) (e:exp V) : option ...@@ -24,7 +24,15 @@ Fixpoint typeExpression (V:Type) (Gamma:nat -> option mType) (e:exp V) : option
let tm2 := typeExpression Gamma e2 in let tm2 := typeExpression Gamma e2 in
match tm1, tm2 with match tm1, tm2 with
| Some m1, Some m2 => Some (join m1 m2) | Some m1, Some m2 => Some (join m1 m2)
| _, _=> None | _, _ => None
end
| Fma e1 e2 e3 =>
let tm1 := typeExpression Gamma e1 in
let tm2 := typeExpression Gamma e2 in
let tm3 := typeExpression Gamma e3 in
match tm1, tm2, tm3 with
| Some m1, Some m2, Some m3 => Some (join3 m1 m2 m3)
| _, _,_ => None
end end
| Downcast m e1 => | Downcast m e1 =>
let tm1 := typeExpression Gamma e1 in let tm1 := typeExpression Gamma e1 in
...@@ -47,6 +55,12 @@ Fixpoint typeMap (Gamma:nat -> option mType) (e:exp Q) (e': exp Q) : option mTyp ...@@ -47,6 +55,12 @@ Fixpoint typeMap (Gamma:nat -> option mType) (e:exp Q) (e': exp Q) : option mTyp
| None, Some m2 => Some m2 | None, Some m2 => Some m2
| None, None => None | None, None => None
end end
| Fma e1 e2 e3 => if expEq e e' then typeExpression Gamma e
else
match (typeMap Gamma e1 e'), (typeMap Gamma e2 e'), (typeMap Gamma e3 e') with
| Some m1, Some m2, Some m3 => Some (join3 m1 m2 m3)
| _, _, _ => None
end
| Downcast m e1 => if expEq e e' then typeExpression Gamma (Downcast m e1) else typeMap Gamma e1 e' | Downcast m e1 => if expEq e e' then typeExpression Gamma (Downcast m e1) else typeMap Gamma e1 e'
end. *) end. *)
...@@ -76,6 +90,17 @@ Fixpoint typeMap (Gamma:nat -> option mType) (e:exp Q) (tMap:DaisyMap.t mType) ...@@ -76,6 +90,17 @@ Fixpoint typeMap (Gamma:nat -> option mType) (e:exp Q) (tMap:DaisyMap.t mType)
|Some t1, Some t2 => DaisyMap.add e (join t1 t2) tMap2 |Some t1, Some t2 => DaisyMap.add e (join t1 t2) tMap2
| _, _ => DaisyMap.empty mType | _, _ => DaisyMap.empty mType
end end
| Fma e1 e2 e3 =>
let tMap1 := typeMap Gamma e1 tMap in
let tMap2 := typeMap Gamma e2 tMap1 in
let tMap3 := typeMap Gamma e3 tMap2 in
let m1 := DaisyMap.find e1 tMap3 in
let m2 := DaisyMap.find e2 tMap3 in
let m3 := DaisyMap.find e3 tMap3 in
match m1, m2, m3 with
|Some t1, Some t2, Some t3 => DaisyMap.add e (join3 t1 t2 t3) tMap3
| _, _, _ => DaisyMap.empty mType
end
| Downcast m e1 => | Downcast m e1 =>
let tMap_new := typeMap Gamma e1 tMap in let tMap_new := typeMap Gamma e1 tMap in
let m1 := DaisyMap.find e1 tMap in let m1 := DaisyMap.find e1 tMap in
...@@ -135,10 +160,18 @@ Fixpoint typeCheck (e:exp Q) (Gamma:nat -> option mType) ...@@ -135,10 +160,18 @@ Fixpoint typeCheck (e:exp Q) (Gamma:nat -> option mType)
| Binop b e1 e2 => match DaisyMap.find e tMap, DaisyMap.find e1 tMap, DaisyMap.find e2 tMap with | Binop b e1 e2 => match DaisyMap.find e tMap, DaisyMap.find e1 tMap, DaisyMap.find e2 tMap with
| Some m, Some m1, Some m2 => | Some m, Some m1, Some m2 =>
mTypeEq m (join m1 m2) mTypeEq m (join m1 m2)
&& typeCheck e1 Gamma tMap && typeCheck e1 Gamma tMap
&& typeCheck e2 Gamma tMap && typeCheck e2 Gamma tMap
| _, _, _ => false | _, _, _ => false
end end
| Fma e1 e2 e3 => match DaisyMap.find e tMap, DaisyMap.find e1 tMap, DaisyMap.find e2 tMap, DaisyMap.find e3 tMap with
| Some m, Some m1, Some m2, Some m3 =>
mTypeEq m (join3 m1 m2 m3)
&& typeCheck e1 Gamma tMap
&& typeCheck e2 Gamma tMap
&& typeCheck e3 Gamma tMap
| _, _, _, _ => false
end
| Downcast m e1 => match DaisyMap.find e tMap, DaisyMap.find e1 tMap with | Downcast m e1 => match DaisyMap.find e tMap, DaisyMap.find e1 tMap with
| Some m', Some m1 => mTypeEq m m' && isMorePrecise m1 m && typeCheck e1 Gamma tMap | Some m', Some m1 => mTypeEq m m' && isMorePrecise m1 m && typeCheck e1 Gamma tMap
| _, _ => false | _, _ => false
...@@ -254,6 +287,10 @@ Proof. ...@@ -254,6 +287,10 @@ Proof.
- erewrite IHe1 in *; eauto. - erewrite IHe1 in *; eauto.
erewrite IHe2 in *; eauto. erewrite IHe2 in *; eauto.
inversion Heqo0; subst; inversion Heqo1; subst; auto. inversion Heqo0; subst; inversion Heqo1; subst; auto.
- erewrite IHe1 in *; eauto.
erewrite IHe2 in *; eauto.
erewrite IHe3 in *; eauto.
inversion Heqo0; subst; inversion Heqo1; subst; inversion Heqo2; subst; auto.
Qed. Qed.
Theorem typingSoundnessCmd c Gamma E v m expTypes: Theorem typingSoundnessCmd c Gamma E v m expTypes:
...@@ -265,4 +302,4 @@ Proof. ...@@ -265,4 +302,4 @@ Proof.
Daisy_compute; try congruence; type_conv; subst; inversion bc; subst. Daisy_compute; try congruence; type_conv; subst; inversion bc; subst.
- eapply IHc; eauto. - eapply IHc; eauto.
- eapply typingSoundnessExp; eauto. - eapply typingSoundnessExp; eauto.
Qed. Qed.
\ No newline at end of file
...@@ -35,6 +35,10 @@ Proof. ...@@ -35,6 +35,10 @@ Proof.
hnf; intros. hnf; intros.
apply in_vars. apply in_vars.
rewrite NatSet.union_spec; auto. rewrite NatSet.union_spec; auto.
- intros vars_fma.
simpl in *.
intros a used_vars.
firstorder.
Qed. Qed.
(* (*
...@@ -588,4 +592,4 @@ Fixpoint exp_subst (e:exp Q) x e_new := ...@@ -588,4 +592,4 @@ Fixpoint exp_subst (e:exp Q) x e_new :=
(* induction ssa_f; *) (* induction ssa_f; *)
(* intros VarEnv ParamEnv P eps fVars_live. *) (* intros VarEnv ParamEnv P eps fVars_live. *)
(* - *) (* - *)
(* *) *) (* *) *)
\ No newline at end of file
...@@ -201,6 +201,52 @@ val div_abs_err_bounded = store_thm ("div_abs_err_bounded", ...@@ -201,6 +201,52 @@ val div_abs_err_bounded = store_thm ("div_abs_err_bounded",
\\ once_rewrite_tac[REAL_ABS_MUL] \\ once_rewrite_tac[REAL_ABS_MUL]
\\ match_mp_tac REAL_LE_MUL2 \\ fs[REAL_ABS_POS])); \\ match_mp_tac REAL_LE_MUL2 \\ fs[REAL_ABS_POS]));
val fma_abs_err_bounded = store_thm ("fma_abs_err_bounded",
``!(e1:real exp) (e1R:real) (e1F:real) (e2:real exp) (e2R:real) (e2F:real) (e3:real exp) (e3R:real) (e3F:real) (err1:real) (err2:real) (err3:real)
(vR:real) (vF:real) (E1 E2 :env) (m m1 m2 m3:mType) (defVars: num -> mType option).
eval_exp E1 (toRMap defVars) (toREval e1) e1R M0 /\
eval_exp E2 defVars e1 e1F m1 /\
eval_exp E1 (toRMap defVars) (toREval e2) e2R M0 /\
eval_exp E2 defVars e2 e2F m2 /\
eval_exp E1 (toRMap defVars) (toREval e3) e3R M0 /\
eval_exp E2 defVars e3 e3F m3 /\
eval_exp E1 (toRMap defVars) (toREval (Fma e1 e2 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 1) (Var 2) (Var 3)) vF m /\