v0.17~preview.129.36+325

generate/dune

@@ -1,5 +1,5 @@
 (executables
  (modes byte exe)
  (names generate_pow_overflow_bounds)
- (libraries num)
+ (libraries zarith)
  (preprocess no_preprocessing))

generate/generate_pow_overflow_bounds.ml

@@ -4,6 +4,7 @@
 (* This module generates lookup tables to detect integer overflow when calculating integer
    exponents.  At index [e], [table.[e]^e] will not overflow, but [(table[e] + 1)^e]
    will. *)
+module Z = Zarith.Z
 
 type mode =
   | Normal
@@ -28,19 +29,6 @@ let oc, mode =
   | _ -> failwith "bad command line arguments"
 ;;
 
-module Big_int = struct
-  include Big_int
-
-  let ( > ) = gt_big_int
-  let ( <= ) = le_big_int
-  let ( ^ ) = power_big_int_positive_int
-  let ( - ) = sub_big_int
-  let ( + ) = add_big_int
-  let one = unit_big_int
-  let sqrt = sqrt_big_int
-  let to_string = string_of_big_int
-end
-
 module Array = StdLabels.Array
 
 type generated_type =
@@ -52,16 +40,16 @@ type generated_type =
 let max_big_int_for_bits bits =
   let shift = bits - 1 in
   (* sign bit *)
-  Big_int.(shift_left_big_int one shift - one)
+  Z.(shift_left one shift - one)
 ;;
 
 let safe_to_print_as_int =
   let int31_max = max_big_int_for_bits 31 in
-  fun x -> Big_int.(x <= int31_max)
+  fun x -> x <= int31_max
 ;;
 
 let format_entry typ b =
-  let s = Big_int.to_string b in
+  let s = Z.to_string b in
   match typ with
   | Int ->
     if safe_to_print_as_int b then s else Printf.sprintf "Stdlib.Int64.to_int %sL" s
@@ -99,16 +87,16 @@ let generate_negative_bounds = function
 ;;
 
 let highest_base exponent max_val =
-  let open Big_int in
+  let open Z in
   match exponent with
   | 0 | 1 -> max_val
   | 2 -> sqrt max_val
   | _ ->
     let rec search possible_base =
-      if possible_base ^ exponent > max_val
+      if possible_base ** exponent > max_val
       then (
         let res = possible_base - one in
-        assert (res ^ exponent <= max_val);
+        assert (res ** exponent <= max_val);
         res)
       else search (possible_base + one)
     in
@@ -128,7 +116,7 @@ let gen_array ~typ ~bits ~sign ~indent =
   let bounds =
     match sign with
     | Pos -> pos_bounds
-    | Neg -> Array.map pos_bounds ~f:Big_int.minus_big_int
+    | Neg -> Array.map pos_bounds ~f:Z.( ~- )
   in
   pr "[| %s" (format_entry typ bounds.(0));
   for i = 1 to Array.length bounds - 1 do

generate/zarith.ml

@@ -0,0 +1,4 @@
+module Big_int_Z = Big_int_Z
+module Q = Q
+module Z = Z
+module Zarith_version = Zarith_version

hash_types/src/base_internalhash_types.ml

@@ -1,18 +1,42 @@
-(** [state] is defined as a subtype of [int] using the [private] keyword. This makes it an
-    opaque type for most purposes, and tells the compiler that the type is immediate. *)
-type state = private int
-
 type seed = int
 type hash_value = int
 
-external create_seeded : seed -> state = "%identity" [@@noalloc]
+(* The main non-64-bit systems we are planning to support are JavaScript and WebAssembly.
+   js_of_ocaml is treated as a 32-bit platform with 32-bit native integers. All of the
+   external [caml_hash*] implementations are all written assuming these 32-bit native ints
+   and so using Int32 on the [Non_immediate] path allows for this change to be a runtime
+   noop for native and JavaScript. If we were to make this something like [Int63], which
+   intuitively feels like a more consistent choice, we would have to change the
+   implementations of all of these pretty foundational hash functions in both js and wasm. *)
+include Sys.Immediate64.Make (Int) (Int32)
+
+type state = t
+
+let compare_state (x : state) (y : state) : hash_value =
+  match repr with
+  | Immediate -> Int.compare x y
+  | Non_immediate -> Int32.compare x y
+;;
+
+let state_to_string (x : state) : string =
+  match repr with
+  | Immediate -> Int.to_string x
+  | Non_immediate -> Int32.to_string x
+;;
+
+let create_seeded (x : int) : state =
+  match repr with
+  | Immediate -> x
+  | Non_immediate -> Int32.of_int x
+;;
 
+(* onicole: On a 32-bit backend such as Wasm, these functions may allocate. *)
 external fold_int64
   :  state
   -> (int64[@unboxed])
   -> state
   = "Base_internalhash_fold_int64" "Base_internalhash_fold_int64_unboxed"
