v0.17~preview.128.45+251

hash_types/src/base_internalhash_types.ml

@@ -6,7 +6,14 @@ type seed = int
 type hash_value = int
 
 external create_seeded : seed -> state = "%identity" [@@noalloc]
-external fold_int64 : state -> int64 -> state = "Base_internalhash_fold_int64" [@@noalloc]
+
+external fold_int64
+  :  state
+  -> (int64[@unboxed])
+  -> state
+  = "Base_internalhash_fold_int64" "Base_internalhash_fold_int64_unboxed"
+  [@@noalloc]
+
 external fold_int : state -> int -> state = "Base_internalhash_fold_int" [@@noalloc]
 
 external fold_float

hash_types/src/internalhash_stubs.c

@@ -21,6 +21,11 @@ CAMLprim value Base_internalhash_fold_int64(value st, value i)
   return Val_long(caml_hash_mix_int64(Long_val(st), Int64_val(i)));
 }
 
+CAMLprim value Base_internalhash_fold_int64_unboxed(value st, int64_t i)
+{
+  return Val_long(caml_hash_mix_int64(Long_val(st), i));
+}
+
 CAMLprim value Base_internalhash_fold_int(value st, value i)
 {
   return Val_long(caml_hash_mix_intnat(Long_val(st), Long_val(i)));

src/avltree.ml

@@ -177,72 +177,45 @@ let balance tree =
       tree)
 ;;
 
-(* @pre: tree is balanceable
-   @pre: abs (height (right node) - height (balance tree)) <= 3
-   @post: result is balanceable *)
-
-(* @pre: tree is balanceable
-   @pre: abs (height (right node) - height (balance tree)) <= 3
-   @post: result is balanceable *)
-let set_left node tree =
-  let tree = balance tree in
-  match node with
-  | Node ({ left; key = _; value = _; height = _; right = _ } as r) ->
-    if phys_equal left tree then () else r.left <- tree;
-    update_height node
-  | _ -> assert false
-;;
-
-(* @pre: tree is balanceable
-   @pre: abs (height (left node) - height (balance tree)) <= 3
-   @post: result is balanceable *)
-let set_right node tree =
-  let tree = balance tree in
-  match node with
-  | Node ({ left = _; key = _; value = _; height = _; right } as r) ->
-    if phys_equal right tree then () else r.right <- tree;
-    update_height node
-  | _ -> assert false
-;;
-
 (* @pre: t is balanced.
    @post: result is balanced, with new node inserted
    @post: !added = true iff the shape of the input tree changed.  *)
