From dbe2f1770512ee317e54d6cc483be804d6103f48 Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Wed, 26 Jul 2023 10:45:42 -0400 Subject: [PATCH] Float_u stdlib module (#1572) --- ocaml/Makefile.common-jst | 9 +- ocaml/driver/compenv.ml | 2 +- ocaml/ocamldoc/odoc.ml | 2 + ocaml/stdlib/.depend | 10 + ocaml/stdlib/Makefile | 23 ++ ocaml/stdlib/StdlibModules | 2 +- ocaml/stdlib/dune | 7 + ocaml/stdlib/float_u.ml | 156 ++++++++ ocaml/stdlib/float_u.mli | 349 ++++++++++++++++++ ocaml/stdlib/ocaml_compiler_internal_params | 2 + .../tests/typing-layouts-float64/alloc.ml | 33 +- .../stdlib_float_u_alpha.ml | 269 ++++++++++++++ .../unboxed_floats.compilers.reference | 8 +- .../typing-layouts-float64/unboxed_floats.ml | 36 +- .../unboxed_floats_alpha.ml | 36 +- .../unboxed_floats_beta.compilers.reference | 8 +- .../unboxed_floats_beta.ml | 36 +- 17 files changed, 872 insertions(+), 116 deletions(-) create mode 100644 ocaml/stdlib/float_u.ml create mode 100644 ocaml/stdlib/float_u.mli create mode 100644 ocaml/stdlib/ocaml_compiler_internal_params create mode 100644 ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u_alpha.ml diff --git a/ocaml/Makefile.common-jst b/ocaml/Makefile.common-jst index acd7a7689db..a639cc1f264 100644 --- a/ocaml/Makefile.common-jst +++ b/ocaml/Makefile.common-jst @@ -102,7 +102,8 @@ dune_config_targets = \ duneconf/main.ws \ $(ocamldir)/duneconf/dirs-to-ignore.inc \ $(ocamldir)/duneconf/jst-extra.inc \ - dune-project + dune-project \ + $(ocamldir)/stdlib/ocaml_compiler_internal_params _build/_bootinstall: Makefile.config $(dune_config_targets) echo -n '$(NATDYNLINKOPTS)' > $(ocamldir)/otherlibs/dynlink/natdynlinkops @@ -172,6 +173,12 @@ _install: compiler install: _install mkdir -p '$(prefix)' rsync --chmod=u+rw,go+r -rl _install/ '$(prefix)' + rm '$(prefix)/lib/ocaml/ocaml_compiler_internal_params' + # rm `ocaml_compiler_internal_params`, which is used to compile the + # stdlib `Float_u` module with `-extension layouts_alpha`, because we + # don't want user programs that happened to be named + # `ocaml/stdlib/float_u.ml` to get the flag automatically. + # Same as above, but relies on a successfull earlier _install install_for_opam: diff --git a/ocaml/driver/compenv.ml b/ocaml/driver/compenv.ml index c63aedda76c..005c9588f33 100644 --- a/ocaml/driver/compenv.ml +++ b/ocaml/driver/compenv.ml @@ -534,7 +534,7 @@ type file_option = { } let scan_line ic = - Scanf.bscanf ic "%[0-9a-zA-Z_.*] : %[a-zA-Z_-] = %s " + Scanf.bscanf ic "%[0-9a-zA-Z/_.*] : %[a-zA-Z_-] = %s " (fun pattern name value -> let pattern = match pattern with diff --git a/ocaml/ocamldoc/odoc.ml b/ocaml/ocamldoc/odoc.ml index 1d0332ddb12..12089a668e5 100644 --- a/ocaml/ocamldoc/odoc.ml +++ b/ocaml/ocamldoc/odoc.ml @@ -18,6 +18,8 @@ module M = Odoc_messages +let () = Language_extension.enable_maximal () + (* we check if we must load a module given on the command line *) let arg_list = Array.to_list Sys.argv let (plugins, paths) = diff --git a/ocaml/stdlib/.depend b/ocaml/stdlib/.depend index 5e4f8e60b4b..86098b9cd4c 100644 --- a/ocaml/stdlib/.depend +++ b/ocaml/stdlib/.depend @@ -325,6 +325,16 @@ stdlib__Float.cmx : float.ml \ stdlib__Float.cmi : float.mli \ stdlib.cmi \ stdlib__Seq.cmi +stdlib__Float_u.cmo : float_u.ml \ + stdlib.cmi \ + stdlib__Float.cmi \ + stdlib__Float_u.cmi +stdlib__Float_u.cmx : float_u.ml \ + stdlib.cmx \ + stdlib__Float.cmx \ + stdlib__Float_u.cmi +stdlib__Float_u.cmi : float_u.mli \ + stdlib.cmi stdlib__Format.cmo : format.ml \ stdlib__String.cmi \ stdlib.cmi \ diff --git a/ocaml/stdlib/Makefile b/ocaml/stdlib/Makefile index 8ed32ddf722..40728ae3ee8 100644 --- a/ocaml/stdlib/Makefile +++ b/ocaml/stdlib/Makefile @@ -220,6 +220,29 @@ stdlib.cmx: stdlib.ml -pp "$(AWK) -f ./expand_module_aliases.awk" -c $< +# special cases to add the extension flag when compiling float_u +# CR layouts: eventually these can be just [-extension layouts] +stdlib__Float_u.cmi: + $(CAMLC) $(COMPFLAGS) -extension layouts_alpha \ + -o $@ -c $(filter %.mli, $^) + +stdlib__Float_u.cmo: + $(CAMLC) $(COMPFLAGS) -extension layouts_alpha \ + -o $@ -c $(filter %.ml, $^) + +stdlib__Float_u.cmx: + $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) -extension layouts_alpha \ + -o $@ -c $(filter %.ml, $^) + +float_u.cmi: %.mli + $(CAMLC) $(COMPFLAGS) -extension layouts_alpha -c $< + +float_u.cmo: %.ml + $(CAMLC) $(COMPFLAGS) -extension layouts_alpha -c $< + +float_u.cmx: %.ml + $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) -extension layouts_alpha -c $< + %.cmi: %.mli $(CAMLC) $(COMPFLAGS) -c $< diff --git a/ocaml/stdlib/StdlibModules b/ocaml/stdlib/StdlibModules index 1d22a1f80ce..0861672f7e8 100644 --- a/ocaml/stdlib/StdlibModules +++ b/ocaml/stdlib/StdlibModules @@ -38,7 +38,7 @@ STDLIB_MODULE_BASENAMES = \ stdlib pervasives either \ sys obj camlinternalLazy lazy \ seq option result bool char uchar \ - list int bytes string unit marshal array iarray float int32 int64 nativeint \ + list int bytes string unit marshal array iarray float float_u int32 int64 nativeint \ lexing parsing set map stack queue stream buffer \ camlinternalFormat printf arg atomic \ printexc fun gc digest random hashtbl weak \ diff --git a/ocaml/stdlib/dune b/ocaml/stdlib/dune index 7ad3a3905e7..74793e5e4cf 100644 --- a/ocaml/stdlib/dune +++ b/ocaml/stdlib/dune @@ -43,6 +43,7 @@ (install (files Makefile.config + ocaml_compiler_internal_params camlheader camlheaderd @@ -104,6 +105,8 @@ filename.mli float.ml float.mli + float_u.ml + float_u.mli format.ml format.mli fun.ml @@ -240,6 +243,9 @@ .stdlib.objs/byte/stdlib__Float.cmi .stdlib.objs/byte/stdlib__Float.cmt .stdlib.objs/byte/stdlib__Float.cmti + .stdlib.objs/byte/stdlib__Float_u.cmi + .stdlib.objs/byte/stdlib__Float_u.cmt + .stdlib.objs/byte/stdlib__Float_u.cmti .stdlib.objs/byte/stdlib__Format.cmi .stdlib.objs/byte/stdlib__Format.cmt .stdlib.objs/byte/stdlib__Format.cmti @@ -413,6 +419,7 @@ .stdlib.objs/native/stdlib__StdLabels.cmx .stdlib.objs/native/stdlib__Weak.cmx .stdlib.objs/native/stdlib__Float.cmx + .stdlib.objs/native/stdlib__Float_u.cmx .stdlib.objs/native/stdlib__Pervasives.cmx .stdlib.objs/native/stdlib__Fun.cmx .stdlib.objs/native/stdlib__Bigarray.cmx diff --git a/ocaml/stdlib/float_u.ml b/ocaml/stdlib/float_u.ml new file mode 100644 index 00000000000..34ddc178547 --- /dev/null +++ b/ocaml/stdlib/float_u.ml @@ -0,0 +1,156 @@ +# 1 "float_u.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open! Stdlib + +[@@@ocaml.flambda_o3] + + +external to_float : float# -> (float[@local_opt]) = "%box_float" + +external of_float : (float[@local_opt]) -> float# = "%unbox_float" + +(* CR layouts: Investigate whether it's worth making these things externals. + Are there situations where the middle-end won't inline them and remove the + boxing/unboxing? *) + +let[@inline always] neg x = of_float (Float.neg (to_float x)) + +let[@inline always] add x y = of_float (Float.add (to_float x) (to_float y)) + +let[@inline always] sub x y = of_float (Float.sub (to_float x) (to_float y)) + +let[@inline always] mul x y = of_float (Float.mul (to_float x) (to_float y)) + +let[@inline always] div x y = of_float (Float.div (to_float x) (to_float y)) + +let[@inline always] fma x y z = of_float (Float.fma (to_float x) (to_float y) (to_float z)) + +let[@inline always] rem x y = of_float (Float.rem (to_float x) (to_float y)) + +let[@inline always] succ x = of_float (Float.succ (to_float x)) + +let[@inline always] pred x = of_float (Float.pred (to_float x)) + +let[@inline always] abs x = of_float (Float.abs (to_float x)) + +let[@inline always] is_finite x = Float.is_finite (to_float x) + +let[@inline always] is_infinite x = Float.is_infinite (to_float x) + +let[@inline always] is_nan x = Float.is_nan (to_float x) + +let[@inline always] is_integer x = Float.is_integer (to_float x) + +let[@inline always] of_int x = of_float (Float.of_int x) + +let[@inline always] to_int x = Float.to_int (to_float x) + +let[@inline always] of_string x = of_float (Float.of_string x) + +let[@inline always] to_string x = Float.to_string (to_float x) + +type fpclass = Stdlib.fpclass = + FP_normal + | FP_subnormal + | FP_zero + | FP_infinite + | FP_nan + +let[@inline always] classify_float x = Float.classify_float (to_float x) + +let[@inline always] pow x y = of_float (Float.pow (to_float x) (to_float y)) + +let[@inline always] sqrt x = of_float (Float.sqrt (to_float x)) + +let[@inline always] cbrt x = of_float (Float.cbrt (to_float x)) + +let[@inline always] exp x = of_float (Float.exp (to_float x)) + +let[@inline always] exp2 x = of_float (Float.exp2 (to_float x)) + +let[@inline always] log x = of_float (Float.log (to_float x)) + +let[@inline always] log10 x = of_float (Float.log10 (to_float x)) + +let[@inline always] log2 x = of_float (Float.log2 (to_float x)) + +let[@inline always] expm1 x = of_float (Float.expm1 (to_float x)) + +let[@inline always] log1p x = of_float (Float.log1p (to_float x)) + +let[@inline always] cos x = of_float (Float.cos (to_float x)) + +let[@inline always] sin x = of_float (Float.sin (to_float x)) + +let[@inline always] tan x = of_float (Float.tan (to_float x)) + +let[@inline always] acos x = of_float (Float.acos (to_float x)) + +let[@inline always] asin x = of_float (Float.asin (to_float x)) + +let[@inline always] atan x = of_float (Float.atan (to_float x)) + +let[@inline always] atan2 x y = of_float (Float.atan2 (to_float x) (to_float y)) + +let[@inline always] hypot x y = of_float (Float.hypot (to_float x) (to_float y)) + +let[@inline always] cosh x = of_float (Float.cosh (to_float x)) + +let[@inline always] sinh x = of_float (Float.sinh (to_float x)) + +let[@inline always] tanh x = of_float (Float.tanh (to_float x)) + +let[@inline always] acosh x = of_float (Float.acosh (to_float x)) + +let[@inline always] asinh x = of_float (Float.asinh (to_float x)) + +let[@inline always] atanh x = of_float (Float.atanh (to_float x)) + +let[@inline always] erf x = of_float (Float.erf (to_float x)) + +let[@inline always] erfc x = of_float (Float.erfc (to_float x)) + +let[@inline always] trunc x = of_float (Float.trunc (to_float x)) + +let[@inline always] round x = of_float (Float.round (to_float x)) + +let[@inline always] ceil x = of_float (Float.ceil (to_float x)) + +let[@inline always] floor x = of_float (Float.floor (to_float x)) + +let[@inline always] next_after x y = of_float (Float.next_after (to_float x) (to_float y)) + +let[@inline always] copy_sign x y = of_float (Float.copy_sign (to_float x) (to_float y)) + +let[@inline always] sign_bit x = Float.sign_bit (to_float x) + +let[@inline always] ldexp x i = of_float (Float.ldexp (to_float x) i) + +type t = float# + +let[@inline always] compare x y = Float.compare (to_float x) (to_float y) + +let[@inline always] equal x y = Float.equal (to_float x) (to_float y) + +let[@inline always] min x y = of_float (Float.min (to_float x) (to_float y)) + +let[@inline always] max x y = of_float (Float.max (to_float x) (to_float y)) + +let[@inline always] min_num x y = of_float (Float.min_num (to_float x) (to_float y)) + +let[@inline always] max_num x y = of_float (Float.max_num (to_float x) (to_float y)) diff --git a/ocaml/stdlib/float_u.mli b/ocaml/stdlib/float_u.mli new file mode 100644 index 00000000000..6eaf8f74d6f --- /dev/null +++ b/ocaml/stdlib/float_u.mli @@ -0,0 +1,349 @@ +# 1 "float_u.mli" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open! Stdlib + +(* CR layouts v4: This file is based on [float.mli], which itself is generated + from [float.template.mli]. That file is generated to deal with labels in the + Array submodule, which we don't have here, so I haven't done something + similar. If we have an Array submodule here in the future, reconsider. *) + +(* CR layouts: This module is not included in the [Stdlib] module, much like + IArray. This is intended to be a speed bump so that people won't + accidentally rely on it in public release code. Eventually, we plan to move + it out of the stdlib library and into a new otherlib. *) + +(** Unboxed floating-point arithmetic. This file primarily duplicates + functionality from the [Float] module, but for [float#]. + + OCaml's floating-point numbers follow the + IEEE 754 standard, using double precision (64 bits) numbers. + Floating-point operations never raise an exception on overflow, + underflow, division by zero, etc. Instead, special IEEE numbers + are returned as appropriate, such as [infinity] for [1.0 /. 0.0], + [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') + for [0.0 /. 0.0]. These special numbers then propagate through + floating-point computations as expected: for instance, + [1.0 /. infinity] is [0.0], basic arithmetic operations + ([+.], [-.], [*.], [/.]) with [nan] as an argument return [nan], ... +*) + +(* CR layouts v5: add back all the constants in this module (e.g., [zero] and + [infinity]) when we we support [float64]s in structures. *) + +(* Unboxed-specific stuff at the top. *) +external to_float : float# -> (float[@local_opt]) = "%box_float" +(** Box a [float#] *) + +external of_float : (float[@local_opt]) -> float# = "%unbox_float" +(** Unbox a boxed [float] *) + +(* Below here, everything also appears in [Float], though most things are + externals in that module. *) + +val neg : float# -> float# +(** Unary negation. *) + +val add : float# -> float# -> float# +(** Floating-point addition. *) + +val sub : float# -> float# -> float# +(** Floating-point subtraction. *) + +val mul : float# -> float# -> float# +(** Floating-point multiplication. *) + +val div : float# -> float# -> float# +(** Floating-point division. *) + +val fma : float# -> float# -> float# -> float# +(** [fma x y z] returns [x * y + z], with a best effort for computing + this expression with a single rounding, using either hardware + instructions (providing full IEEE compliance) or a software + emulation. + + On 64-bit Cygwin, 64-bit mingw-w64 and MSVC 2017 and earlier, this function + may be emulated owing to known bugs on limitations on these platforms. + Note: since software emulation of the fma is costly, make sure that you are + using hardware fma support if performance matters. *) + +val rem : float# -> float# -> float# +(** [rem a b] returns the remainder of [a] with respect to [b]. The returned + value is [a -. n *. b], where [n] is the quotient [a /. b] rounded towards + zero to an integer. *) + +val succ : float# -> float# +(** [succ x] returns the floating point number right after [x] i.e., + the smallest floating-point number greater than [x]. See also + {!next_after}. *) + +val pred : float# -> float# +(** [pred x] returns the floating-point number right before [x] i.e., + the greatest floating-point number smaller than [x]. See also + {!next_after}. *) + +val abs : float# -> float# +(** [abs f] returns the absolute value of [f]. *) + +val is_finite : float# -> bool +(** [is_finite x] is [true] if and only if [x] is finite i.e., not infinite and + not {!nan}. *) + +val is_infinite : float# -> bool +(** [is_infinite x] is [true] if and only if [x] is {!infinity} or + {!neg_infinity}. *) + +val is_nan : float# -> bool +(** [is_nan x] is [true] if and only if [x] is not a number (see {!nan}). *) + + +val is_integer : float# -> bool +(** [is_integer x] is [true] if and only if [x] is an integer. *) + + +val of_int : int -> float# +(** Convert an integer to floating-point. *) + +val to_int : float# -> int +(** Truncate the given floating-point number to an integer. + The result is unspecified if the argument is [nan] or falls outside the + range of representable integers. *) + +val of_string : string -> float# +(** Convert the given string to a float. The string is read in decimal + (by default) or in hexadecimal (marked by [0x] or [0X]). + The format of decimal floating-point numbers is + [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. + The format of hexadecimal floating-point numbers is + [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an + hexadecimal digit and [d] for a decimal digit. + In both cases, at least one of the integer and fractional parts must be + given; the exponent part is optional. + The [_] (underscore) character can appear anywhere in the string + and is ignored. + Depending on the execution platforms, other representations of + floating-point numbers can be accepted, but should not be relied upon. + @raise Failure if the given string is not a valid + representation of a float. *) + +(* CR layouts v5: Add [of_string_opt] when we allow float64s in structures. *) + +val to_string : float# -> string +(** Return a string representation of a floating-point number. + + This conversion can involve a loss of precision. For greater control over + the manner in which the number is printed, see {!Printf}. + + This function is an alias for {!Stdlib.string_of_float}. *) + +type fpclass = Stdlib.fpclass = + FP_normal (** Normal number, none of the below *) + | FP_subnormal (** Number very close to 0.0, has reduced precision *) + | FP_zero (** Number is 0.0 or -0.0 *) + | FP_infinite (** Number is positive or negative infinity *) + | FP_nan (** Not a number: result of an undefined operation *) +(** The five classes of floating-point numbers, as determined by + the {!classify_float} function. *) + +val classify_float : float# -> fpclass +(** Return the class of the given floating-point number: + normal, subnormal, zero, infinite, or not a number. *) + +val pow : float# -> float# -> float# +(** Exponentiation. *) + +val sqrt : float# -> float# +(** Square root. *) + +val cbrt : float# -> float# +(** Cube root. *) + +val exp : float# -> float# +(** Exponential. *) + +val exp2 : float# -> float# +(** Base 2 exponential function. *) + +val log : float# -> float# +(** Natural logarithm. *) + +val log10 : float# -> float# +(** Base 10 logarithm. *) + +val log2 : float# -> float# +(** Base 2 logarithm. *) + +val expm1 : float# -> float# +(** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results + even if [x] is close to [0.0]. *) + +val log1p : float# -> float# +(** [log1p x] computes [log(1.0 +. x)] (natural logarithm), + giving numerically-accurate results even if [x] is close to [0.0]. *) + +val cos : float# -> float# +(** Cosine. Argument is in radians. *) + +val sin : float# -> float# +(** Sine. Argument is in radians. *) + +val tan : float# -> float# +(** Tangent. Argument is in radians. *) + +val acos : float# -> float# +(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. + Result is in radians and is between [0.0] and [pi]. *) + +val asin : float# -> float# +(** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. + Result is in radians and is between [-pi/2] and [pi/2]. *) + +val atan : float# -> float# +(** Arc tangent. + Result is in radians and is between [-pi/2] and [pi/2]. *) + +val atan2 : float# -> float# -> float# +(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] + and [y] are used to determine the quadrant of the result. + Result is in radians and is between [-pi] and [pi]. *) + +val hypot : float# -> float# -> float# +(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length + of the hypotenuse of a right-angled triangle with sides of length + [x] and [y], or, equivalently, the distance of the point [(x,y)] + to origin. If one of [x] or [y] is infinite, returns [infinity] + even if the other is [nan]. *) + +val cosh : float# -> float# +(** Hyperbolic cosine. Argument is in radians. *) + +val sinh : float# -> float# +(** Hyperbolic sine. Argument is in radians. *) + +val tanh : float# -> float# +(** Hyperbolic tangent. Argument is in radians. *) + +val acosh : float# -> float# +(** Hyperbolic arc cosine. The argument must fall within the range + [[1.0, inf]]. + Result is in radians and is between [0.0] and [inf]. *) + +val asinh : float# -> float# +(** Hyperbolic arc sine. The argument and result range over the entire + real line. + Result is in radians. *) + +val atanh : float# -> float# +(** Hyperbolic arc tangent. The argument must fall within the range + [[-1.0, 1.0]]. + Result is in radians and ranges over the entire real line. *) + +val erf : float# -> float# +(** Error function. The argument ranges over the entire real line. + The result is always within [[-1.0, 1.0]]. *) + +val erfc : float# -> float# +(** Complementary error function ([erfc x = 1 - erf x]). + The argument ranges over the entire real line. + The result is always within [[-1.0, 1.0]]. *) + +val trunc : float# -> float# +(** [trunc x] rounds [x] to the nearest integer whose absolute value is + less than or equal to [x]. *) + +val round : float# -> float# +(** [round x] rounds [x] to the nearest integer with ties (fractional + values of 0.5) rounded away from zero, regardless of the current + rounding direction. If [x] is an integer, [+0.], [-0.], [nan], or + infinite, [x] itself is returned. + + On 64-bit mingw-w64, this function may be emulated owing to a bug in the + C runtime library (CRT) on this platform. *) + +val ceil : float# -> float# +(** Round above to an integer value. + [ceil f] returns the least integer value greater than or equal to [f]. + The result is returned as a float. *) + +val floor : float# -> float# +(** Round below to an integer value. + [floor f] returns the greatest integer value less than or + equal to [f]. + The result is returned as a float. *) + +val next_after : float# -> float# -> float# +(** [next_after x y] returns the next representable floating-point + value following [x] in the direction of [y]. More precisely, if + [y] is greater (resp. less) than [x], it returns the smallest + (resp. largest) representable number greater (resp. less) than [x]. + If [x] equals [y], the function returns [y]. If [x] or [y] is + [nan], a [nan] is returned. + Note that [next_after max_float infinity = infinity] and that + [next_after 0. infinity] is the smallest denormalized positive number. + If [x] is the smallest denormalized positive number, + [next_after x 0. = 0.] *) + +val copy_sign : float# -> float# -> float# +(** [copy_sign x y] returns a float whose absolute value is that of [x] + and whose sign is that of [y]. If [x] is [nan], returns [nan]. + If [y] is [nan], returns either [x] or [-. x], but it is not + specified which. *) + +val sign_bit : float# -> bool +(** [sign_bit x] is [true] if and only if the sign bit of [x] is set. + For example [sign_bit 1.] and [signbit 0.] are [false] while + [sign_bit (-1.)] and [sign_bit (-0.)] are [true]. *) + +(* CR layouts v5: add back [frexp], [modf], [min_max] and [min_max_num] when we + have floats in structures. *) + +val ldexp : float# -> int -> float# +(** [ldexp x n] returns [x *. 2 ** n]. *) + +type t = float# +(** An alias for the type of floating-point numbers. *) + +val compare: t -> t -> int +(** [compare x y] returns [0] if [x] is equal to [y], a negative integer if [x] + is less than [y], and a positive integer if [x] is greater than + [y]. [compare] treats [nan] as equal to itself and less than any other float + value. This treatment of [nan] ensures that [compare] defines a total + ordering relation. *) + +val equal: t -> t -> bool +(** The equal function for floating-point numbers, compared using {!compare}. *) + +val min : t -> t -> t +(** [min x y] returns the minimum of [x] and [y]. It returns [nan] + when [x] or [y] is [nan]. Moreover [min (-0.) (+0.) = -0.] *) + +val max : float# -> float# -> float# +(** [max x y] returns the maximum of [x] and [y]. It returns [nan] + when [x] or [y] is [nan]. Moreover [max (-0.) (+0.) = +0.] *) + +val min_num : t -> t -> t +(** [min_num x y] returns the minimum of [x] and [y] treating [nan] as + missing values. If both [x] and [y] are [nan], [nan] is returned. + Moreover [min_num (-0.) (+0.) = -0.] *) + +val max_num : t -> t -> t +(** [max_num x y] returns the maximum of [x] and [y] treating [nan] as + missing values. If both [x] and [y] are [nan] [nan] is returned. + Moreover [max_num (-0.) (+0.) = +0.] *) + +(* CR layouts v5: add back hash when we deal with the ad-hoc polymorphic + functions. *) diff --git a/ocaml/stdlib/ocaml_compiler_internal_params b/ocaml/stdlib/ocaml_compiler_internal_params new file mode 100644 index 00000000000..e4160e63c43 --- /dev/null +++ b/ocaml/stdlib/ocaml_compiler_internal_params @@ -0,0 +1,2 @@ +ocaml/stdlib/float_u.mli : extension = layouts_alpha +ocaml/stdlib/float_u.ml : extension = layouts_alpha diff --git a/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml b/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml index eba22c61adb..816db8b5ddb 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml @@ -6,30 +6,15 @@ (* A test comparing allocations with unboxed floats to allocations with boxed floats. *) -(* CR layouts v2: Delete this `Float_u` module and use the one we add to the - standard library instead. *) -module type Float_u = sig - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - val ( + ) : float# -> float# -> float# - val ( - ) : float# -> float# -> float# - val ( * ) : float# -> float# -> float# - val ( / ) : float# -> float# -> float# - val ( ** ) : float# -> float# -> float# - val ( > ) : float# -> float# -> bool -end - -module Float_u : Float_u = struct - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - let ( + ) x y = of_float ((to_float x) +. (to_float y)) - let ( - ) x y = of_float ((to_float x) -. (to_float y)) - let ( * ) x y = of_float ((to_float x) *. (to_float y)) - let ( / ) x y = of_float ((to_float x) /. (to_float y)) - let ( ** ) x y = of_float ((to_float x) ** (to_float y)) - let ( > ) x y = (to_float x) > (to_float y) +module Float_u = struct + include Stdlib__Float_u + + let ( + ) = add + let ( - ) = sub + let ( * ) = mul + let ( / ) = div + let ( ** ) = pow + let ( > ) x y = (compare x y) > 0 end let alloc = ref 0.0 diff --git a/ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u_alpha.ml b/ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u_alpha.ml new file mode 100644 index 00000000000..866ea45f55b --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u_alpha.ml @@ -0,0 +1,269 @@ +(* TEST + flags = "-extension layouts_alpha" +*) + +module Float_u = Stdlib__Float_u + +(* Constant seed for repeatable random-testing properties *) +let () = Random.init 1234 + +type 'a result = { + actual : 'a; + expected : 'a; + equal : 'a -> 'a -> bool; + to_string : 'a -> string +} + +let float_result ~actual ~expected = { + actual; + expected; + equal = Float.equal; + to_string = Float.to_string; +} + +let bool_result ~actual ~expected = { + actual; + expected; + equal = Bool.equal; + to_string = Bool.to_string; +} + +let int_result ~actual ~expected = { + actual; + expected; + equal = Int.equal; + to_string = Int.to_string; +} + +let string_result ~actual ~expected = { + actual; + expected; + equal = String.equal; + to_string = fun x -> x; +} + +let fpclass_to_string = function + FP_normal -> "FP_normal" + | FP_subnormal -> "FP_subnormal" + | FP_zero -> "FP_zero" + | FP_infinite -> "FP_infinite" + | FP_nan -> "FP_nan" + +let fpclass_result ~actual ~expected = { + actual; + expected; + equal = (=); + to_string = fpclass_to_string; +} + +let interesting_floats = + [ 0.; 1.; -1.; Float.max_float; Float.min_float; Float.epsilon; + Float.nan; Float.infinity; Float.neg_infinity ] + +let interesting_ints = [ 0; 1; -1; Int.max_int; Int.min_int ] + +let default_min = -10000. +let default_max = 10000. + +let floats_in_range ~num min max = + (* Generating well-distributed random floats in a range is obviously hard. + The "in a range" part is important because many float functions are only + defined on certain ranges. I'm not trying very hard, here - this should + only be used with min and max that aren't at the outer limits of the float + range. *) + let float_in_range () = + let f = Random.float 1000. in + let f = f *. ((max -. min) /. 1000.) in + f +. min + in + List.init num (fun _ -> float_in_range ()) + +let float_inputs ~range ~num = + let min, max = + match range with + | None -> default_min, default_max + | Some (min, max) -> min, max + in + let input = floats_in_range ~num min max in + let input = + if Option.is_none range then interesting_floats @ input else input + in + input + +let string_inputs ~num = + List.map Float.to_string (float_inputs ~range:None ~num) + +let int_inputs ~num = + let gen_int _ = (Random.full_int Int.max_int) - (Int.max_int / 2) in + interesting_ints @ List.init num gen_int + +let passed { actual; expected; equal; _ } = equal actual expected + +let test inputs input_to_string name prop = + let test x = + let {expected; actual; to_string} as result = prop x in + if not (passed result) + then + Printf.printf "Test failed: %s. Input = %s; expected = %s; actual = %s\n" + name (input_to_string x) (to_string expected) (to_string actual) + in + List.iter test inputs + +(* zips that truncate *) +let rec zip l1 l2 = + match l1, l2 with + | x1 :: l1, x2 :: l2 -> (x1, x2) :: zip l1 l2 + | _ -> [] + +let rec zip3 l1 l2 l3 = + match l1, l2, l3 with + | x1 :: l1, x2 :: l2, x3 :: l3 -> (x1, x2, x3) :: zip3 l1 l2 l3 + | _ -> [] + +(* These run a property on inputs and check the result *) +let test_unary ?range name prop = + let inputs = float_inputs ~range ~num:10 in + let input_to_string = Float.to_string in + test inputs input_to_string name prop + +let test_unary_int ?range name prop = + let inputs = int_inputs ~num:10 in + let input_to_string = Int.to_string in + test inputs input_to_string name prop + +let test_unary_string ?range name prop = + let inputs = string_inputs ~num:10 in + let input_to_string x = x in + test inputs input_to_string name prop + +let test_binary ?range name prop = + let input1 = float_inputs ~range ~num:20 in + let input2 = List.rev (float_inputs ~range ~num:20) in + let inputs = zip input1 (List.rev input2) in + let input_to_string (f1,f2) = Printf.sprintf "(%f, %f)" f1 f2 in + test inputs input_to_string name prop + +let test_binary_float_int ?range name prop = + let input1 = float_inputs ~range ~num:20 in + let input2 = List.rev (int_inputs ~num:20) in + let inputs = zip input1 (List.rev input2) in + let input_to_string (f1,f2) = Printf.sprintf "(%f, %d)" f1 f2 in + test inputs input_to_string name prop + +let test_ternary ?range name prop = + let input1 = float_inputs ~range ~num:30 in + let input2 = float_inputs ~range ~num:30 in + let input3 = List.rev (float_inputs ~range ~num:30) in + let inputs = zip3 input1 input2 input3 in + let input_to_string (f1, f2, f3) = Printf.sprintf "(%f, %f, %f)" f1 f2 f3 in + test inputs input_to_string name prop + +(* These make the property to be tested for various arities and types *) +let mk1 expected_f actual_f arg = + let expected = expected_f arg in + let actual = Float_u.to_float (actual_f (Float_u.of_float arg)) in + float_result ~actual ~expected + +let mk2 expected_f actual_f (arg1, arg2) = + let expected = expected_f arg1 arg2 in + let actual = + Float_u.to_float + (actual_f (Float_u.of_float arg1) (Float_u.of_float arg2)) + in + float_result ~actual ~expected + +let mk3 expected_f actual_f (arg1, arg2, arg3) = + let expected = expected_f arg1 arg2 arg3 in + let actual = + Float_u.to_float + (actual_f (Float_u.of_float arg1) (Float_u.of_float arg2) + (Float_u.of_float arg3)) + in + float_result ~actual ~expected + +let mk_float_X result expected_f actual_f arg = + let expected = expected_f arg in + let actual = actual_f (Float_u.of_float arg) in + result ~actual ~expected + +let mk_X_float expected_f actual_f arg = + let expected = expected_f arg in + let actual = Float_u.to_float (actual_f arg) in + float_result ~actual ~expected + +let mk_float_X_float expected_f actual_f (arg1, arg2) = + let expected = expected_f arg1 arg2 in + let actual = Float_u.to_float (actual_f (Float_u.of_float arg1) arg2) in + float_result ~actual ~expected + +let mk_float_float_X result expected_f actual_f (arg1, arg2) = + let expected = expected_f arg1 arg2 in + let actual = actual_f (Float_u.of_float arg1) (Float_u.of_float arg2) in + result ~actual ~expected + +let () = + test_unary "neg" (mk1 Float.neg Float_u.neg); + test_binary "add" (mk2 Float.add Float_u.add); + test_binary "sub" (mk2 Float.sub Float_u.sub); + test_binary "mul" (mk2 Float.mul Float_u.mul); + test_binary "div" (mk2 Float.div Float_u.div); + test_ternary "fma" (mk3 Float.fma Float_u.fma); + test_binary "rem" (mk2 Float.rem Float_u.rem); + test_unary "succ" (mk1 Float.succ Float_u.succ); + test_unary "pred" (mk1 Float.pred Float_u.pred); + test_unary "abs" (mk1 Float.abs Float_u.abs); + test_unary "is_finite" + (mk_float_X bool_result Float.is_finite Float_u.is_finite); + test_unary "is_nan" (mk_float_X bool_result Float.is_nan Float_u.is_nan); + test_unary "is_integer" + (mk_float_X bool_result Float.is_integer Float_u.is_integer); + test_unary_int "of_int" (mk_X_float Float.of_int Float_u.of_int); + test_unary "to_int" (mk_float_X int_result Float.to_int Float_u.to_int); + test_unary_string "of_string" (mk_X_float Float.of_string Float_u.of_string); + test_unary "to_string" + (mk_float_X string_result Float.to_string Float_u.to_string); + test_unary "classify_float" + (mk_float_X fpclass_result Float.classify_float Float_u.classify_float); + test_binary "pow" (mk2 Float.pow Float_u.pow); + test_unary "sqt" (mk1 Float.sqrt Float_u.sqrt); + test_unary "cbrt" (mk1 Float.cbrt Float_u.cbrt); + test_unary "exp" (mk1 Float.exp Float_u.exp); + test_unary "exp2" (mk1 Float.exp2 Float_u.exp2); + test_unary "log" (mk1 Float.log Float_u.log); + test_unary "log10" (mk1 Float.log10 Float_u.log10); + test_unary "log2" (mk1 Float.log2 Float_u.log2); + test_unary "log1p" (mk1 Float.log1p Float_u.log1p); + test_unary "cos" (mk1 Float.cos Float_u.cos); + test_unary "sin" (mk1 Float.sin Float_u.sin); + test_unary "tan" (mk1 Float.tan Float_u.tan); + test_unary "acos" ~range:(-1.0, 1.0) (mk1 Float.acos Float_u.acos); + test_unary "asin" ~range:(-1.0, 1.0) (mk1 Float.asin Float_u.asin); + test_unary "atan" (mk1 Float.atan Float_u.atan); + test_binary "atan2" (mk2 Float.atan2 Float_u.atan2); + test_binary "hypot" (mk2 Float.hypot Float_u.hypot); + test_unary "cosh" (mk1 Float.cosh Float_u.cosh); + test_unary "sinh" (mk1 Float.sinh Float_u.sinh); + test_unary "tanh" (mk1 Float.tanh Float_u.tanh); + test_unary "acosh" ~range:(1.0, Float.infinity) + (mk1 Float.acosh Float_u.acosh); + test_unary "asinh" (mk1 Float.asinh Float_u.asinh); + test_unary "atanh" ~range:(-1.0, 1.0) (mk1 Float.atanh Float_u.atanh); + test_unary "erf" (mk1 Float.erf Float_u.erf); + test_unary "erfc" (mk1 Float.erfc Float_u.erfc); + test_unary "trunk" (mk1 Float.trunc Float_u.trunc); + test_unary "round" (mk1 Float.round Float_u.round); + test_unary "ceil" (mk1 Float.ceil Float_u.ceil); + test_unary "floor" (mk1 Float.floor Float_u.floor); + test_binary "next_after" (mk2 Float.next_after Float_u.next_after); + test_binary "copy_sign" (mk2 Float.copy_sign Float_u.copy_sign); + test_unary "sign_bit" + (mk_float_X bool_result Float.sign_bit Float_u.sign_bit); + test_binary_float_int "ldexp" (mk_float_X_float Float.ldexp Float_u.ldexp); + test_binary "compare" + (mk_float_float_X int_result Float.compare Float_u.compare); + test_binary "equal" + (mk_float_float_X bool_result Float.equal Float_u.equal); + test_binary "min" (mk2 Float.min Float_u.min); + test_binary "max" (mk2 Float.max Float_u.max); + test_binary "min_num" (mk2 Float.min_num Float_u.min_num); + test_binary "max_num" (mk2 Float.max_num Float_u.max_num); diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference index bdd5cc8d3fe..c89d2a2a147 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference @@ -1,4 +1,4 @@ -File "unboxed_floats.ml", line 21, characters 22-28: -21 | external to_float : float# -> (float[@local_opt]) = "%box_float" - ^^^^^^ -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +File "unboxed_floats.ml", line 74, characters 11-18: +74 | type ('a : float64) t_float64 = 'a + ^^^^^^^ +Error: Layout float64 is used here, but the appropriate layouts extension is not enabled diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml index fde0cc869ca..e715f44f62b 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml @@ -17,35 +17,17 @@ (*****************************************) (* Prelude: Functions on unboxed floats. *) -module type Float_u = sig - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - val ( + ) : float# -> float# -> float# - val ( - ) : float# -> float# -> float# - val ( * ) : float# -> float# -> float# - val ( / ) : float# -> float# -> float# - val ( ** ) : float# -> float# -> float# - val ( > ) : float# -> float# -> bool +module Float_u = struct + include Stdlib__Float_u + + let ( + ) = add + let ( - ) = sub + let ( * ) = mul + let ( / ) = div + let ( ** ) = pow + let ( > ) x y = (compare x y) > 0 end -module Float_u : Float_u = struct - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - (* We may in the future add primitives for these, but for now this has proven - to be good enough - the boxing/unboxing is eliminated on all - middle-ends. *) - let[@inline always] ( + ) x y = of_float ((to_float x) +. (to_float y)) - let[@inline always] ( - ) x y = of_float ((to_float x) -. (to_float y)) - let[@inline always] ( * ) x y = of_float ((to_float x) *. (to_float y)) - let[@inline always] ( / ) x y = of_float ((to_float x) /. (to_float y)) - let[@inline always] ( ** ) x y = of_float ((to_float x) ** (to_float y)) - let[@inline always] ( > ) x y = (to_float x) > (to_float y) -end - -(* CR layouts v2: move this into a stand-alone [Float_u] module *) - (*********************************) (* Test 1: some basic arithmetic *) diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml index 6f1a5a6d1f9..bde12e86733 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml @@ -11,35 +11,17 @@ (*****************************************) (* Prelude: Functions on unboxed floats. *) -module type Float_u = sig - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - val ( + ) : float# -> float# -> float# - val ( - ) : float# -> float# -> float# - val ( * ) : float# -> float# -> float# - val ( / ) : float# -> float# -> float# - val ( ** ) : float# -> float# -> float# - val ( > ) : float# -> float# -> bool +module Float_u = struct + include Stdlib__Float_u + + let ( + ) = add + let ( - ) = sub + let ( * ) = mul + let ( / ) = div + let ( ** ) = pow + let ( > ) x y = (compare x y) > 0 end -module Float_u : Float_u = struct - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - (* We may in the future add primitives for these, but for now this has proven - to be good enough - the boxing/unboxing is eliminated on all - middle-ends. *) - let[@inline always] ( + ) x y = of_float ((to_float x) +. (to_float y)) - let[@inline always] ( - ) x y = of_float ((to_float x) -. (to_float y)) - let[@inline always] ( * ) x y = of_float ((to_float x) *. (to_float y)) - let[@inline always] ( / ) x y = of_float ((to_float x) /. (to_float y)) - let[@inline always] ( ** ) x y = of_float ((to_float x) ** (to_float y)) - let[@inline always] ( > ) x y = (to_float x) > (to_float y) -end - -(* CR layouts v2: move this into a stand-alone [Float_u] module *) - (*********************************) (* Test 1: some basic arithmetic *) diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference index 6c4a93e135e..003bda1cb3b 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference @@ -1,4 +1,4 @@ -File "unboxed_floats_beta.ml", line 21, characters 22-28: -21 | external to_float : float# -> (float[@local_opt]) = "%box_float" - ^^^^^^ -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +File "unboxed_floats_beta.ml", line 74, characters 11-18: +74 | type ('a : float64) t_float64 = 'a + ^^^^^^^ +Error: Layout float64 is used here, but the appropriate layouts extension is not enabled diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml index 0032d72389f..490523454a7 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml @@ -17,35 +17,17 @@ (*****************************************) (* Prelude: Functions on unboxed floats. *) -module type Float_u = sig - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - val ( + ) : float# -> float# -> float# - val ( - ) : float# -> float# -> float# - val ( * ) : float# -> float# -> float# - val ( / ) : float# -> float# -> float# - val ( ** ) : float# -> float# -> float# - val ( > ) : float# -> float# -> bool +module Float_u = struct + include Stdlib__Float_u + + let ( + ) = add + let ( - ) = sub + let ( * ) = mul + let ( / ) = div + let ( ** ) = pow + let ( > ) x y = (compare x y) > 0 end -module Float_u : Float_u = struct - external to_float : float# -> (float[@local_opt]) = "%box_float" - external of_float : (float[@local_opt]) -> float# = "%unbox_float" - - (* We may in the future add primitives for these, but for now this has proven - to be good enough - the boxing/unboxing is eliminated on all - middle-ends. *) - let[@inline always] ( + ) x y = of_float ((to_float x) +. (to_float y)) - let[@inline always] ( - ) x y = of_float ((to_float x) -. (to_float y)) - let[@inline always] ( * ) x y = of_float ((to_float x) *. (to_float y)) - let[@inline always] ( / ) x y = of_float ((to_float x) /. (to_float y)) - let[@inline always] ( ** ) x y = of_float ((to_float x) ** (to_float y)) - let[@inline always] ( > ) x y = (to_float x) > (to_float y) -end - -(* CR layouts v2: move this into a stand-alone [Float_u] module *) - (*********************************) (* Test 1: some basic arithmetic *)