Section Binary.
Arguments exist {A} {P}.
(** [prec] is the number of bits of the mantissa including the implicit one; [emax] is the exponent of the infinities. For instance, binary32 is defined by [prec = 24] and [emax = 128]. *)
Variable prec emax : Z.
Context (prec_gt_0_ : Prec_gt_0 prec).
Hypothesis Hmax : (prec < emax)%Z.
Let emin := (3 - emax - prec)%Z.
Let fexp := FLT_exp emin prec.
Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec.
Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec.
Definition canonical_mantissa m e :=
Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e.
Definition bounded m e :=
andb (canonical_mantissa m e) (Zle_bool e (emax - prec)).
Definition nan_pl pl :=
Zlt_bool (Zpos (digits2_pos pl)) prec.
Definition valid_binary x :=
match x with
| F754_finite _ m e => bounded m e
| F754_nan _ pl => nan_pl pl
| _ => true
end.
(** Basic type used for representing binary FP numbers. Note that there is exactly one such object per FP datum. *)
Inductive binary_float :=
| B754_zero (s : bool)
| B754_infinity (s : bool)
| B754_nan (s : bool) (pl : positive) :
nan_pl pl = true -> binary_float
| B754_finite (s : bool) (m : positive) (e : Z) :
bounded m e = true -> binary_float.
Definition FF2B x :=
match x as x return valid_binary x = true -> binary_float with
| F754_finite s m e => B754_finite s m e
| F754_infinity s => fun _ => B754_infinity s
| F754_zero s => fun _ => B754_zero s
| F754_nan b pl => fun H => B754_nan b pl H
end.
Definition B2FF x :=
match x with
| B754_finite s m e _ => F754_finite s m e
| B754_infinity s => F754_infinity s
| B754_zero s => F754_zero s
| B754_nan b pl _ => F754_nan b pl
end.
Definition B2R f :=
match f with
| B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e)
| _ => 0%R
end.
Proof with auto with typeclass_instances.
intros x.
apply FLT_format_generic...
apply generic_format_B2R.
Qed.
Definition is_finite_strict f :=
match f with
| B754_finite _ _ _ _ => true
| _ => false
end.
Definition Bsign x :=
match x with
| B754_nan s _ _ => s
| B754_zero s => s
| B754_infinity s => s
| B754_finite s _ _ _ => s
end.
Definition sign_FF x :=
match x with
| F754_nan s _ => s
| F754_zero s => s
| F754_infinity s => s
| F754_finite s _ _ => s
end.
Definition is_finite f :=
match f with
| B754_finite _ _ _ _ => true
| B754_zero _ => true
| _ => false
end.
Definition is_finite_FF f :=
match f with
| F754_finite _ _ _ => true
| F754_zero _ => true
| _ => false
end.
Definition is_nan f :=
match f with
| B754_nan _ _ _ => true
| _ => false
end.
Definition is_nan_FF f :=
match f with
| F754_nan _ _ => true
| _ => false
end.
Definition get_nan_pl (x : binary_float) : positive :=
match x with B754_nan _ pl _ => pl | _ => xH end.
Definition build_nan (x : { x | is_nan x = true }) : binary_float.
Definition erase (x : binary_float) : binary_float.
(** Opposite *)
Definition Bopp opp_nan x :=
match x with
| B754_nan _ _ _ => build_nan (opp_nan x)
| B754_infinity sx => B754_infinity (negb sx)
| B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx
| B754_zero sx => B754_zero (negb sx)
end.
(** Comparison  [Some c] means ordered as per [c]; [None] means unordered. *)
Definition Bcompare (f1 f2 : binary_float) : option comparison :=
match f1, f2 with
| B754_nan _ _ _,_ | _,B754_nan _ _ _ => None
| B754_infinity s1, B754_infinity s2 =>
Some match s1, s2 with
| true, true => Eq
| false, false => Eq
| true, false => Lt
| false, true => Gt
end
| B754_infinity s, _ => Some (if s then Lt else Gt)
| _, B754_infinity s => Some (if s then Gt else Lt)
| B754_finite s _ _ _, B754_zero _ => Some (if s then Lt else Gt)
| B754_zero _, B754_finite s _ _ _ => Some (if s then Gt else Lt)
| B754_zero _, B754_zero _ => Some Eq
| B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ =>
Some match s1, s2 with
| true, false => Lt
| false, true => Gt
| false, false =>
match Z.compare e1 e2 with
| Lt => Lt
| Gt => Gt
| Eq => Pcompare m1 m2 Eq
end
| true, true =>
match Z.compare e1 e2 with
| Lt => Gt
| Gt => Lt
| Eq => CompOpp (Pcompare m1 m2 Eq)
end
end
end.
(** Truncation *)
Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }.
Definition shr_1 mrs :=
let '(Build_shr_record m r s) := mrs in
let s := orb r s in
match m with
| Z0 => Build_shr_record Z0 false s
| Zpos xH => Build_shr_record Z0 true s
| Zpos (xO p) => Build_shr_record (Zpos p) false s
| Zpos (xI p) => Build_shr_record (Zpos p) true s
| Zneg xH => Build_shr_record Z0 true s
| Zneg (xO p) => Build_shr_record (Zneg p) false s
| Zneg (xI p) => Build_shr_record (Zneg p) true s
end.
Definition loc_of_shr_record mrs :=
match mrs with
| Build_shr_record _ false false => loc_Exact
| Build_shr_record _ false true => loc_Inexact Lt
| Build_shr_record _ true false => loc_Inexact Eq
| Build_shr_record _ true true => loc_Inexact Gt
end.
Definition shr_record_of_loc m l :=
match l with
| loc_Exact => Build_shr_record m false false
| loc_Inexact Lt => Build_shr_record m false true
| loc_Inexact Eq => Build_shr_record m true false
| loc_Inexact Gt => Build_shr_record m true true
end.
Definition shr mrs e n :=
match n with
| Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z)
| _ => (mrs, e)
end.
Definition shr_fexp m e l :=
shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e).
(** Rounding modes *)
Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA.
Definition round_mode m :=
match m with
| mode_NE => ZnearestE
| mode_ZR => Ztrunc
| mode_DN => Zfloor
| mode_UP => Zceil
| mode_NA => ZnearestA
end.
Definition choice_mode m sx mx lx :=
match m with
| mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx
| mode_ZR => mx
| mode_DN => cond_incr (round_sign_DN sx lx) mx
| mode_UP => cond_incr (round_sign_UP sx lx) mx
| mode_NA => cond_incr (round_N true lx) mx
end.
Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m).
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_aux mode sx mx ex lx :=
let '(mrs', e') := shr_fexp mx ex lx in
let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in
match shr_m mrs'' with
| Z0 => F754_zero sx
| Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx
| _ => F754_nan false xH (* dummy *)
end.
Proof with auto with typeclass_instances.
intros m x mx ex lx Px Bx Ex z.
unfold binary_round_aux in z.
revert z.
rewrite shr_truncate.
refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))).
rewrite <- cexp_abs in Ex.
refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)).
destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1).
rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
intros (H1a,H1b) H1c.
rewrite H1c.
assert (Hm: (m1 <= m1')%Z).
(* . *)
unfold m1', choice_mode, cond_incr.
case m ;
try apply Z.le_refl ;
match goal with |- (m1 <= if ?b then _ else _)%Z =>
case b ; [ apply Zle_succ | apply Z.le_refl ] end.
assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
(* . *)
rewrite <- (Z.abs_eq m1').
replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')).
rewrite F2R_Zabs.
now apply f_equal.
apply abs_cond_Zopp.
apply Z.le_trans with (2 := Hm).
apply Zlt_succ_le.
apply gt_0_F2R with radix2 e1.
apply Rle_lt_trans with (1 := Rabs_pos x).
exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
(* . *)
assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
now apply inbetween_Exact.
destruct m1' as [|m1'|m1'].
(* . m1' = 0 *)
rewrite shr_truncate. 2: apply Z.le_refl.
generalize (truncate_0 radix2 fexp e1 loc_Exact).
destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
rewrite shr_m_shr_record_of_loc.
intros Hm2.
rewrite Hm2.
repeat split.
rewrite Rlt_bool_true.
repeat split.
apply sym_eq.
case Rlt_bool ; apply F2R_0.
rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
apply bpow_gt_0.
(* . 0 < m1' *)
assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
2: discriminate.
rewrite H1b.
rewrite cexp_abs.
fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
apply cexp_round_ge...
rewrite H1c.
case (Rlt_bool x 0).
apply Rlt_not_eq.
now apply F2R_lt_0.
apply Rgt_not_eq.
now apply F2R_gt_0.
refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
2: now rewrite Hr ; apply F2R_gt_0.
refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
2: discriminate.
rewrite shr_truncate. 2: easy.
destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
rewrite shr_m_shr_record_of_loc.
intros (H3,H4) (H2,_).
destruct m2 as [|m2|m2].
elim Rgt_not_eq with (2 := H3).
rewrite F2R_0.
now apply F2R_gt_0.
rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs.
simpl Z.abs.
case_eq (Zle_bool e2 (emax - prec)) ; intros He2.
assert (bounded m2 e2 = true).
apply andb_true_intro.
split.
unfold canonical_mantissa.
apply Zeq_bool_true.
rewrite Zpos_digits2_pos.
rewrite <- mag_F2R_Zdigits.
apply sym_eq.
now rewrite H3 in H4.
discriminate.
exact He2.
apply (conj H).
rewrite Rlt_bool_true.
repeat split.
apply F2R_cond_Zopp.
now apply bounded_lt_emax.
rewrite (Rlt_bool_false _ (bpow radix2 emax)).
refine (conj _ (refl_equal _)).
unfold binary_overflow.
case overflow_to_inf.
apply refl_equal.
unfold valid_binary, bounded.
rewrite Zle_bool_refl.
rewrite Bool.andb_true_r.
apply Zeq_bool_true.
rewrite Zpos_digits2_pos.
replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
unfold fexp, FLT_exp, emin.
generalize (prec_gt_0 prec).
clear -Hmax ; zify ; omega.
change 2%Z with (radix_val radix2).
case_eq (Zpower radix2 prec - 1)%Z.
simpl Zdigits.
generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)).
clear ; omega.
intros p Hp.
apply Zle_antisym.
cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega.
apply Zdigits_gt_Zpower.
simpl Z.abs. rewrite <- Hp.
cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega.
apply lt_IZR.
rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak.
apply bpow_lt.
apply Zlt_pred.
now apply Zlt_0_le_0_pred.
apply Zdigits_le_Zpower.
simpl Z.abs. rewrite <- Hp.
apply Zlt_pred.
intros p Hp.
generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)).
clear -Hp ; zify ; omega.
apply Rnot_lt_le.
intros Hx.
generalize (refl_equal (bounded m2 e2)).
unfold bounded at 2.
rewrite He2.
rewrite Bool.andb_false_r.
rewrite bounded_canonical_lt_emax with (2 := Hx).
discriminate.
unfold canonical.
now rewrite <- H3.
elim Rgt_not_eq with (2 := H3).
apply Rlt_trans with R0.
now apply F2R_lt_0.
now apply F2R_gt_0.
rewrite <- Hr.
apply generic_format_abs...
apply generic_format_round...
(* . not m1' < 0 *)
elim Rgt_not_eq with (2 := Hr).
apply Rlt_le_trans with R0.
now apply F2R_lt_0.
apply Rabs_pos.
(* *)
now apply Rabs_pos_lt.
(* all the modes are valid *)
clear. case m.
exact inbetween_int_NE_sign.
exact inbetween_int_ZR_sign.
exact inbetween_int_DN_sign.
exact inbetween_int_UP_sign.
exact inbetween_int_NA_sign.
(* *)
apply inbetween_float_bounds in Bx.
apply Zlt_succ_le.
eapply gt_0_F2R.
apply Rle_lt_trans with (2 := proj2 Bx).
apply Rabs_pos.
Qed.
Proof with auto with typeclass_instances.
intros m x mx ex lx Bx Ex z.
unfold binary_round_aux in z.
revert z.
rewrite shr_truncate. 2: easy.
refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))).
refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)).
destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1).
rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
intros (H1a,H1b) H1c.
rewrite H1c.
assert (Hm: (m1 <= m1')%Z).
(* . *)
unfold m1', choice_mode, cond_incr.
case m ;
try apply Z.le_refl ;
match goal with |- (m1 <= if ?b then _ else _)%Z =>
case b ; [ apply Zle_succ | apply Z.le_refl ] end.
assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
(* . *)
rewrite <- (Z.abs_eq m1').
replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')).
rewrite F2R_Zabs.
now apply f_equal.
apply abs_cond_Zopp.
apply Z.le_trans with (2 := Hm).
apply Zlt_succ_le.
apply gt_0_F2R with radix2 e1.
apply Rle_lt_trans with (1 := Rabs_pos x).
exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
(* . *)
assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
now apply inbetween_Exact.
destruct m1' as [|m1'|m1'].
(* . m1' = 0 *)
rewrite shr_truncate. 2: apply Z.le_refl.
generalize (truncate_0 radix2 fexp e1 loc_Exact).
destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
rewrite shr_m_shr_record_of_loc.
intros Hm2.
rewrite Hm2.
repeat split.
rewrite Rlt_bool_true.
repeat split.
apply sym_eq.
case Rlt_bool ; apply F2R_0.
rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
apply bpow_gt_0.
(* . 0 < m1' *)
assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
2: discriminate.
rewrite H1b.
rewrite cexp_abs.
fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
apply cexp_round_ge...
rewrite H1c.
case (Rlt_bool x 0).
apply Rlt_not_eq.
now apply F2R_lt_0.
apply Rgt_not_eq.
now apply F2R_gt_0.
refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
2: now rewrite Hr ; apply F2R_gt_0.
refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
2: discriminate.
rewrite shr_truncate. 2: easy.
destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
rewrite shr_m_shr_record_of_loc.
intros (H3,H4) (H2,_).
destruct m2 as [|m2|m2].
elim Rgt_not_eq with (2 := H3).
rewrite F2R_0.
now apply F2R_gt_0.
rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs.
simpl Z.abs.
case_eq (Zle_bool e2 (emax - prec)) ; intros He2.
assert (bounded m2 e2 = true).
apply andb_true_intro.
split.
unfold canonical_mantissa.
apply Zeq_bool_true.
rewrite Zpos_digits2_pos.
rewrite <- mag_F2R_Zdigits.
apply sym_eq.
now rewrite H3 in H4.
discriminate.
exact He2.
apply (conj H).
rewrite Rlt_bool_true.
repeat split.
apply F2R_cond_Zopp.
now apply bounded_lt_emax.
rewrite (Rlt_bool_false _ (bpow radix2 emax)).
refine (conj _ (refl_equal _)).
unfold binary_overflow.
case overflow_to_inf.
apply refl_equal.
unfold valid_binary, bounded.
rewrite Zle_bool_refl.
rewrite Bool.andb_true_r.
apply Zeq_bool_true.
rewrite Zpos_digits2_pos.
replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
unfold fexp, FLT_exp, emin.
generalize (prec_gt_0 prec).
clear -Hmax ; zify ; omega.
change 2%Z with (radix_val radix2).
case_eq (Zpower radix2 prec - 1)%Z.
simpl Zdigits.
generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)).
clear ; omega.
intros p Hp.
apply Zle_antisym.
cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega.
apply Zdigits_gt_Zpower.
simpl Z.abs. rewrite <- Hp.
cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega.
apply lt_IZR.
rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak.
apply bpow_lt.
apply Zlt_pred.
now apply Zlt_0_le_0_pred.
apply Zdigits_le_Zpower.
simpl Z.abs. rewrite <- Hp.
apply Zlt_pred.
intros p Hp.
generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)).
clear -Hp ; zify ; omega.
apply Rnot_lt_le.
intros Hx.
generalize (refl_equal (bounded m2 e2)).
unfold bounded at 2.
rewrite He2.
rewrite Bool.andb_false_r.
rewrite bounded_canonical_lt_emax with (2 := Hx).
discriminate.
unfold canonical.
now rewrite <- H3.
elim Rgt_not_eq with (2 := H3).
apply Rlt_trans with R0.
now apply F2R_lt_0.
now apply F2R_gt_0.
rewrite <- Hr.
apply generic_format_abs...
apply generic_format_round...
(* . not m1' < 0 *)
elim Rgt_not_eq with (2 := Hr).
apply Rlt_le_trans with R0.
now apply F2R_lt_0.
apply Rabs_pos.
(* *)
apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)).
now apply F2R_gt_0.
(* all the modes are valid *)
clear. case m.
exact inbetween_int_NE_sign.
exact inbetween_int_ZR_sign.
exact inbetween_int_DN_sign.
exact inbetween_int_UP_sign.
exact inbetween_int_NA_sign.
Qed.
(** Multiplication *)
Definition Bmult mult_nan m x y :=
match x, y with
| B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (mult_nan x y)
| B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy)
| B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
| B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy)
| B754_infinity _, B754_zero _ => build_nan (mult_nan x y)
| B754_zero _, B754_infinity _ => build_nan (mult_nan x y)
| B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy)
| B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
| B754_zero sx, B754_zero sy => B754_zero (xorb sx sy)
| B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy))
end.
(** Normalization and rounding *)
Definition shl_align mx ex ex' :=
match (ex' - ex)%Z with
| Zneg d => (shift_pos d mx, ex')
| _ => (mx, ex)
end.
Definition shl_align_fexp mx ex :=
shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)).
Definition binary_round m sx mx ex :=
let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact.
Definition binary_normalize mode m e szero :=
match m with
| Z0 => B754_zero szero
| Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e))
| Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e))
end.
Proof with auto with typeclass_instances.
intros m mx ez szero.
destruct mx as [|mz|mz] ; simpl.
rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true...
split... split...
rewrite Rcompare_Eq...
apply bpow_gt_0.
(* . mz > 0 *)
generalize (binary_round_correct m false mz ez).
simpl.
case Rlt_bool_spec.
intros _ (Vz, (Rz, (Rz', Rz''))).
split.
now rewrite B2R_FF2B.
split.
now rewrite is_finite_FF2B.
rewrite Bsign_FF2B, Rz''.
rewrite Rcompare_Gt...
apply F2R_gt_0.
simpl. zify; omega.
intros Hz' (Vz, Rz).
rewrite B2FF_FF2B, Rz.
apply f_equal.
apply sym_eq.
apply Rlt_bool_false.
now apply F2R_ge_0.
(* . mz < 0 *)
generalize (binary_round_correct m true mz ez).
simpl.
case Rlt_bool_spec.
intros _ (Vz, (Rz, (Rz', Rz''))).
split.
now rewrite B2R_FF2B.
split.
now rewrite is_finite_FF2B.
rewrite Bsign_FF2B, Rz''.
rewrite Rcompare_Lt...
apply F2R_lt_0.
simpl. zify; omega.
intros Hz' (Vz, Rz).
rewrite B2FF_FF2B, Rz.
apply f_equal.
apply sym_eq.
apply Rlt_bool_true.
now apply F2R_lt_0.
Qed.
(** Addition *)
Definition Bplus plus_nan m x y :=
match x, y with
| B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (plus_nan x y)
| B754_infinity sx, B754_infinity sy =>
if Bool.eqb sx sy then x else build_nan (plus_nan x y)
| B754_infinity _, _ => x
| _, B754_infinity _ => y
| B754_zero sx, B754_zero sy =>
if Bool.eqb sx sy then x else
match m with mode_DN => B754_zero true | _ => B754_zero false end
| B754_zero _, _ => y
| _, B754_zero _ => x
| B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
let ez := Z.min ex ey in
binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
ez (match m with mode_DN => true | _ => false end)
end.
Proof with auto with typeclass_instances.
intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy.
(* *)
rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true...
simpl.
rewrite Rcompare_Eq by auto.
destruct sx, sy; try easy; now case m.
apply bpow_gt_0.
(* *)
rewrite Rplus_0_l, round_generic, Rlt_bool_true...
split... split...
simpl. unfold F2R.
erewrite <- Rmult_0_l, Rcompare_mult_r.
rewrite Rcompare_IZR with (y:=0%Z).
destruct sy...
apply bpow_gt_0.
apply abs_B2R_lt_emax.
apply generic_format_B2R.
(* *)
rewrite Rplus_0_r, round_generic, Rlt_bool_true...
split... split...
simpl. unfold F2R.
erewrite <- Rmult_0_l, Rcompare_mult_r.
rewrite Rcompare_IZR with (y:=0%Z).
destruct sx...
apply bpow_gt_0.
apply abs_B2R_lt_emax.
apply generic_format_B2R.
(* *)
clear Fx Fy.
simpl.
set (szero := match m with mode_DN => true | _ => false end).
set (ez := Z.min ex ey).
set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z).
assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) +
F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)).
rewrite 2!F2R_cond_Zopp.
generalize (shl_align_correct mx ex ez).
generalize (shl_align_correct my ey ez).
generalize (snd_shl_align mx ex ez (Z.le_min_l ex ey)).
generalize (snd_shl_align my ey ez (Z.le_min_r ex ey)).
destruct (shl_align mx ex ez) as (mx', ex').
destruct (shl_align my ey ez) as (my', ey').
simpl.
intros H1 H2.
rewrite H1, H2.
clear H1 H2.
intros (H1, _) (H2, _).
rewrite H1, H2.
clear H1 H2.
rewrite <- 2!F2R_cond_Zopp.
unfold F2R. simpl.
now rewrite <- Rmult_plus_distr_r, <- plus_IZR.
rewrite Hp.
assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy).
(* . *)
rewrite <- Hp.
intros Bz.
destruct (Bool.bool_dec sx sy) as [Hs|Hs].
(* .. *)
refine (conj _ Hs).
rewrite Hs.
apply sym_eq.
case sy.
apply Rlt_bool_true.
rewrite <- (Rplus_0_r 0).
apply Rplus_lt_compat.
now apply F2R_lt_0.
now apply F2R_lt_0.
apply Rlt_bool_false.
rewrite <- (Rplus_0_r 0).
apply Rplus_le_compat.
now apply F2R_ge_0.
now apply F2R_ge_0.
(* .. *)
elim Rle_not_lt with (1 := Bz).
generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy).
intros Bx By (Hx',_) (Hy',_).
generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy').
clear -Bx By Hs prec_gt_0_.
intros Cx Cy.
destruct sx.
(* ... *)
destruct sy.
now elim Hs.
clear Hs.
apply Rabs_lt.
split.
apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)).
rewrite F2R_Zopp.
now apply Ropp_lt_contravar.
apply round_ge_generic...
now apply generic_format_canonical.
pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
now apply F2R_ge_0.
apply Rle_lt_trans with (2 := By).
apply round_le_generic...
now apply generic_format_canonical.
rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))).
apply Rplus_le_compat_r.
now apply F2R_le_0.
(* ... *)
destruct sy.
2: now elim Hs.
clear Hs.
apply Rabs_lt.
split.
apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)).
rewrite F2R_Zopp.
now apply Ropp_lt_contravar.
apply round_ge_generic...
now apply generic_format_canonical.
pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l.
apply Rplus_le_compat_r.
now apply F2R_ge_0.
apply Rle_lt_trans with (2 := Bx).
apply round_le_generic...
now apply generic_format_canonical.
rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))).
apply Rplus_le_compat_l.
now apply F2R_le_0.
(* . *)
generalize (binary_normalize_correct m mz ez szero).
case Rlt_bool_spec.
split; try easy. split; try easy.
destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy.
rewrite H1 in Hp.
apply Rplus_opp_r_uniq in Hp.
rewrite <- F2R_Zopp in Hp.
eapply canonical_unique in Hp.
inversion Hp. destruct sy, sx, m; try discriminate H3; easy.
apply canonical_canonical_mantissa.
apply Bool.andb_true_iff in Hy. easy.
replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx))
by (destruct sx; auto).
apply canonical_canonical_mantissa.
apply Bool.andb_true_iff in Hx. easy.
intros Hz' Vz.
specialize (Sz Hz').
split.
rewrite Vz.
now apply f_equal.
apply Sz.
Qed.
(** Subtraction *)
Definition Bminus minus_nan m x y :=
match x, y with
| B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (minus_nan x y)
| B754_infinity sx, B754_infinity sy =>
if Bool.eqb sx (negb sy) then x else build_nan (minus_nan x y)
| B754_infinity _, _ => x
| _, B754_infinity sy => B754_infinity (negb sy)
| B754_zero sx, B754_zero sy =>
if Bool.eqb sx (negb sy) then x else
match m with mode_DN => B754_zero true | _ => B754_zero false end
| B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy
| _, B754_zero _ => x
| B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
let ez := Z.min ex ey in
binary_normalize m (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
ez (match m with mode_DN => true | _ => false end)
end.
Proof with auto with typeclass_instances.
intros minus_nan m x y Fx Fy.
generalize (Bplus_correct minus_nan m x (Bopp (fun n => minus_nan n (B754_zero false)) y) Fx).
rewrite is_finite_Bopp, B2R_Bopp.
intros H.
specialize (H Fy).
replace (negb (Bsign y)) with (Bsign (Bopp (fun n => minus_nan n (B754_zero false)) y)).
destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy.
unfold Bminus, Zminus.
now rewrite <- cond_Zopp_negb.
now destruct y as [ | | | ].
Qed.
(** Fused Multiply-Add *)
Definition Bfma_szero m (x y z: binary_float) : bool :=
let s_xy := xorb (Bsign x) (Bsign y) in  (* sign of product x*y *)
if Bool.eqb s_xy (Bsign z) then s_xy
else match m with mode_DN => true | _ => false end.
Definition Bfma fma_nan m (x y z: binary_float) :=
match x, y with
| B754_nan _ _ _, _ | _, B754_nan _ _ _
| B754_infinity _, B754_zero _
| B754_zero _, B754_infinity _ =>
(* Multiplication produces NaN *)
build_nan (fma_nan x y z)
| B754_infinity sx, B754_infinity sy
| B754_infinity sx, B754_finite sy _ _ _
| B754_finite sx _ _ _, B754_infinity sy =>
let s := xorb sx sy in
(* Multiplication produces infinity with sign [s] *)
match z with
| B754_nan _ _ _ => build_nan (fma_nan x y z)
| B754_infinity sz =>
if Bool.eqb s sz then z else build_nan (fma_nan x y z)
| _ => B754_infinity s
end
| B754_finite sx _ _ _, B754_zero sy
| B754_zero sx, B754_finite sy _ _ _
| B754_zero sx, B754_zero sy =>
(* Multiplication produces zero *)
match z with
| B754_nan _ _ _ => build_nan (fma_nan x y z)
| B754_zero _ => B754_zero (Bfma_szero m x y z)
| _ => z
end
| B754_finite sx mx ex _, B754_finite sy my ey _ =>
(* Multiplication produces a finite, non-zero result *)
match z with
| B754_nan _ _ _ => build_nan (fma_nan x y z)
| B754_infinity sz => z
| B754_zero _ =>
let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
let '(Float _ mr er) := Fmult X Y in
binary_normalize m mr er (Bfma_szero m x y z)
| B754_finite sz mz ez _ =>
let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
let Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez in
let '(Float _ mr er) := Fplus (Fmult X Y) Z in
binary_normalize m mr er (Bfma_szero m x y z)
end
end.

Theorem Bfma_correct:
forall fma_nan m x y z,
let res := (B2R x * B2R y + B2R z)%R in
is_finite x = true ->
is_finite y = true ->
is_finite z = true ->
if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then
B2R (Bfma fma_nan m x y z) = round radix2 fexp (round_mode m) res /\
is_finite (Bfma fma_nan m x y z) = true /\
Bsign (Bfma fma_nan m x y z) =
match Rcompare res 0 with
| Eq => Bfma_szero m x y z
| Lt => true
| Gt => false
end
else
B2FF (Bfma fma_nan m x y z) = binary_overflow m (Rlt_bool res 0).