Use an array instead of a list for domain-local state.

This enables constant-time access to any field in the domain-local
state. Hence, there is no longer a need to specialise the domain-local
state for local states in Stdlib. This simplifies the code massively
compared to the previous design.

11 files changed, 110 insertions, 166 deletions

diff --git a/stdlib/.depend b/stdlib/.depend
index b96f43017f..37c1c3832b 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -110,14 +110,6 @@ camlinternalAtomic.cmo : \
 camlinternalAtomic.cmx : \
     camlinternalAtomic.cmi
 camlinternalAtomic.cmi :
-camlinternalDomain.cmo : \
-    stdlib__obj.cmi \
-    camlinternalDomain.cmi
-camlinternalDomain.cmx : \
-    stdlib__obj.cmx \
-    camlinternalDomain.cmi
-camlinternalDomain.cmi : \
-    stdlib__obj.cmi
 camlinternalFormat.cmo : \
     stdlib__sys.cmi \
     stdlib__string.cmi \
@@ -221,14 +213,16 @@ stdlib__digest.cmi :
 stdlib__domain.cmo : \
     stdlib__obj.cmi \
     stdlib__mutex.cmi \
-    camlinternalDomain.cmi \
+    stdlib__int.cmi \
     stdlib__atomic.cmi \
+    stdlib__array.cmi \
     stdlib__domain.cmi
 stdlib__domain.cmx : \
     stdlib__obj.cmx \
     stdlib__mutex.cmx \
-    camlinternalDomain.cmx \
+    stdlib__int.cmx \
     stdlib__atomic.cmx \
+    stdlib__array.cmx \
     stdlib__domain.cmi
 stdlib__domain.cmi :
 stdlib__either.cmo : \
@@ -261,10 +255,8 @@ stdlib__filename.cmo : \
     stdlib__string.cmi \
     stdlib__random.cmi \
     stdlib__printf.cmi \
-    stdlib__obj.cmi \
     stdlib__list.cmi \
-    stdlib__lazy.cmi \
-    camlinternalDomain.cmi \
+    stdlib__domain.cmi \
     stdlib__buffer.cmi \
     stdlib__filename.cmi
 stdlib__filename.cmx : \
@@ -272,10 +264,8 @@ stdlib__filename.cmx : \
     stdlib__string.cmx \
     stdlib__random.cmx \
     stdlib__printf.cmx \
-    stdlib__obj.cmx \
     stdlib__list.cmx \
-    stdlib__lazy.cmx \
-    camlinternalDomain.cmx \
+    stdlib__domain.cmx \
     stdlib__buffer.cmx \
     stdlib__filename.cmi
 stdlib__filename.cmi :
@@ -367,8 +357,7 @@ stdlib__hashtbl.cmo : \
     stdlib__seq.cmi \
     stdlib__random.cmi \
     stdlib__obj.cmi \
-    stdlib__lazy.cmi \
-    camlinternalDomain.cmi \
+    stdlib__domain.cmi \
     stdlib__array.cmi \
     stdlib__hashtbl.cmi
 stdlib__hashtbl.cmx : \
@@ -377,8 +366,7 @@ stdlib__hashtbl.cmx : \
     stdlib__seq.cmx \
     stdlib__random.cmx \
     stdlib__obj.cmx \
-    stdlib__lazy.cmx \
-    camlinternalDomain.cmx \
+    stdlib__domain.cmx \
     stdlib__array.cmx \
     stdlib__hashtbl.cmi
 stdlib__hashtbl.cmi : \
@@ -582,27 +570,25 @@ stdlib__queue.cmi : \
 stdlib__random.cmo : \
     stdlib__string.cmi \
     stdlib.cmi \
-    stdlib__obj.cmi \
     stdlib__nativeint.cmi \
     stdlib__int64.cmi \
     stdlib__int32.cmi \
     stdlib__int.cmi \