-  [@@noalloc]
+[@@noalloc]
 
 external fold_int : state -> int -> state = "Base_internalhash_fold_int" [@@noalloc]
 
@@ -21,10 +45,10 @@ external fold_float
   -> (float[@unboxed])
   -> state
   = "Base_internalhash_fold_float" "Base_internalhash_fold_float_unboxed"
-  [@@noalloc]
+[@@noalloc]
 
 external fold_string : state -> string -> state = "Base_internalhash_fold_string"
-  [@@noalloc]
+[@@noalloc]
 
 external get_hash_value : state -> hash_value = "Base_internalhash_get_hash_value"
-  [@@noalloc]
+[@@noalloc]

hash_types/src/runtime.wat

@@ -0,0 +1,78 @@
+(module
+   (import "env" "Int32_val" (func $Int32_val (param (ref eq)) (result i32)))
+   (import "env" "Int64_val" (func $Int64_val (param (ref eq)) (result i64)))
+   (import "env" "Double_val"
+      (func $Double_val (param (ref eq)) (result f64)))
+   (import "env" "caml_copy_int32"
+      (func $caml_copy_int32 (param $i i32) (result (ref eq))))
+   (import "env" "caml_hash_mix_int"
+      (func $caml_hash_mix_int (param i32) (param i32) (result i32)))
+   (import "env" "caml_hash_mix_int64"
+      (func $caml_hash_mix_int64 (param i32) (param i64) (result i32)))
+   (import "env" "caml_hash_mix_double"
+      (func $caml_hash_mix_double (param i32) (param f64) (result i32)))
+   (import "env" "caml_hash_mix_string"
+      (func $caml_hash_mix_string
+         (param i32) (param (ref $string)) (result i32)))
+   (import "env" "caml_hash_mix_final"
+      (func $caml_hash_mix_final (param i32) (result i32)))
+
+   (type $string (array (mut i8)))
+   (type $compare
+      (func (param (ref eq)) (param (ref eq)) (param i32) (result i32)))
+   (type $hash
+      (func (param (ref eq)) (result i32)))
+   (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32)))
+   (type $serialize
+      (func (param (ref eq)) (param (ref eq)) (result i32) (result i32)))
+   (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32)))
+   (type $dup (func (param (ref eq)) (result (ref eq))))
+   (type $custom_operations
+      (struct
+         (field $id (ref $string))
+         (field $compare (ref null $compare))
+         (field $compare_ext (ref null $compare))
+         (field $hash (ref null $hash))
+         (field $fixed_length (ref null $fixed_length))
+         (field $serialize (ref null $serialize))
+         (field $deserialize (ref null $deserialize))
+         (field $dup (ref null $dup))))
+   (type $custom (sub (struct (field (ref $custom_operations)))))
+   (type $int32
+      (sub final $custom (struct (field (ref $custom_operations)) (field i32))))
+
+   (func (export "Base_internalhash_fold_int64")
+      (param $st (ref eq)) (param $i (ref eq)) (result (ref eq))
+      (call $caml_copy_int32
+         (call $caml_hash_mix_int64
+            (call $Int32_val (local.get $st))
+            (call $Int64_val (local.get $i)))))
+
+   (func (export "Base_internalhash_fold_int")
+      (param $st (ref eq)) (param $i (ref eq)) (result (ref eq))
+      (call $caml_copy_int32
+         (call $caml_hash_mix_int
+            (call $Int32_val (local.get $st))
+            (i31.get_s (ref.cast (ref i31) (local.get $i))))))
+
+   (func (export "Base_internalhash_fold_float")
+      (param $st (ref eq)) (param $f (ref eq)) (result (ref eq))
+      (call $caml_copy_int32
+         (call $caml_hash_mix_double
+            (call $Int32_val (local.get $st))
+            (call $Double_val (local.get $f)))))
+
+   (func (export "Base_internalhash_fold_string")
+      (param $st (ref eq)) (param $s (ref eq)) (result (ref eq))
+      (call $caml_copy_int32
+         (call $caml_hash_mix_string
+            (call $Int32_val (local.get $st))
+            (ref.cast (ref $string) (local.get $s)))))
+
+   (func (export "Base_internalhash_get_hash_value")
+      (param $st (ref eq)) (result (ref eq))
+      (ref.i31
+         (i32.and
+            (call $caml_hash_mix_final (call $Int32_val (local.get $st)))
+            (i32.const 0x3FFFFFFF))))
+)

hash_types/test/test_immediate.ml

@@ -2,8 +2,7 @@ open! Base
 open! Import
 
 let%expect_test "[Base.Hash.state] is still immediate" =
-  require_no_allocation [%here] (fun () ->
-    ignore (Sys.opaque_identity (Base.Hash.create ())));
+  require_no_allocation (fun () -> ignore (Sys.opaque_identity (Base.Hash.create ())));
   [%expect {| |}]
 ;;
 

