Fix some data-races into mirage-crypto

config/cfg_domain.ml

@@ -0,0 +1,7 @@
+let parse s = Scanf.sscanf s "%d.%d" (fun major minor -> (major, minor))
+
+let () =
+  let version = parse Sys.ocaml_version in
+  if version >= (5, 0)
+  then print_string "domain.stable.ml"
+  else print_string "domain.pre500.ml"

config/dune

@@ -1,3 +1,13 @@
-(executables
- (names cfg)
+(executable
+ (name cfg)
+ (modules cfg)
  (libraries dune-configurator))
+
+(executable
+ (name cfg_domain)
+ (modules cfg_domain))
+
+(rule
+ (with-stdout-to
+  domain_shims
+  (run ./cfg_domain.exe)))

mirage-crypto-rng.opam

@@ -13,7 +13,7 @@ build: [ ["dune" "subst"] {dev}
          ["dune" "runtest" "-p" name "-j" jobs] {with-test} ]
 
 depends: [
-  "ocaml" {>= "4.08.0"}
+  "ocaml" {>= "4.12.0"}
   "dune" {>= "2.7"}
   "dune-configurator" {>= "2.0.0"}
   "duration"

rng/entropy.ml

@@ -43,19 +43,19 @@ module Cpu_native = struct
     | _ -> assert false
 end
 
-let _sources = ref []
+let _sources = Atomic.make []
 
 type source = Rng.source
 
 let register_source name =
-  let n = List.length !_sources in
+  let n = List.length (Atomic.get _sources) in
   let source = (n, name) in
-  _sources := source :: !_sources;
+  Atomic.set _sources (source :: (Atomic.get _sources));
   source
 
 let id (idx, _) = idx
 
-let sources () = !_sources
+let sources () = Atomic.get _sources
 
 let pp_source ppf (idx, name) = Format.fprintf ppf "[%d] %s" idx name
 

rng/rng.ml

@@ -54,14 +54,14 @@ let create (type a) ?g ?seed ?(strict=false) ?time (m : a generator) =
   Option.iter (M.reseed ~g) seed;
   Generator (g, strict, m)
 
-let _default_generator = ref None
+let _default_generator = Atomic.make None
 
-let set_default_generator g = _default_generator := Some g
+let set_default_generator g = Atomic.set _default_generator (Some g)
 
-let unset_default_generator () = _default_generator := None
+let unset_default_generator () = Atomic.set _default_generator None
 
 let default_generator () =
-  match !_default_generator with
+  match Atomic.get _default_generator with
   | None -> raise No_default_generator
   | Some g -> g
 

rng/unix/mirage_crypto_rng_unix.ml

@@ -16,10 +16,10 @@ let getrandom_init i =
   let data = getrandom 128 in
   Entropy.header i data
 
-let running = ref false
+let running = Atomic.make false
 
 let initialize (type a) ?g (rng : a generator) =
-  if !running then
+  if Atomic.get running then
     Log.debug
       (fun m -> m "Mirage_crypto_rng_unix.initialize has already been called, \
                    ignoring this call.")
@@ -30,7 +30,7 @@ let initialize (type a) ?g (rng : a generator) =
                              been set, check that this call is intentional");
      with
        No_default_generator -> ());
-    running := true ;
+    Atomic.set running true ;
     let seed =
       let init =
         Entropy.[ bootstrap ; whirlwind_bootstrap ; bootstrap ; getrandom_init ]

src/cipher_block.ml

@@ -89,14 +89,15 @@ module Counters = struct
     val unsafe_count_into : ctr -> Native.buffer -> int -> blocks:int -> unit
   end
 
-  let _tmp = Bytes.make 16 '\x00'
+  let _tmp = Domain_shims.DLS.new_key (Fun.const (Bytes.make 16 '\000'))
 
   module C64be = struct
     type ctr = int64
     let size = 8
     let of_cstruct cs = BE.get_uint64 cs 0
     let add = Int64.add
     let unsafe_count_into t buf off ~blocks =
+      let _tmp = Domain_shims.DLS.get _tmp in
       Bytes.set_int64_be _tmp 0 t;
       Native.count8be _tmp buf off ~blocks
   end
@@ -110,6 +111,7 @@ module Counters = struct
       let flip = if Int64.logxor w0 w0' < 0L then w0' > w0 else w0' < w0 in
       ((if flip then Int64.succ w1 else w1), w0')
     let unsafe_count_into (w1, w0) buf off ~blocks =
+      let _tmp = Domain_shims.DLS.get _tmp in
       Bytes.set_int64_be _tmp 0 w1; Bytes.set_int64_be _tmp 8 w0;
       Native.count16be _tmp buf off ~blocks
   end
@@ -120,6 +122,7 @@ module Counters = struct
       let hi = 0xffffffff00000000L and lo = 0x00000000ffffffffL in
       (w1, Int64.(logor (logand hi w0) (add n w0 |> logand lo)))
     let unsafe_count_into (w1, w0) buf off ~blocks =
+      let _tmp = Domain_shims.DLS.get _tmp in
       Bytes.set_int64_be _tmp 0 w1; Bytes.set_int64_be _tmp 8 w0;
       Native.count16be4 _tmp buf off ~blocks
   end
@@ -239,11 +242,12 @@ module Modes = struct
       assert (cs.len >= tagsize);
       let k = Bytes.create keysize in
       Native.GHASH.keyinit cs.buffer cs.off k; k
-    let _cs = create_unsafe tagsize
+    let _cs = Domain_shims.DLS.new_key (Fun.const (create_unsafe tagsize))
     let hash0 = Bytes.make tagsize '\x00'
     let digesti ~key i = (* Clobbers `_cs`! *)
       let res = Bytes.copy hash0 in
       i (fun cs -> Native.GHASH.ghash key res cs.buffer cs.off cs.len);
+      let _cs = Domain_shims.DLS.get _cs in
       blit_from_bytes res 0 _cs 0 tagsize; _cs
   end
 
@@ -256,15 +260,19 @@ module Modes = struct
 
     let tag_size = GHASH.tagsize
     let key_sizes, block_size = C.(key, block)
-    let z128, h = create block_size, create block_size
+    let z128 = Domain_shims.DLS.new_key (Fun.const (create block_size))
+    let h = Domain_shims.DLS.new_key (Fun.const (create block_size))
 
     let of_secret cs =
       let key = C.e_of_secret cs in
+      let z128 = Domain_shims.DLS.get z128 in
+      let h = Domain_shims.DLS.get h in
       C.encrypt ~key ~blocks:1 z128.buffer z128.off h.buffer h.off;
       { key ; hkey = GHASH.derive h }
 
     let bits64 cs = Int64.of_int (length cs * 8)
-    let pack64s = let _cs = create_unsafe 16 in fun a b ->
+    let _cs = Domain_shims.DLS.new_key (Fun.const (create_unsafe 16))
+    let pack64s = let _cs = Domain_shims.DLS.get _cs in fun a b ->
                     BE.set_uint64 _cs 0 a; BE.set_uint64 _cs 8 b; _cs
 
     let counter ~hkey nonce = match length nonce with

src/domain.pre500.ml

@@ -0,0 +1,14 @@
+module DLS = struct
+  type 'a key =
+    { init : unit -> 'a
+    ; cell : 'a option ref }
+
+  let new_key ?split_from_parent:_ fn =
+    { init= fn; cell= ref None }
+
+  let get { init; cell; } = match !cell with
+    | None -> cell := Some (init ()); Option.get !cell
+    | Some value -> value
+
+  let set { cell; _ } value = cell := Some value
+end

src/domain.stable.ml

@@ -0,0 +1 @@
+include Stdlib.Domain

src/dune

@@ -19,6 +19,9 @@
    (:standard)
    (:include cflags.sexp))))
 
+(rule
+ (copy %{read:../config/domain_shims} domain_shims.ml))
+
 (env
  (dev
   (c_flags (:include cflags_warn.sexp))))