+    stdlib__domain.cmi \
     stdlib__digest.cmi \
     stdlib__char.cmi \
-    camlinternalDomain.cmi \
     stdlib__array.cmi \
     stdlib__random.cmi
 stdlib__random.cmx : \
     stdlib__string.cmx \
     stdlib.cmx \
-    stdlib__obj.cmx \
     stdlib__nativeint.cmx \
     stdlib__int64.cmx \
     stdlib__int32.cmx \
     stdlib__int.cmx \
+    stdlib__domain.cmx \
     stdlib__digest.cmx \
     stdlib__char.cmx \
-    camlinternalDomain.cmx \
     stdlib__array.cmx \
     stdlib__random.cmi
 stdlib__random.cmi : \
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index 8acddf94ed..87adf93773 100644
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -34,11 +34,12 @@ STDLIB_MODS=\
   stdlib pervasives seq option either result bool char uchar \
   sys list bytes string unit marshal obj array float int int32 int64 nativeint \
   lexing parsing set map stack queue camlinternalLazy lazy stream buffer \
-  camlinternalDomain camlinternalFormat printf arg atomic \
+  atomic mutex condition semaphore domain \
+	camlinternalFormat printf arg \
   printexc fun gc digest random hashtbl weak \
   format scanf callback camlinternalOO oo camlinternalMod genlex ephemeron \
   filename complex arrayLabels listLabels bytesLabels stringLabels moreLabels \
-  stdLabels bigarray mutex condition semaphore domain
+  stdLabels bigarray
 
 STDLIB_MODULES=\
   $(foreach module, $(STDLIB_MODS), $(call add_stdlib_prefix,$(module)))
diff --git a/stdlib/camlinternalDomain.ml b/stdlib/camlinternalDomain.ml
deleted file mode 100644
index d22d78a657..0000000000
--- a/stdlib/camlinternalDomain.ml
+++ /dev/null
@@ -1,46 +0,0 @@
-type entry = {key_id: int ref; mutable slot: Obj.t}
-
-type dls_state =
-  { mutable random     : Obj.t; (* Domain-local state of Random module *)
-    mutable hashtbl    : Obj.t; (* Domain-local state of Hashtbl module *)
-    mutable filename   : Obj.t; (* Domain-local state of filename module *)
-    mutable entry_list : entry list }
-
-external get_dls_state : unit -> dls_state = "%dls_get"
-
-external set_dls_state : dls_state -> unit = "caml_domain_dls_set" [@@noalloc]
-
-let default_initialiser () =
-  let st = get_dls_state () in
-  if Obj.is_int (Obj.repr st) then begin
-    let st =
-      { random = Obj.repr (); hashtbl = Obj.repr (); filename = Obj.repr ();
-        entry_list = [] }
-    in
-    set_dls_state st;
-    st
-  end else st
-
-(* Run the default initialisation for the initial domain *)
-let _ = default_initialiser ()
-
-let initialiser = ref (fun () -> ignore (default_initialiser ()))
-
-(* Called in the top-level of stdlib modules by the initial domain to
- * initialise domain-local state *)
-let register_initialiser f =
-  let current_initialiser = !initialiser in
-  let new_initialiser () =
-    current_initialiser ();
-    let st = get_dls_state () in
-    f st
-  in
-  initialiser := new_initialiser;
-  (* Initialise for the main domain *)
-  let st = get_dls_state () in
-  f st
-
-(* Called when a new domain is spawned *)
-let initialise_dls () =
-  let f = !initialiser in
-  f ()
diff --git a/stdlib/camlinternalDomain.mli b/stdlib/camlinternalDomain.mli
deleted file mode 100644
index 301bc46dd2..0000000000
--- a/stdlib/camlinternalDomain.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-type entry = {key_id: int ref; mutable slot: Obj.t}
-
-type dls_state =
-  { mutable random     : Obj.t; (* Domain-local state of Random module *)
-    mutable hashtbl    : Obj.t; (* Domain-local state of Hashtbl module *)
-    mutable filename   : Obj.t; (* Domain-local state of filename module *)
-    mutable entry_list : entry list }
-
-external get_dls_state : unit -> dls_state = "%dls_get"
-
-val default_initialiser : unit -> dls_state
-
-val register_initialiser : (dls_state -> unit) -> unit
-
-val initialise_dls : unit -> unit
diff --git a/stdlib/domain.ml b/stdlib/domain.ml
index 4756314388..9add1e4129 100644
--- a/stdlib/domain.ml
+++ b/stdlib/domain.ml
@@ -9,6 +9,61 @@ module Raw = struct
     = "caml_ml_domain_cpu_relax"
 end
 
