diff --git a/jscomp/common/lam_constant.ml b/jscomp/common/lam_constant.ml index 91ddf8768..3d4302f3d 100644 --- a/jscomp/common/lam_constant.ml +++ b/jscomp/common/lam_constant.ml @@ -51,6 +51,7 @@ type t = | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 + | Const_nativeint of nativeint | Const_pointer of string | Const_block of int * Lam_tag_info.t * t list | Const_float_array of string list @@ -75,6 +76,7 @@ let rec eq_approx (x : t) (y : t) = | _ -> false) | Const_float ix -> ( match y with Const_float iy -> ix = iy | _ -> false) | Const_int64 ix -> ( match y with Const_int64 iy -> ix = iy | _ -> false) + | Const_nativeint ix -> ( match y with Const_nativeint iy -> ix = iy | _ -> false) | Const_pointer ix -> ( match y with Const_pointer iy -> ix = iy | _ -> false) | Const_block (ix, _, ixs) -> ( diff --git a/jscomp/common/lam_constant.mli b/jscomp/common/lam_constant.mli index 4ba2dbe64..c3ebb859e 100644 --- a/jscomp/common/lam_constant.mli +++ b/jscomp/common/lam_constant.mli @@ -45,6 +45,7 @@ type t = | Const_string of { s : string; unicode : bool } | Const_float of string | Const_int64 of int64 + | Const_nativeint of nativeint | Const_pointer of string | Const_block of int * Lam_tag_info.t * t list | Const_float_array of string list diff --git a/jscomp/core/lam.ml b/jscomp/core/lam.ml index e1c765d10..c704e7500 100644 --- a/jscomp/core/lam.ml +++ b/jscomp/core/lam.ml @@ -687,6 +687,7 @@ let rec eval_const_as_bool (v : Constant.t) : bool = | Const_int { i = x; _ } -> x <> 0l | Const_char x -> Char.code x <> 0 | Const_int64 x -> x <> 0L + | Const_nativeint x -> x <> 0n | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined -> false | Const_js_true | Const_string _ | Const_pointer _ | Const_float _ diff --git a/jscomp/core/lam_analysis.ml b/jscomp/core/lam_analysis.ml index e64110cc7..4ca73928c 100644 --- a/jscomp/core/lam_analysis.ml +++ b/jscomp/core/lam_analysis.ml @@ -213,7 +213,7 @@ let rec size (lam : Lam.t) = and size_constant x = match x with - | Const_int _ | Const_char _ | Const_float _ | Const_int64 _ | Const_pointer _ + | Const_int _ | Const_char _ | Const_float _ | Const_int64 _ | Const_nativeint _ | Const_pointer _ | Const_js_null | Const_js_undefined | Const_module_alias | Const_js_true | Const_js_false -> 1 diff --git a/jscomp/core/lam_compile_const.ml b/jscomp/core/lam_compile_const.ml index 20716f10f..6e8e6b38b 100644 --- a/jscomp/core/lam_compile_const.ml +++ b/jscomp/core/lam_compile_const.ml @@ -70,6 +70,7 @@ and translate (x : Lam.Constant.t) : J.expression = (* E.float (Int64.to_string i) *) Js_long.of_const i (* https://github.com/google/closure-library/blob/master/closure%2Fgoog%2Fmath%2Flong.js *) + | Const_nativeint i -> Nativeint.to_int32 i |> E.int | Const_float f -> E.float f (* TODO: preserve float *) | Const_string { s; unicode = false } -> E.str s | Const_string { s; unicode = true } -> E.unicode s diff --git a/jscomp/core/lam_constant_convert.ml b/jscomp/core/lam_constant_convert.ml index 496ec881e..3716895b9 100644 --- a/jscomp/core/lam_constant_convert.ml +++ b/jscomp/core/lam_constant_convert.ml @@ -60,7 +60,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam.Constant.t = | Const_base (Const_float i, _) -> Const_float i | Const_base (Const_int32 i, _) -> Const_int { i; comment = None } | Const_base (Const_int64 i, _) -> Const_int64 i - | Const_base (Const_nativeint _, _) -> assert false + | Const_base (Const_nativeint i, _) -> Const_nativeint i | Const_float_array s -> Const_float_array s | Const_immstring s -> Const_string { s; unicode = false } | Const_block (i, t, xs) -> ( diff --git a/jscomp/core/lam_convert.cppo.ml b/jscomp/core/lam_convert.cppo.ml index efed27bb6..d1c824b6a 100644 --- a/jscomp/core/lam_convert.cppo.ml +++ b/jscomp/core/lam_convert.cppo.ml @@ -189,7 +189,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = Lam.prim ~primitive:(Pccall { prim_name = "caml_int_compare" }) ~args loc | Pcompare_floats -> Lam.prim ~primitive:(Pccall { prim_name = "caml_float_compare" }) ~args loc - | Pcompare_bints Pnativeint -> assert false + | Pcompare_bints Pnativeint -> + Lam.prim ~primitive:(Pccall {prim_name = "caml_nativeint_compare" }) ~args loc | Pcompare_bints Pint32 -> Lam.prim ~primitive:(Pccall { prim_name = "caml_int32_compare" }) ~args loc | Pcompare_bints Pint64 -> diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml index ea10be728..37f9e4ca4 100644 --- a/jscomp/core/lam_print.ml +++ b/jscomp/core/lam_print.ml @@ -26,6 +26,7 @@ let rec struct_const ppf (cst : Lam.Constant.t) = | Const_string { s; _ } -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_int64 n -> fprintf ppf "%LiL" n + | Const_nativeint n -> fprintf ppf "%nd" n | Const_pointer name -> fprintf ppf "`%s" name | Const_some n -> fprintf ppf "[some-c]%a" struct_const n | Const_block (tag, _, []) -> fprintf ppf "[%i]" tag diff --git a/jscomp/core/mel_ast_invariant.ml b/jscomp/core/mel_ast_invariant.ml index 2af92698c..689adcad9 100644 --- a/jscomp/core/mel_ast_invariant.ml +++ b/jscomp/core/mel_ast_invariant.ml @@ -43,10 +43,12 @@ let check_constant ~loc kind (const : Parsetree.constant) = *) try ignore (Int32.of_string s) with _ -> Location.prerr_warning loc Mel_integer_literal_overflow) - | Pconst_integer (_, Some 'n') -> - Location.raise_errorf ~loc - "`nativeint' is not currently supported in Melange. The `n' suffix \ - cannot be used." + | Pconst_integer (s, Some 'n') -> ( + (* Location.prerr_warning loc pf + "`nativeint' is not fully supported in Melange. The `n' suffix \ + should be avoided."; *) + try ignore (Nativeint.of_string s) + with _ -> Location.prerr_warning loc Mel_integer_literal_overflow) | _ -> () module Core_type = struct diff --git a/jscomp/stdlib/dune b/jscomp/stdlib/dune index 37e379912..61924395a 100644 --- a/jscomp/stdlib/dune +++ b/jscomp/stdlib/dune @@ -139,6 +139,12 @@ (action (run cppo -D=BS %{env:CPPO_FLAGS=} %{deps} -o %{target}))) +(rule + (deps nativeint.cppo.ml) + (target nativeint.ml) + (action + (run cppo -D=BS %{env:CPPO_FLAGS=} %{deps} -o %{target}))) + (rule (deps parsing.cppo.ml) (target parsing.ml) diff --git a/jscomp/stdlib/nativeint.cppo.ml b/jscomp/stdlib/nativeint.cppo.ml new file mode 100644 index 000000000..fc7036de0 --- /dev/null +++ b/jscomp/stdlib/nativeint.cppo.ml @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 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. *) +(* *) +(**************************************************************************) + +(* Module [Nativeint]: processor-native integers *) + +external neg: nativeint -> nativeint = "%nativeint_neg" +external add: nativeint -> nativeint -> nativeint = "%nativeint_add" +external sub: nativeint -> nativeint -> nativeint = "%nativeint_sub" +external mul: nativeint -> nativeint -> nativeint = "%nativeint_mul" +external div: nativeint -> nativeint -> nativeint = "%nativeint_div" +external rem: nativeint -> nativeint -> nativeint = "%nativeint_mod" +external logand: nativeint -> nativeint -> nativeint = "%nativeint_and" +external logor: nativeint -> nativeint -> nativeint = "%nativeint_or" +external logxor: nativeint -> nativeint -> nativeint = "%nativeint_xor" +external shift_left: nativeint -> int -> nativeint = "%nativeint_lsl" +external shift_right: nativeint -> int -> nativeint = "%nativeint_asr" +external shift_right_logical: nativeint -> int -> nativeint = "%nativeint_lsr" +external of_int: int -> nativeint = "%nativeint_of_int" +external to_int: nativeint -> int = "%nativeint_to_int" +external of_float : float -> nativeint + = "caml_nativeint_of_float" "caml_nativeint_of_float_unboxed" + [@@unboxed] [@@noalloc] +external to_float : nativeint -> float + = "caml_nativeint_to_float" "caml_nativeint_to_float_unboxed" + [@@unboxed] [@@noalloc] +external of_int32: int32 -> nativeint = "%nativeint_of_int32" +external to_int32: nativeint -> int32 = "%nativeint_to_int32" + +let zero = 0n +let one = 1n +let minus_one = -1n +let succ n = add n 1n +let pred n = sub n 1n +let abs n = if n >= 0n then n else neg n +let size = Sys.word_size +let min_int = shift_left 1n (size - 1) +let max_int = sub min_int 1n +let lognot n = logxor n (-1n) + +let unsigned_to_int = + let max_int = of_int Stdlib.max_int in + fun n -> + if n >= 0n && n <= max_int then + Some (to_int n) + else + None + +external format : string -> nativeint -> string = "caml_nativeint_format" +let to_string n = format "%d" n + +external of_string: string -> nativeint = "caml_nativeint_of_string" + +let of_string_opt s = + try Some (of_string s) + with Failure _ -> None + +type t = nativeint + +let compare (x: t) (y: t) = Stdlib.compare x y +let equal (x: t) (y: t) = compare x y = 0 + +let unsigned_compare n m = + compare (sub n min_int) (sub m min_int) + +let unsigned_lt n m = + sub n min_int < sub m min_int + +let min x y : t = if x <= y then x else y +let max x y : t = if x >= y then x else y + +(* Unsigned division from signed division of the same bitness. + See Warren Jr., Henry S. (2013). Hacker's Delight (2 ed.), Sec 9-3. +*) +let unsigned_div n d = + if d < zero then + if unsigned_lt n d then zero else one + else + let q = shift_left (div (shift_right_logical n 1) d) 1 in + let r = sub n (mul q d) in + if unsigned_lt r d then q else succ q + +let unsigned_rem n d = + sub n (mul (unsigned_div n d) d) + +external seeded_hash_param : + int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc] +let seeded_hash seed x = seeded_hash_param 10 100 seed x +let hash x = seeded_hash_param 10 100 0 x diff --git a/jscomp/stdlib/nativeint.mli b/jscomp/stdlib/nativeint.mli new file mode 100644 index 000000000..caaf7cb9d --- /dev/null +++ b/jscomp/stdlib/nativeint.mli @@ -0,0 +1,251 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 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. *) +(* *) +(**************************************************************************) + +(** Processor-native integers. + + This module provides operations on the type [nativeint] of + signed 32-bit integers (on 32-bit platforms) or + signed 64-bit integers (on 64-bit platforms). + This integer type has exactly the same width as that of a + pointer type in the C compiler. All arithmetic operations over + [nativeint] are taken modulo 2{^32} or 2{^64} depending + on the word size of the architecture. + + Performance notice: values of type [nativeint] occupy more memory + space than values of type [int], and arithmetic operations on + [nativeint] are generally slower than those on [int]. Use [nativeint] + only when the application requires the extra bit of precision + over the [int] type. + + Literals for native integers are suffixed by n: + {[ + let zero: nativeint = 0n + let one: nativeint = 1n + let m_one: nativeint = -1n + ]} +*) + +val zero : nativeint +(** The native integer 0.*) + +val one : nativeint +(** The native integer 1.*) + +val minus_one : nativeint +(** The native integer -1.*) + +external neg : nativeint -> nativeint = "%nativeint_neg" +(** Unary negation. *) + +external add : nativeint -> nativeint -> nativeint = "%nativeint_add" +(** Addition. *) + +external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" +(** Subtraction. *) + +external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" +(** Multiplication. *) + +external div : nativeint -> nativeint -> nativeint = "%nativeint_div" +(** Integer division. This division rounds the real quotient of + its arguments towards zero, as specified for {!Stdlib.(/)}. + + @raise Division_by_zero if the second + argument is zero. *) + +val unsigned_div : nativeint -> nativeint -> nativeint +(** Same as {!div}, except that arguments and result are interpreted as {e + unsigned} native integers. + + @since 4.08 *) + +external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" +(** Integer remainder. If [y] is not zero, the result + of [Nativeint.rem x y] satisfies the following properties: + [Nativeint.zero <= Nativeint.rem x y < Nativeint.abs y] and + [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y) + (Nativeint.rem x y)]. + If [y = 0], [Nativeint.rem x y] raises [Division_by_zero]. *) + +val unsigned_rem : nativeint -> nativeint -> nativeint +(** Same as {!rem}, except that arguments and result are interpreted as {e + unsigned} native integers. + + @since 4.08 *) + +val succ : nativeint -> nativeint +(** Successor. + [Nativeint.succ x] is [Nativeint.add x Nativeint.one]. *) + +val pred : nativeint -> nativeint +(** Predecessor. + [Nativeint.pred x] is [Nativeint.sub x Nativeint.one]. *) + +val abs : nativeint -> nativeint +(** [abs x] is the absolute value of [x]. On [min_int] this + is [min_int] itself and thus remains negative. *) + +val size : int +(** The size in bits of a native integer. This is equal to [32] + on a 32-bit platform and to [64] on a 64-bit platform. *) + +val max_int : nativeint +(** The greatest representable native integer, + either 2{^31} - 1 on a 32-bit platform, + or 2{^63} - 1 on a 64-bit platform. *) + +val min_int : nativeint +(** The smallest representable native integer, + either -2{^31} on a 32-bit platform, + or -2{^63} on a 64-bit platform. *) + +external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" +(** Bitwise logical and. *) + +external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" +(** Bitwise logical or. *) + +external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" +(** Bitwise logical exclusive or. *) + +val lognot : nativeint -> nativeint +(** Bitwise logical negation. *) + +external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" +(** [Nativeint.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= bitsize], + where [bitsize] is [32] on a 32-bit platform and + [64] on a 64-bit platform. *) + +external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" +(** [Nativeint.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= bitsize]. *) + +external shift_right_logical : + nativeint -> int -> nativeint = "%nativeint_lsr" +(** [Nativeint.shift_right_logical x y] shifts [x] to the right + by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= bitsize]. *) + + +external of_int : int -> nativeint = "%nativeint_of_int" +(** Convert the given integer (type [int]) to a native integer + (type [nativeint]). *) + +external to_int : nativeint -> int = "%nativeint_to_int" +(** Convert the given native integer (type [nativeint]) to an + integer (type [int]). The high-order bit is lost during + the conversion. *) + +val unsigned_to_int : nativeint -> int option +(** Same as {!to_int}, but interprets the argument as an {e unsigned} integer. + Returns [None] if the unsigned value of the argument cannot fit into an + [int]. + + @since 4.08 *) + +external of_float : float -> nativeint + = "caml_nativeint_of_float" "caml_nativeint_of_float_unboxed" + [@@unboxed] [@@noalloc] +(** Convert the given floating-point number to a native integer, + discarding the fractional part (truncate towards 0). + If the truncated floating-point number is outside the range + \[{!Nativeint.min_int}, {!Nativeint.max_int}\], no exception is raised, + and an unspecified, platform-dependent integer is returned. *) + +external to_float : nativeint -> float + = "caml_nativeint_to_float" "caml_nativeint_to_float_unboxed" + [@@unboxed] [@@noalloc] +(** Convert the given native integer to a floating-point number. *) + +external of_int32 : int32 -> nativeint = "%nativeint_of_int32" +(** Convert the given 32-bit integer (type [int32]) + to a native integer. *) + +external to_int32 : nativeint -> int32 = "%nativeint_to_int32" +(** Convert the given native integer to a + 32-bit integer (type [int32]). On 64-bit platforms, + the 64-bit native integer is taken modulo 2{^32}, + i.e. the top 32 bits are lost. On 32-bit platforms, + the conversion is exact. *) + +external of_string : string -> nativeint = "caml_nativeint_of_string" +(** Convert the given string to a native integer. + The string is read in decimal (by default, or if the string + begins with [0u]) or in hexadecimal, octal or binary if the + string begins with [0x], [0o] or [0b] respectively. + + The [0u] prefix reads the input as an unsigned integer in the range + [[0, 2*Nativeint.max_int+1]]. If the input exceeds {!Nativeint.max_int} + it is converted to the signed integer + [Int64.min_int + input - Nativeint.max_int - 1]. + + @raise Failure if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [nativeint]. *) + +val of_string_opt: string -> nativeint option +(** Same as [of_string], but return [None] instead of raising. + @since 4.05 *) + +val to_string : nativeint -> string +(** Return the string representation of its argument, in decimal. *) + +type t = nativeint +(** An alias for the type of native integers. *) + +val compare: t -> t -> int +(** The comparison function for native integers, with the same specification as + {!Stdlib.compare}. Along with the type [t], this function [compare] + allows the module [Nativeint] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val unsigned_compare: t -> t -> int +(** Same as {!compare}, except that arguments are interpreted as {e unsigned} + native integers. + + @since 4.08 *) + +val equal: t -> t -> bool +(** The equal function for native ints. + @since 4.03 *) + +val min: t -> t -> t +(** Return the smaller of the two arguments. + @since 4.13 +*) + +val max: t -> t -> t +(** Return the greater of the two arguments. + @since 4.13 + *) + +val seeded_hash : int -> t -> int +(** A seeded hash function for native ints, with the same output value as + {!Hashtbl.seeded_hash}. This function allows this module to be passed as + argument to the functor {!Hashtbl.MakeSeeded}. + + @since 5.1 *) + +val hash : t -> int +(** An unseeded hash function for native ints, with the same output value as + {!Hashtbl.hash}. This function allows this module to be passed as argument + to the functor {!Hashtbl.Make}. + + @since 5.1 *) diff --git a/jscomp/stdlib/stdlib.cppo.ml b/jscomp/stdlib/stdlib.cppo.ml index 714ad6aa5..99f9e8cb3 100644 --- a/jscomp/stdlib/stdlib.cppo.ml +++ b/jscomp/stdlib/stdlib.cppo.ml @@ -759,11 +759,8 @@ module ListLabels = ListLabels module Map = Map module Marshal = Marshal module MoreLabels = MoreLabels -module Mutex = Mutex -#ifdef BS -#else +module Mutex = Mutex module Nativeint = Nativeint -#endif module Obj = Obj module Oo = Oo module Option = Option diff --git a/jscomp/stdlib/stdlib.cppo.mli b/jscomp/stdlib/stdlib.cppo.mli index 48ee8872b..1076d7228 100644 --- a/jscomp/stdlib/stdlib.cppo.mli +++ b/jscomp/stdlib/stdlib.cppo.mli @@ -1576,6 +1576,7 @@ module In_channel = In_channel module Int = Int module Int32 = Int32 module Int64 = Int64 +module Nativeint = Nativeint module Lazy = Lazy module Lexing = Lexing module List = List diff --git a/test/blackbox-tests/mel-errors.t b/test/blackbox-tests/mel-errors.t index 5ad3cf442..d419a2854 100644 --- a/test/blackbox-tests/mel-errors.t +++ b/test/blackbox-tests/mel-errors.t @@ -64,16 +64,6 @@ Demonstrate PPX error messages Error: Unicode strings cannot currently be used in pattern matching [1] - $ cat > x.ml < let x = 42n - > EOF - $ dune build @melange - File "x.ml", line 1, characters 8-11: - 1 | let x = 42n - ^^^ - Error: `nativeint' is not currently supported in Melange. The `n' suffix cannot be used. - [1] - $ cat > x.ml < external cast: 'a -> 'b -> 'c = "%identity" > EOF