-let add =
-  let rec add t replace added compare k v =
-    match t with
-    | Empty ->
+let rec add t ~replace ~compare ~added ~key:k ~data:v =
+  match t with
+  | Empty ->
+    added := true;
+    Leaf { key = k; value = v }
+  | Leaf ({ key = k'; value = _ } as r) ->
+    let c = compare k' k in
+    (* This compare is reversed on purpose, we are pretending
+       that the leaf was just inserted instead of the other way
+       round, that way we only allocate one node. *)
+    if c = 0
+    then (
+      added := false;
+      if replace then r.value <- v;
+      t)
+    else (
       added := true;
-      Leaf { key = k; value = v }
-    | Leaf ({ key = k'; value = _ } as r) ->
-      let c = compare k' k in
-      (* This compare is reversed on purpose, we are pretending
-         that the leaf was just inserted instead of the other way
-         round, that way we only allocate one node. *)
-      if c = 0
+      if c < 0
+      then Node { left = t; key = k; value = v; height = 2; right = Empty }
+      else Node { left = Empty; key = k; value = v; height = 2; right = t })
+  | Node ({ left; key = k'; value = _; height = _; right } as r) ->
+    let c = compare k k' in
+    if c = 0
+    then (
+      added := false;
+      if replace then r.value <- v;
+      t)
+    else (
+      if c < 0
       then (
-        added := false;
-        if replace then r.value <- v;
-        t)
+        let left' = add left ~replace ~added ~compare ~key:k ~data:v in
+        if not (phys_equal left' left) then r.left <- left')
       else (
-        added := true;
-        if c < 0
-        then Node { left = t; key = k; value = v; height = 2; right = Empty }
-        else Node { left = Empty; key = k; value = v; height = 2; right = t })
-    | Node ({ left; key = k'; value = _; height = _; right } as r) ->
-      let c = compare k k' in
-      if c = 0
-      then (
-        added := false;
-        if replace then r.value <- v)
-      else if c < 0
-      then set_left t (add left replace added compare k v)
-      else set_right t (add right replace added compare k v);
-      t
-  in
-  fun t ~replace ~compare ~added ~key ~data ->
-    let t = add t replace added compare key data in
-    if !added then balance t else t
+        let right' = add right ~replace ~added ~compare ~key:k ~data:v in
+        if not (phys_equal right' right) then r.right <- right');
+      if !added then balance t else t)
 ;;
 
 let rec first t =
@@ -403,7 +376,7 @@ let mem =
   fun t ~compare k -> find_and_call t ~compare k ~if_found ~if_not_found
 ;;
 
-let remove =
+let rec remove =
   let rec min_elt tree =
     match tree with
     | Empty -> Empty
@@ -414,40 +387,38 @@ let remove =
   let rec remove_min_elt tree =
     match tree with
     | Empty -> assert false
-    | Leaf _ -> Empty (* This must be the root *)
+    | Leaf _ -> Empty
     | Node { left = Empty; key = _; value = _; height = _; right } -> right
     | Node { left = Leaf _; key = k; value = v; height = _; right = Empty } ->
       Leaf { key = k; value = v }
-    | Node { left = Leaf _; key = _; value = _; height = _; right = _ } as node ->
-      set_left node Empty;
-      tree
-    | Node { left; key = _; value = _; height = _; right = _ } as node ->
-      set_left node (remove_min_elt left);
-      tree
+    | Node ({ left; key = _; value = _; height = _; right = _ } as r) ->
+      r.left <- remove_min_elt left;
+      balance tree
   in
   let merge t1 t2 =
     match t1, t2 with
     | Empty, t -> t
     | t, Empty -> t
     | _, _ ->
       let tree = min_elt t2 in
-      (match tree with
-       | Empty -> assert false
-       | Leaf { key = k; value = v } ->
-         let t2 = balance (remove_min_elt t2) in
-         Node
-           { left = t1
-           ; key = k
-           ; value = v
-           ; height = Int.max (height t1) (height t2) + 1
-           ; right = t2
-           }
-       | Node _ as node ->
-         set_right node (remove_min_elt t2);
-         set_left node t1;
-         node)
+      balance
+        (match tree with
+         | Empty -> assert false
+         | Leaf { key = k; value = v } ->
+           let t2 = remove_min_elt t2 in
+           Node
+             { left = t1
+             ; key = k
+             ; value = v
+             ; height = Int.max (height t1) (height t2) + 1
+             ; right = t2
+             }
+         | Node r ->
+           r.right <- remove_min_elt t2;
+           r.left <- t1;
+           tree)
   in
-  let rec remove t removed compare k =
+  fun t ~removed ~compare k ->
     match t with
     | Empty ->
       removed := false;
@@ -460,21 +431,21 @@ let remove =
       else (
         removed := false;
         t)
-    | Node { left; key = k'; value = _; height = _; right } ->
+    | Node ({ left; key = k'; value = _; height = _; right } as r) ->
       let c = compare k k' in
       if c = 0
       then (
         removed := true;
         merge left right)
-      else if c < 0
-      then (
-        set_left t (remove left removed compare k);
-        t)
       else (
-        set_right t (remove right removed compare k);
-        t)
-  in
-  fun t ~removed ~compare k -> balance (remove t removed compare k)
+        if c < 0
+        then (
+          let left' = remove left ~removed ~compare k in
+          if not (phys_equal left' left) then r.left <- left')
+        else (
+          let right' = remove right ~removed ~compare k in
+          if not (phys_equal right' right) then r.right <- right');
+        if !removed then balance t else t)
 ;;
 
 let rec fold t ~init ~f =

src/dune

@@ -12,7 +12,7 @@
  (libraries base_internalhash_types sexplib0 shadow_stdlib)
  (c_flags :standard -D_LARGEFILE64_SOURCE (:include mpopcnt.sexp))
  (c_names bytes_stubs exn_stubs float_stubs int_math_stubs hash_stubs
-  am_testing)
+  obj_stubs am_testing)
  (preprocess no_preprocessing)
  (lint
   (pps ppx_base ppx_base_lint -check-doc-comments -type-conv-keep-w32=both

src/hash.ml

@@ -144,7 +144,11 @@ module Internalhash : sig
        and type seed = Base_internalhash_types.seed
        and type hash_value = Base_internalhash_types.hash_value
 
-  external fold_int64 : state -> int64 -> state = "Base_internalhash_fold_int64"
+  external fold_int64
+    :  state
+    -> (int64[@unboxed])
+    -> state
+    = "Base_internalhash_fold_int64" "Base_internalhash_fold_int64_unboxed"
     [@@noalloc]
 
   external fold_int : state -> int -> state = "Base_internalhash_fold_int" [@@noalloc]

src/hashtbl.ml

@@ -234,12 +234,10 @@ let remove t key =
   ensure_mutation_allowed t;
   let i = slot t key in
   let root = t.table.(i) in
-  let added_or_removed =  (ref false) in
-  let new_root =
-    Avltree.remove root ~removed:added_or_removed ~compare:(compare_key t) key
-  in
+  let removed =  (ref false) in
+  let new_root = Avltree.remove root ~removed ~compare:(compare_key t) key in
   if not (phys_equal root new_root) then t.table.(i) <- new_root;
-  if !added_or_removed then t.length <- t.length - 1
+  if !removed then t.length <- t.length - 1
 ;;
 
 let length t = t.length

src/int63.ml

@@ -3,58 +3,7 @@ open! Import
 let raise_s = Error.raise_s
 
 module Repr = Int63_emul.Repr
-
-(* In a world where the compiler would understand [@@immediate64] attributes on type
-   declarations, this module is how one would produce a [type t] with this attribute. *)
-module Immediate64 : sig
-  module type Non_immediate = sig
-    type t
-  end
-
-  module type Immediate = sig
-    type t [@@immediate]
-  end
-
-  module Make (Immediate : Immediate) (Non_immediate : Non_immediate) : sig
-    type t [@@immediate64]
-
-    type 'a repr =
-      | Immediate : Immediate.t repr
-      | Non_immediate : Non_immediate.t repr
-
-    val repr : t repr
-  end
-end = struct
-  module type Non_immediate = sig
-    type t
-  end
-
-  module type Immediate = sig
-    type t [@@immediate]
-  end
-
-  module Make (Immediate : Immediate) (Non_immediate : Non_immediate) = struct
-    type t [@@immediate64]
-
-    type 'a repr =
-      | Immediate : Immediate.t repr
-      | Non_immediate : Non_immediate.t repr
-
-    external transparent_magic : ('a[@local_opt]) -> ('b[@local_opt]) = "%identity"
-
-    let repr =
-      (* [Obj.magic] involves opaqueness under Flambda 2 which will inhibit
-         availability of functions defined in this module for later inlining
-         (e.g. into float.ml). As such we explicitly use %identity here. *)
-      match Word_size.word_size with
-      | W64 -> (transparent_magic Immediate : t repr)
-      | W32 -> (transparent_magic Non_immediate : t repr)
-    ;;
-  end
-  [@@inline always]
-end
-
-include Immediate64.Make (Int) (Int63_emul)
+include Sys0.Make_immediate64 (Int) (Int63_emul)
 
 module Backend = struct
   module type S = sig

src/list.ml

@@ -1275,10 +1275,10 @@ module Assoc = struct
 
   let find_exn =
     let not_found = Not_found_s (Atom "List.Assoc.find_exn: not found") in
-    let find_exn t ~equal key =
-      match find t key ~equal with
-      | None -> raise not_found
-      | Some value -> value
+    let rec find_exn t ~equal key =
+      match t with
+      | [] -> raise not_found
+      | (key', value) :: t -> if equal key key' then value else find_exn t ~equal key
     in
     (* named to preserve symbol in compiled binary *)
     find_exn