+module DLS = struct
+
+  type dls_state = Obj.t array
+
+  let unique_value = Obj.repr (ref 0)
+
+  external get_dls_state : unit -> dls_state = "%dls_get"
+
+  external set_dls_state : dls_state -> unit =
+    "caml_domain_dls_set" [@@noalloc]
+
+  let create_dls () =
+    let st = Array.make 8 unique_value in
+    set_dls_state st
+
+  let _ = create_dls ()
+
+  type 'a key = int * (unit -> 'a)
+
+  let key_counter = Atomic.make 0
+
+  let new_key f =
+    let k = Atomic.fetch_and_add key_counter 1 in
+    (k, f)
+
+  let rec log2 n =
+    if n <= 1 then 0 else 1 + (log2 (n asr 1))
+
+  (* If necessary, grow the current domain's local state array such that [idx]
+   * is a valid index in the array. *)
+  let maybe_grow idx =
+    let st = get_dls_state () in
+    if idx < Array.length st then st
+    else begin
+      let sz = Int.shift_left 1 (1 + log2 idx) in
+      let new_st = Array.make sz unique_value in
+      Array.blit st 0 new_st 0 (Array.length st);
+      set_dls_state new_st;
+      new_st
+    end
+
+  let set (idx, _init) x =
+    let st = maybe_grow idx in
+    st.(idx) <- Obj.repr x
+
+  let get (idx, init) =
+    let st = maybe_grow idx in
+    let v = st.(idx) in
+    if v == unique_value then
+      let v' = Obj.repr (init ()) in
+      st.(idx) <- v';
+      Obj.magic v'
+    else Obj.magic v
+
+end
 type nanoseconds = int64
 external timer_ticks : unit -> (int64 [@unboxed]) =
   "caml_ml_domain_ticks" "caml_ml_domain_ticks_unboxed" [@@noalloc]
@@ -44,7 +99,7 @@ let spawn f =
   let termination_mutex = Mutex.create () in
   let state = Atomic.make Running in
   let body () =
-    CamlinternalDomain.initialise_dls ();
+    DLS.create_dls ();
     let result = match f () with
       | x -> Ok x
       | exception ex -> Error ex in
@@ -93,46 +148,4 @@ let get_id { domain; _ } = domain
 
 let self () = Raw.self ()
 
-module DLS = struct
-
-  open CamlinternalDomain
 
-  type 'a key = int ref * (unit -> 'a)
-
-  let new_key f = (ref 0, f)
-
-  let set k x =
-    let cs = Obj.repr x in
-    let st = get_dls_state () in
-    let rec add_or_update_entry k v l =
-      match l with
-      | [] -> Some {key_id = k; slot = v}
-      | hd::tl ->
-        if (hd.key_id == k) then begin
-          hd.slot <- v;
-          None
-        end
-        else add_or_update_entry k v tl
-    in
-    let (key, _) = k in
-    match add_or_update_entry key cs st.entry_list with
-    | None -> ()
-    | Some e -> st.entry_list <- e::st.entry_list
-
-  let get k =
-    let st = get_dls_state () in
-    let rec search (key_id, init) l =
-      match l with
-      | [] ->
-        begin
-          let slot = Obj.repr (init ()) in
-          st.entry_list <- ({key_id; slot}::st.entry_list);
-          slot
-        end
-      | hd::tl ->
-        if hd.key_id == key_id then hd.slot
-        else search (key_id, init) tl
-    in
-    Obj.obj @@ search k st.entry_list
-
-end
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index 9a4953937b..142ed05bde 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -327,13 +327,10 @@ let remove_extension name =
 external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 external close_desc: int -> unit = "caml_sys_close"
 
