Commit e2327b52 authored by Guillaume Melquiond's avatar Guillaume Melquiond

Fixed overflow handling for directed rounding mode.

parent a4f1712c
...@@ -359,12 +359,25 @@ Definition choice_mode m sx mx lx := ...@@ -359,12 +359,25 @@ Definition choice_mode m sx mx lx :=
| mode_NA => cond_incr (round_N true lx) mx | mode_NA => cond_incr (round_N true lx) mx
end. end.
Definition overflow_to_inf m s :=
match m with
| mode_NE => true
| mode_NA => true
| mode_ZR => false
| mode_UP => negb s
| mode_DN => s
end.
Definition binary_overflow m s :=
if overflow_to_inf m s then F754_infinity s
else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec).
Definition binary_round_sign mode sx mx ex lx := Definition binary_round_sign mode sx mx ex lx :=
let '(m', e', l') := truncate radix2 fexp (Zpos mx, ex, lx) in let '(m', e', l') := truncate radix2 fexp (Zpos mx, ex, lx) in
let '(m'', e'', l'') := truncate radix2 fexp (choice_mode mode sx m' l', e', loc_Exact) in let '(m'', e'', l'') := truncate radix2 fexp (choice_mode mode sx m' l', e', loc_Exact) in
match m'' with match m'' with
| Z0 => F754_zero sx | Z0 => F754_zero sx
| Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else F754_infinity sx | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx
| _ => F754_nan (* dummy *) | _ => F754_nan (* dummy *)
end. end.
...@@ -376,7 +389,7 @@ Theorem binary_round_sign_correct : ...@@ -376,7 +389,7 @@ Theorem binary_round_sign_correct :
if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
FF2R radix2 (binary_round_sign mode (Rlt_bool x 0) mx ex lx) = round radix2 fexp (round_mode mode) x FF2R radix2 (binary_round_sign mode (Rlt_bool x 0) mx ex lx) = round radix2 fexp (round_mode mode) x
else else
binary_round_sign mode (Rlt_bool x 0) mx ex lx = F754_infinity (Rlt_bool x 0). binary_round_sign mode (Rlt_bool x 0) mx ex lx = binary_overflow mode (Rlt_bool x 0).
Proof. Proof.
intros m x mx ex lx Bx Ex. intros m x mx ex lx Bx Ex.
unfold binary_round_sign. unfold binary_round_sign.
...@@ -464,9 +477,43 @@ apply (conj H). ...@@ -464,9 +477,43 @@ apply (conj H).
rewrite Rlt_bool_true. rewrite Rlt_bool_true.
apply F2R_cond_Zopp. apply F2R_cond_Zopp.
now apply bounded_lt_emax. now apply bounded_lt_emax.
apply (conj (refl_equal true)). rewrite (Rlt_bool_false _ (bpow radix2 emax)).
rewrite Rlt_bool_false. refine (conj _ (refl_equal _)).
unfold binary_overflow.
case overflow_to_inf.
apply refl_equal. apply refl_equal.
unfold valid_binary, bounded.
rewrite Zle_bool_refl.
rewrite Bool.andb_true_r.
apply Zeq_bool_true.
rewrite Z_of_nat_S_digits2_Pnat.
change Fcalc_digits.radix2 with radix2.
replace (digits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
unfold fexp, FLT_exp, emin.
clear -Hprec Hmax.
zify ; omega.
change 2%Z with (radix_val radix2).
case_eq (Zpower radix2 prec - 1)%Z.
simpl digits.
generalize (Zpower_gt_1 radix2 _ Hprec).
clear ; omega.
intros p Hp.
apply Zle_antisym.
cut (prec - 1 < digits radix2 (Zpos p))%Z. clear ; omega.
apply digits_gt_Zpower.
simpl Zabs. rewrite <- Hp.
cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega.
apply lt_Z2R.
rewrite 2!Z2R_Zpower. 2: now apply Zlt_le_weak.
apply bpow_lt.
apply Zlt_pred.
now apply Zlt_0_le_0_pred.
apply digits_le_Zpower.
simpl Zabs. rewrite <- Hp.
apply Zlt_pred.
intros p Hp.
generalize (Zpower_gt_1 radix2 _ Hprec).
clear -Hp ; zify ; omega.
apply Rnot_lt_le. apply Rnot_lt_le.
intros Hx. intros Hx.
generalize (refl_equal (bounded m2 e2)). generalize (refl_equal (bounded m2 e2)).
...@@ -519,7 +566,7 @@ Lemma Bmult_correct_aux : ...@@ -519,7 +566,7 @@ Lemma Bmult_correct_aux :
if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then
FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) FF2R radix2 z = round radix2 fexp (round_mode m) (x * y)
else else
z = F754_infinity (xorb sx sy). z = binary_overflow m (xorb sx sy).
Proof. Proof.
intros m sx mx ex Hx sy my ey Hy x y. intros m sx mx ex Hx sy my ey Hy x y.
unfold x, y. unfold x, y.
...@@ -583,7 +630,7 @@ Theorem Bmult_correct : ...@@ -583,7 +630,7 @@ Theorem Bmult_correct :
if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then
B2R (Bmult m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) B2R (Bmult m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y)
else else
Bmult m x y = B754_infinity (xorb (Bsign x) (Bsign y)). B2FF (Bmult m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
Proof. Proof.
intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ;
try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ apply refl_equal | apply bpow_gt_0 ] ). try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ apply refl_equal | apply bpow_gt_0 ] ).
...@@ -593,22 +640,9 @@ intros H1 H2. ...@@ -593,22 +640,9 @@ intros H1 H2.
revert H2. revert H2.
case Rlt_bool ; intros H2. case Rlt_bool ; intros H2.
now rewrite B2R_FF2B. now rewrite B2R_FF2B.
apply binary_unicity.
now rewrite B2FF_FF2B. now rewrite B2FF_FF2B.
Qed. Qed.
Theorem Bmult_correct_finite :
forall m x y,
is_finite (Bmult m x y) = true ->
B2R (Bmult m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y)%R.
Proof.
intros m x y.
generalize (Bmult_correct m x y).
destruct (Bmult m x y) as [sz|sz| |sz mz ez Hz] ; try easy.
now case Rlt_bool.
now case Rlt_bool.
Qed.
Definition fexp_scale mx ex := Definition fexp_scale mx ex :=
let ex' := fexp (Z_of_nat (S (digits2_Pnat mx)) + ex) in let ex' := fexp (Z_of_nat (S (digits2_Pnat mx)) + ex) in
match (ex' - ex)%Z with match (ex' - ex)%Z with
...@@ -671,7 +705,7 @@ Theorem binary_round_sign_fexp_scale_correct : ...@@ -671,7 +705,7 @@ Theorem binary_round_sign_fexp_scale_correct :
if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then
FF2R radix2 (binary_round_sign_fexp_scale m sx mx ex) = round radix2 fexp (round_mode m) x FF2R radix2 (binary_round_sign_fexp_scale m sx mx ex) = round radix2 fexp (round_mode m) x
else else
binary_round_sign_fexp_scale m sx mx ex = F754_infinity sx. binary_round_sign_fexp_scale m sx mx ex = binary_overflow m sx.
Proof. Proof.
intros m sx mx ex. intros m sx mx ex.
unfold binary_round_sign_fexp_scale. unfold binary_round_sign_fexp_scale.
...@@ -727,7 +761,7 @@ Theorem Bplus_correct : ...@@ -727,7 +761,7 @@ Theorem Bplus_correct :
if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then
B2R (Bplus m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) B2R (Bplus m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y)
else else
(Bplus m x y = B754_infinity (Bsign x) /\ Bsign x = Bsign y). (B2FF (Bplus m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y).
Proof. Proof.
intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy. intros m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy.
(* *) (* *)
...@@ -840,7 +874,6 @@ now rewrite B2R_FF2B. ...@@ -840,7 +874,6 @@ now rewrite B2R_FF2B.
intros Hz' (Vz, Rz). intros Hz' (Vz, Rz).
specialize (Sz Hz'). specialize (Sz Hz').
refine (conj _ (proj2 Sz)). refine (conj _ (proj2 Sz)).
apply binary_unicity.
rewrite B2FF_FF2B. rewrite B2FF_FF2B.
rewrite (proj1 Sz). rewrite (proj1 Sz).
rewrite Rlt_bool_false. rewrite Rlt_bool_false.
...@@ -855,7 +888,6 @@ now rewrite B2R_FF2B. ...@@ -855,7 +888,6 @@ now rewrite B2R_FF2B.
intros Hz' (Vz, Rz). intros Hz' (Vz, Rz).
specialize (Sz Hz'). specialize (Sz Hz').
refine (conj _ (proj2 Sz)). refine (conj _ (proj2 Sz)).
apply binary_unicity.
rewrite B2FF_FF2B. rewrite B2FF_FF2B.
rewrite (proj1 Sz). rewrite (proj1 Sz).
rewrite Rlt_bool_true. rewrite Rlt_bool_true.
...@@ -879,7 +911,7 @@ Lemma Bdiv_correct_aux : ...@@ -879,7 +911,7 @@ Lemma Bdiv_correct_aux :
if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then
FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) FF2R radix2 z = round radix2 fexp (round_mode m) (x / y)
else else
z = F754_infinity (xorb sx sy). z = binary_overflow m (xorb sx sy).
Proof. Proof.
intros m sx mx ex Hx sy my ey Hy. intros m sx mx ex Hx sy my ey Hy.
refine (_ (Fdiv_core_correct radix2 prec (Zpos mx) ex (Zpos my) ey _ _ _)) ; try easy. refine (_ (Fdiv_core_correct radix2 prec (Zpos mx) ex (Zpos my) ey _ _ _)) ; try easy.
...@@ -982,7 +1014,7 @@ Theorem Bdiv_correct : ...@@ -982,7 +1014,7 @@ Theorem Bdiv_correct :
if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then
B2R (Bdiv m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) B2R (Bdiv m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y)
else else
Bdiv m x y = B754_infinity (xorb (Bsign x) (Bsign y)). B2FF (Bdiv m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
Proof. Proof.
intros m x [sy|sy| |sy my ey Hy] Zy ; try now elim Zy. intros m x [sy|sy| |sy my ey Hy] Zy ; try now elim Zy.
revert x. revert x.
...@@ -996,7 +1028,6 @@ revert H2. ...@@ -996,7 +1028,6 @@ revert H2.
unfold Rdiv. unfold Rdiv.
case Rlt_bool ; intros H2. case Rlt_bool ; intros H2.
now rewrite B2R_FF2B. now rewrite B2R_FF2B.
apply binary_unicity.
now rewrite B2FF_FF2B. now rewrite B2FF_FF2B.
Qed. Qed.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment