(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, 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.     *)
(*                                                                     *)
(* *********************************************************************)
(** Formalization of floating-point numbers, using the Flocq library. *)
(*From Flocq*)
Require Archi.
Close Scope R_scope.
Open Scope Z_scope.
Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *)
Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *)
(** Boolean-valued comparisons *)
Definition cmp_of_comparison (c: comparison) (x: option Datatypes.comparison) : bool :=
match c with
| Ceq =>
match x with Some Eq => true | _ => false end
| Cne =>
match x with Some Eq => false | _ => true end
| Clt =>
match x with Some Lt => true | _ => false end
| Cle =>
match x with Some(Lt|Eq) => true | _ => false end
| Cgt =>
match x with Some Gt => true | _ => false end
| Cge =>
match x with Some(Gt|Eq) => true | _ => false end
end.
Definition ordered_of_comparison (x: option Datatypes.comparison) : bool :=
match x with None => false | Some _ => true end.
(** Normalization of NaN payloads *)
(** Transform a Nan payload to a quiet Nan payload. *)
Definition quiet_nan_64_payload (p: positive) :=
Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 51 1%positive))) 52%nat).
Definition expand_nan s p H : {x | is_nan _ _ x = true} :=
exist _ (B754_nan 53 1024 s (expand_nan_payload p) (expand_nan_proof p H)) (eq_refl true).
Definition of_single_nan (f : float32) : { x : float | is_nan _ _ x = true } :=
match f with
| B754_nan s p H =>
if Archi.float_of_single_preserves_sNaN
then expand_nan s p H
else quiet_nan_64 (s, expand_nan_payload p)
| _ => default_nan_64
end.
Definition reduce_nan_payload (p: positive) :=
(* The [quiet_nan_64_payload p] before the right shift is redundant with the [quiet_nan_32_payload p] performed after, in [to_single_nan]. However the former ensures that the result of the right shift is not 0 and therefore representable as a positive. *)
Pos.shiftr_nat (quiet_nan_64_payload p) 29.
Definition to_single_nan (f : float) : { x : float32 | is_nan _ _ x = true } :=
match f with
| B754_nan s p H => quiet_nan_32 (s, reduce_nan_payload p)
| _ => default_nan_32
end.
(** NaN payload operations for opposite and absolute value. *)
Definition neg_nan (f : float) : { x : float | is_nan _ _ x = true } :=
match f with
| B754_nan s p H => exist _ (B754_nan 53 1024 (negb s) p H) (eq_refl true)
| _ => default_nan_64
end.
Definition abs_nan (f : float) : { x : float | is_nan _ _ x = true } :=
match f with
| B754_nan s p H => exist _ (B754_nan 53 1024 false p H) (eq_refl true)
| _ => default_nan_64
end.
(** When an arithmetic operation returns a NaN, the sign and payload of this NaN are not fully specified by the IEEE standard, and vary among the architectures supported by CompCert.  However, the following behavior applies to all the supported architectures: the payload is either - a default payload, independent of the arguments, or - the payload of one of the NaN arguments, if any.  For each supported architecture, the functions [Archi.choose_nan_64] and [Archi.choose_nan_32] determine the payload of the result as a function of the payloads of the NaN arguments.  Additionally, signaling NaNs are converted to quiet NaNs, as required by the standard. *)
Definition cons_pl (x: float) (l: list (bool * positive)) :=
match x with B754_nan s p _ => (s, p) :: l | _ => l end.
Definition unop_nan (x: float) : {x : float | is_nan _ _ x = true} :=
quiet_nan_64 (Archi.choose_nan_64 (cons_pl x [])).
Definition binop_nan (x y: float) : {x : float | is_nan _ _ x = true} :=
quiet_nan_64 (Archi.choose_nan_64 (cons_pl x (cons_pl y []))).
(** For fused multiply-add, the order in which arguments are examined to select a NaN payload varies across platforms.  E.g. in [fma x y z], x86 considers [x] first, then [y], then [z], while ARM considers [z] first, then [x], then [y].  The corresponding permutation is defined for each target, as function [Archi.fma_order]. *)
Definition fma_nan_1 (x y z: float) : {x : float | is_nan _ _ x = true} :=
let '(a, b, c) := Archi.fma_order x y z in
quiet_nan_64 (Archi.choose_nan_64 (cons_pl a (cons_pl b (cons_pl c [])))).
(** One last wrinkle for fused multiply-add: [fma zero infinity nan] can return either the quiesced [nan], or the default NaN arising out of the invalid operation [zero * infinity].  Of our target platforms, only ARM honors the latter case.  The choice between the default NaN and [nan] is done as in the case of two-argument arithmetic operations. *)
Definition fma_nan (x y z: float) : {x : float | is_nan _ _ x = true} :=
match x, y with
| B754_infinity _, B754_zero _ | B754_zero _, B754_infinity _ =>
if Archi.fma_invalid_mul_is_nan
then quiet_nan_64 (Archi.choose_nan_64 (Archi.default_nan_64 :: cons_pl z []))
else fma_nan_1 x y z
| _, _ =>
fma_nan_1 x y z
end.
(** ** Operations over double-precision floats *)
Definition zero: float := B754_zero _ _ false. (**r the float [+0.0] *)
Definition eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2} := Beq_dec _ _.
(** Arithmetic operations *)
Definition neg: float -> float := Bopp _ _ neg_nan. (**r opposite (change sign) *)
Definition abs: float -> float := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *)
Definition sqrt: float -> float :=
Bsqrt 53 1024 __ __ unop_nan mode_NE.  (**r square root *)
Definition add: float -> float -> float :=
Bplus 53 1024 __ __ binop_nan mode_NE. (**r addition *)
Definition sub: float -> float -> float :=
Bminus 53 1024 __ __ binop_nan mode_NE. (**r subtraction *)
Definition mul: float -> float -> float :=
Bmult 53 1024 __ __ binop_nan mode_NE. (**r multiplication *)
Definition div: float -> float -> float :=
Bdiv 53 1024 __ __ binop_nan mode_NE. (**r division *)
Definition fma: float -> float -> float -> float :=
Bfma 53 1024 __ __ fma_nan mode_NE. (**r fused multiply-add [x * y + z] *)
Definition compare (f1 f2: float) : option Datatypes.comparison := (**r general comparison *)
Bcompare 53 1024 f1 f2.
Definition cmp (c:comparison) (f1 f2: float) : bool := (**r Boolean comparison *)
cmp_of_comparison c (compare f1 f2).
Definition ordered (f1 f2: float) : bool :=
ordered_of_comparison (compare f1 f2).
(** Conversions *)
Definition of_single: float32 -> float := Bconv _ _ 53 1024 __ __ of_single_nan mode_NE.
Definition to_single: float -> float32 := Bconv _ _ 24 128 __ __ to_single_nan mode_NE.
Definition to_int (f:float): option int := (**r conversion to signed 32-bit int *)
option_map Int.repr (ZofB_range _ _ f Int.min_signed Int.max_signed).
Definition to_intu (f:float): option int := (**r conversion to unsigned 32-bit int *)
option_map Int.repr (ZofB_range _ _ f 0 Int.max_unsigned).
Definition to_long (f:float): option int64 := (**r conversion to signed 64-bit int *)
option_map Int64.repr (ZofB_range _ _ f Int64.min_signed Int64.max_signed).
Definition to_longu (f:float): option int64 := (**r conversion to unsigned 64-bit int *)
option_map Int64.repr (ZofB_range _ _ f 0 Int64.max_unsigned).
Definition of_int (n:int): float := (**r conversion from signed 32-bit int *)
BofZ 53 1024 __ __ (Int.signed n).
Definition of_intu (n:int): float:= (**r conversion from unsigned 32-bit int *)
BofZ 53 1024 __ __ (Int.unsigned n).
Definition of_long (n:int64): float := (**r conversion from signed 64-bit int *)
BofZ 53 1024 __ __ (Int64.signed n).
Definition of_longu (n:int64): float:= (**r conversion from unsigned 64-bit int *)
BofZ 53 1024 __ __ (Int64.unsigned n).
Definition from_parsed (base:positive) (intPart:positive) (expPart:Z) : float :=
Bparse 53 1024 __ __ base intPart expPart.
(** Conversions between floats and their concrete in-memory representation as a sequence of 64 bits. *)
Definition to_bits (f: float): int64 := Int64.repr (bits_of_b64 f).
Definition of_bits (b: int64): float := b64_of_bits (Int64.unsigned b).
Definition from_words (hi lo: int) : float := of_bits (Int64.ofwords hi lo).
(** ** Properties *)
(** Below are the only properties of floating-point arithmetic that we rely on in the compiler proof. *)
(** Some tactics **)
Ltac compute_this val :=
let x := fresh in set val as x in *; vm_compute in x; subst x.
Ltac smart_omega :=
simpl radix_val in *; simpl Z.pow in *;
compute_this Int.modulus; compute_this Int.half_modulus;
compute_this Int.max_unsigned;
compute_this Int.min_signed; compute_this Int.max_signed;
compute_this Int64.modulus; compute_this Int64.half_modulus;
compute_this Int64.max_unsigned;
compute_this (Z.pow_pos 2 1024); compute_this (Z.pow_pos 2 53); compute_this (Z.pow_pos 2 52); compute_this (Z.pow_pos 2 32);
zify; omega.
(** Commutativity properties of addition and multiplication. *)

Theorem mul_commut:
forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x.