lint/ppx_base_lint.ml

@@ -25,7 +25,7 @@ let zero_modules () =
   |> Array.to_list
   |> List.filter ~f:(fun fn -> Stdlib.Filename.check_suffix fn "0.ml")
   |> List.map ~f:(fun fn ->
-       String.capitalize (String.sub fn ~pos:0 ~len:(String.length fn - 4)))
+    String.capitalize (String.sub fn ~pos:0 ~len:(String.length fn - 4)))
   |> Set.of_list (module String)
 ;;
 
@@ -114,14 +114,14 @@ let check current_module =
         let expansion =
           Ppx_cold.expand_cold_attribute attr
           |> List.map ~f:(fun a ->
-               { a with
-                 attr_name =
-                   { a.attr_name with
-                     txt =
-                       String.chop_prefix a.attr_name.txt ~prefix:"ocaml."
-                       |> Option.value ~default:a.attr_name.txt
-                   }
-               })
+            { a with
+              attr_name =
+                { a.attr_name with
+                  txt =
+                    String.chop_prefix a.attr_name.txt ~prefix:"ocaml."
+                    |> Option.value ~default:a.attr_name.txt
+                }
+            })
         in
         let is_part_of_expansion attr =
           List.exists expansion ~f:(fun a ->

ppx/README.md

@@ -0,0 +1,6 @@
+# ppx_base_internal
+
+This ppx is intended only for use inside Base itself, to help write certain repeated code
+patterns. It is not designed for use in other contexts. For example, it may refer to
+internal names like `Bool0`, or be specialized to use cases in `Base` that are not
+applicable to other code.

ppx/src/dune

@@ -0,0 +1,6 @@
+(library
+ (name ppx_base_internal)
+ (kind ppx_deriver)
+ (libraries base ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))

ppx/src/ppx_base_internal.ml

@@ -0,0 +1,79 @@
+open! Base
+open Ppxlib
+
+module Specialize_polymorphic_compare = struct
+  let signature ~loc =
+    [%sig:
+      [@@@ocaml.ppwarning "ppx_base_internal: intended only for use inside Base"]
+
+      external ( = ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
+      external ( <> ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%notequal"
+      external ( < ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessthan"
+      external ( > ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterthan"
+      external ( <= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessequal"
+      external ( >= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterequal"
+      external compare : (t[@local_opt]) -> (t[@local_opt]) -> int = "%compare"
+      external compare__local : (t[@local_opt]) -> (t[@local_opt]) -> int = "%compare"
+      external equal : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
+      external equal__local : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
+      val ascending : t -> t -> int
+      val descending : t -> t -> int
+      val max : t -> t -> t
+      val min : t -> t -> t]
+  ;;
+
+  let structure ~loc =
+    [%str
+      [@@@ocaml.ppwarning "ppx_base_internal: intended only for use inside Base"]
+
+      external ( = ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
+      external ( <> ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%notequal"
+      external ( < ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessthan"
+      external ( > ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterthan"
+      external ( <= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessequal"
+      external ( >= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterequal"
+      external compare : (t[@local_opt]) -> (t[@local_opt]) -> int = "%compare"
+      external compare__local : (t[@local_opt]) -> (t[@local_opt]) -> int = "%compare"
+      external equal : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
+      external equal__local : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
+
+      let ascending x y = compare x y
+      let descending x y = compare y x
+      let max x y = Bool0.select (x >= y) x y
+      let min x y = Bool0.select (x <= y) x y]
+  ;;
+
+  let check_decl decl =
+    match core_type_of_type_declaration decl with
+    | [%type: t] -> Ok ()
+    | _ ->
+      Error
+        (Location.Error.to_extension
+           (Location.Error.createf
+              ~loc:decl.ptype_loc
+              "deriving specialize_polymorphic_compare: expected [type t], no other name \
+               or parameters"))
+  ;;
+
+  let sig_type_decl =
+    Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, decls) ->
+      List.concat_map decls ~f:(fun decl ->
+        let loc = decl.ptype_loc in
+        match check_decl decl with
+        | Ok () -> signature ~loc
+        | Error ext -> [ Ast_builder.Default.psig_extension ~loc ext [] ]))
+  ;;
+
+  let str_type_decl =
+    Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, decls) ->
+      List.concat_map decls ~f:(fun decl ->
+        let loc = decl.ptype_loc in
+        match check_decl decl with
+        | Ok () -> structure ~loc
+        | Error ext -> [ Ast_builder.Default.pstr_extension ~loc ext [] ]))
+  ;;
+
+  let deriver =
+    Deriving.add "specialize_polymorphic_compare" ~sig_type_decl ~str_type_decl
+  ;;
+end

ppx/src/ppx_base_internal.mli

@@ -0,0 +1,6 @@
+open! Base
+open Ppxlib
+
+module Specialize_polymorphic_compare : sig
+  val deriver : Deriving.t
+end