-let _ = CamlinternalDomain.(register_initialiser (fun st ->
-  st.filename <- Obj.repr (lazy (Random.State.make_self_init()))))
+let random_key = Domain.DLS.new_key Random.State.make_self_init
 
 let temp_file_name temp_dir prefix suffix =
-  let open CamlinternalDomain in
-  let st = get_dls_state () in
-  let random_state = Lazy.force (Obj.magic st.filename) in
+  let random_state = Domain.DLS.get random_key in
   let rnd = (Random.State.bits random_state) land 0xFFFFFF in
   concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
 
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index 3476c033e5..069ee9b593 100644
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -57,13 +57,7 @@ let randomized = ref randomized_default
 let randomize () = randomized := true
 let is_randomized () = !randomized
 
-let _ = CamlinternalDomain.(register_initialiser (fun st ->
-  st.hashtbl <- Obj.repr (lazy (Random.State.make_self_init()))))
-
-let current_state () =
-  let open CamlinternalDomain in
-  let st = get_dls_state () in
-  Lazy.force (Obj.magic st.hashtbl)
+let random_key = Domain.DLS.new_key Random.State.make_self_init
 
 (* Functions which appear before the functorial interface must either be
    independent of the hash function or take it as a parameter (see #2202 and
@@ -78,7 +72,8 @@ let rec power_2_above x n =
 
 let create ?(random = !randomized) initial_size =
   let s = power_2_above 16 initial_size in
-  let seed = if random then Random.State.bits (current_state ()) else 0 in
+  let random_state = Domain.DLS.get random_key in
+  let seed = if random then Random.State.bits random_state else 0 in
   { initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
 
 let clear h =
@@ -623,7 +618,8 @@ let of_seq i =
 let rebuild ?(random = !randomized) h =
   let s = power_2_above 16 (Array.length h.data) in
   let seed =
-    if random then Random.State.bits (current_state ())
+    let random_state = Domain.DLS.get random_key in
+    if random then Random.State.bits random_state
     else if Obj.size (Obj.repr h) >= 4 then h.seed
     else 0 in
   let h' = {
diff --git a/stdlib/random.ml b/stdlib/random.ml
index 8fa58bc305..addd4f1cd7 100644
--- a/stdlib/random.ml
+++ b/stdlib/random.ml
@@ -163,30 +163,24 @@ let mk_default () = {
   State.idx = 0;
 }
 
-let _ = CamlinternalDomain.(register_initialiser (fun st ->
-  st.random <- Obj.repr (mk_default ())))
-
-let current_state () =
-  let open CamlinternalDomain in
-  let st = get_dls_state () in
-  Obj.magic st.random
-
-let bits () = State.bits (current_state ())
-let int bound = State.int (current_state ()) bound
-let int32 bound = State.int32 (current_state ()) bound
-let nativeint bound = State.nativeint (current_state ()) bound
-let int64 bound = State.int64 (current_state ()) bound
-let float scale = State.float (current_state ()) scale
-let bool () = State.bool (current_state ())
-
-let full_init seed = State.full_init (current_state ()) seed
-let init seed = State.full_init (current_state ()) [| seed |]
+let random_key = Domain.DLS.new_key mk_default
+
+let bits () = State.bits (Domain.DLS.get random_key)
+let int bound = State.int (Domain.DLS.get random_key) bound
+let int32 bound = State.int32 (Domain.DLS.get random_key) bound
+let nativeint bound = State.nativeint (Domain.DLS.get random_key) bound
+let int64 bound = State.int64 (Domain.DLS.get random_key) bound
+let float scale = State.float (Domain.DLS.get random_key) scale
+let bool () = State.bool (Domain.DLS.get random_key)
+
+let full_init seed = State.full_init (Domain.DLS.get random_key) seed
+let init seed = State.full_init (Domain.DLS.get random_key) [| seed |]
 let self_init () = full_init (random_seed())
 
 (* Manipulating the current state. *)
 
-let get_state () = State.copy (current_state ())
-let set_state s = State.assign (current_state ()) s
+let get_state () = State.copy (Domain.DLS.get random_key)
+let set_state s = State.assign (Domain.DLS.get random_key) s
 
 (********************
 
diff --git a/testsuite/tests/backtrace/backtrace2.reference b/testsuite/tests/backtrace/backtrace2.reference
index 044ae732a6..d987cffdf1 100644
--- a/testsuite/tests/backtrace/backtrace2.reference
+++ b/testsuite/tests/backtrace/backtrace2.reference
@@ -35,7 +35,7 @@ Uncaught exception Invalid_argument("index out of bounds")
 Raised by primitive operation at Backtrace2.run in file "backtrace2.ml", line 63, characters 14-22
 test_Not_found
 Uncaught exception Not_found
-Raised at Stdlib__hashtbl.find in file "hashtbl.ml", line 545, characters 13-28
+Raised at Stdlib__hashtbl.find in file "hashtbl.ml", line 540, characters 13-28
 Called from Backtrace2.test_Not_found in file "backtrace2.ml", line 44, characters 9-42
 Re-raised at Backtrace2.test_Not_found in file "backtrace2.ml", line 44, characters 61-70
 Called from Backtrace2.run in file "backtrace2.ml", line 63, characters 11-23
@@ -50,7 +50,7 @@ Called from CamlinternalLazy.do_force_block in file "camlinternalLazy.ml", line
 Re-raised at CamlinternalLazy.do_force_block in file "camlinternalLazy.ml", line 81, characters 4-11
 Called from Backtrace2.run in file "backtrace2.ml", line 63, characters 11-23
 Uncaught exception Not_found
-Raised at Stdlib__hashtbl.find in file "hashtbl.ml", line 545, characters 13-28
+Raised at Stdlib__hashtbl.find in file "hashtbl.ml", line 540, characters 13-28
 Called from Backtrace2.test_lazy.exception_raised_internally in file "backtrace2.ml", line 51, characters 8-41
 Re-raised at CamlinternalLazy.do_force_block.(fun) in file "camlinternalLazy.ml", line 78, characters 50-57
 Called from CamlinternalLazy.do_force_block in file "camlinternalLazy.ml", line 71, characters 17-27
diff --git a/testsuite/tests/parallel/domain_dls2.ml b/testsuite/tests/parallel/domain_dls2.ml
new file mode 100644
index 0000000000..6c79145ba7
--- /dev/null
+++ b/testsuite/tests/parallel/domain_dls2.ml
@@ -0,0 +1,17 @@
+(* TEST
+* hasunix
+include unix
+** bytecode
+** native
+*)
+
+let _ =
+  let key_array =
+    Array.init 128 (fun i -> Domain.DLS.new_key (fun _ -> i))
+  in
+  assert (Domain.DLS.get (key_array.(42)) = 42);
+  let d = Domain.spawn (fun _ ->
+    assert (Domain.DLS.get (key_array.(63)) = 63))
+  in
+  Domain.join d;
+  print_endline "OK"
diff --git a/testsuite/tests/parallel/domain_dls2.reference b/testsuite/tests/parallel/domain_dls2.reference
new file mode 100644
index 0000000000..d86bac9de5
--- /dev/null
+++ b/testsuite/tests/parallel/domain_dls2.reference
@@ -0,0 +1 @@
+OK