Enable Domain module fully on runtime5 (#2464)

Author: mshinwell

backend/cmm_helpers.ml

@@ -4106,3 +4106,5 @@ let allocate_unboxed_nativeint_array =
 
 (* Drop internal optional arguments from exported interface *)
 let block_header x y = block_header x y
+
+let dls_get ~dbg = Cop (Cdls_get, [], dbg)

backend/cmm_helpers.mli

@@ -1067,3 +1067,5 @@ val setfield_unboxed_int32 : ternary_primitive
 val setfield_unboxed_float32 : ternary_primitive
 
 val setfield_unboxed_int64_or_nativeint : ternary_primitive
+
+val dls_get : dbg:Debuginfo.t -> expression

backend/zero_alloc_checker.ml

@@ -2247,7 +2247,7 @@ end = struct
       let w = create_witnesses t (Extcall { callee = func }) dbg in
       transform_top t ~next ~exn w ("external call to " ^ func) dbg
     | Ispecific s -> transform_specific t s ~next ~exn dbg
-    | Idls_get -> Misc.fatal_error "Idls_get not supported"
+    | Idls_get -> next
 
   module D = Dataflow.Backward ((Value : Dataflow.DOMAIN))
 
@@ -2574,7 +2574,7 @@ end = struct
           in
           transform t ~effect ~next ~exn:Value.bot "heap allocation" dbg
         | Specific s -> transform_specific t s ~next ~exn:Value.bot dbg
-        | Dls_get -> Misc.fatal_error "Idls_get not supported"
+        | Dls_get -> next
 
       let basic next (i : Cfg.basic Cfg.instruction) t : (domain, error) result
           =

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -702,9 +702,10 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Punboxed_product_field _ | Pget_header _ ->
     false
   | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ -> false
-  | Prunstack | Pperform | Presume | Preperform | Pdls_get ->
+  | Prunstack | Pperform | Presume | Preperform ->
     Misc.fatal_errorf "Primitive %a is not yet supported by Flambda 2"
       Printlambda.primitive prim
+  | Pdls_get -> false
 
 type non_tail_continuation =
   Acc.t ->

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -1887,6 +1887,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
     [Ternary (Atomic_compare_and_set, atomic, old_value, new_value)]
   | Patomic_fetch_add, [[atomic]; [i]] ->
     [Binary (Atomic_fetch_and_add, atomic, i)]
+  | Pdls_get, _ -> [Nullary Dls_get]
   | ( ( Pmodint Unsafe
       | Pdivbint { is_safe = Unsafe; size = _; mode = _ }
       | Pmodbint { is_safe = Unsafe; size = _; mode = _ }
@@ -2000,7 +2001,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
     Misc.fatal_errorf
       "[%a] should have been handled by [Closure_conversion.close_primitive]"
       Printlambda.primitive prim
-  | (Prunstack | Pperform | Presume | Preperform | Pdls_get), _ ->
+  | (Prunstack | Pperform | Presume | Preperform), _ ->
     Misc.fatal_errorf "Primitive %a is not yet supported by Flambda 2"
       Printlambda.primitive prim
 

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -516,7 +516,8 @@ let nullop _env (op : Flambda_primitive.nullary_primitive) : Fexpr.nullop =
   match op with
   | Begin_region -> Begin_region
   | Begin_try_region -> Begin_try_region
-  | Invalid _ | Optimised_out _ | Probe_is_enabled _ | Enter_inlined_apply _ ->
+  | Invalid _ | Optimised_out _ | Probe_is_enabled _ | Enter_inlined_apply _
+  | Dls_get ->
     Misc.fatal_errorf "TODO: Nullary primitive: %a" Flambda_primitive.print
       (Flambda_primitive.Nullary op)
 

middle_end/flambda2/simplify/simplify_nullary_primitive.ml

@@ -49,3 +49,8 @@ let simplify_nullary_primitive dacc original_prim (prim : P.nullary_primitive)
     let ty = T.this_tagged_immediate Targetint_31_63.zero in
     let dacc = DA.add_variable dacc result_var ty in
     Simplify_primitive_result.create named ~try_reify:false dacc
+  | Dls_get ->
+    let named = Named.create_prim original_prim dbg in
+    let ty = T.any_value in
+    let dacc = DA.add_variable dacc result_var ty in
+    Simplify_primitive_result.create named ~try_reify:false dacc

middle_end/flambda2/terms/code_size.ml

@@ -341,6 +341,7 @@ let nullary_prim_size prim =
   | Begin_region -> 1
   | Begin_try_region -> 1
   | Enter_inlined_apply _ -> 0
+  | Dls_get -> 1
 
 let unary_prim_size prim =
   match (prim : Flambda_primitive.unary_primitive) with

middle_end/flambda2/terms/flambda_primitive.ml

@@ -937,10 +937,11 @@ type nullary_primitive =
   | Begin_region
   | Begin_try_region
   | Enter_inlined_apply of { dbg : Inlined_debuginfo.t }
+  | Dls_get
 
 let nullary_primitive_eligible_for_cse = function
   | Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-  | Begin_try_region | Enter_inlined_apply _ ->
+  | Begin_try_region | Enter_inlined_apply _ | Dls_get ->
     false
 
 let compare_nullary_primitive p1 p2 =
@@ -953,29 +954,35 @@ let compare_nullary_primitive p1 p2 =
   | Begin_try_region, Begin_try_region -> 0
   | Enter_inlined_apply { dbg = dbg1 }, Enter_inlined_apply { dbg = dbg2 } ->
     Inlined_debuginfo.compare dbg1 dbg2
+  | Dls_get, Dls_get -> 0
   | ( Invalid _,
       ( Optimised_out _ | Probe_is_enabled _ | Begin_region | Begin_try_region
-      | Enter_inlined_apply _ ) ) ->
+      | Enter_inlined_apply _ | Dls_get ) ) ->
     -1
   | ( Optimised_out _,
       ( Probe_is_enabled _ | Begin_region | Begin_try_region
-      | Enter_inlined_apply _ ) ) ->
+      | Enter_inlined_apply _ | Dls_get ) ) ->
     -1
   | Optimised_out _, Invalid _ -> 1
-  | Probe_is_enabled _, (Begin_region | Begin_try_region | Enter_inlined_apply _)
-    ->
+  | ( Probe_is_enabled _,
+      (Begin_region | Begin_try_region | Enter_inlined_apply _ | Dls_get) ) ->
     -1
   | Probe_is_enabled _, (Invalid _ | Optimised_out _) -> 1
-  | Begin_region, (Begin_try_region | Enter_inlined_apply _) -> -1
+  | Begin_region, (Begin_try_region | Enter_inlined_apply _ | Dls_get) -> -1
   | Begin_region, (Invalid _ | Optimised_out _ | Probe_is_enabled _) -> 1
-  | Begin_try_region, Enter_inlined_apply _ -> -1
+  | Begin_try_region, (Enter_inlined_apply _ | Dls_get) -> -1
   | ( Begin_try_region,
       (Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region) ) ->
     1
   | ( Enter_inlined_apply _,
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
       | Begin_try_region ) ) ->
     1
+  | Enter_inlined_apply _, Dls_get -> -1
+  | ( Dls_get,
+      ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
+      | Begin_try_region | Enter_inlined_apply _ ) ) ->
+    1
 
 let equal_nullary_primitive p1 p2 = compare_nullary_primitive p1 p2 = 0
 
@@ -994,6 +1001,7 @@ let print_nullary_primitive ppf p =
   | Enter_inlined_apply { dbg } ->
     Format.fprintf ppf "@[<hov 1>(Enter_inlined_apply@ %a)@]"
       Inlined_debuginfo.print dbg
+  | Dls_get -> Format.pp_print_string ppf "Dls_get"
 
 let result_kind_of_nullary_primitive p : result_kind =
   match p with
@@ -1003,6 +1011,7 @@ let result_kind_of_nullary_primitive p : result_kind =
   | Begin_region -> Singleton K.region
   | Begin_try_region -> Singleton K.region
   | Enter_inlined_apply _ -> Unit
+  | Dls_get -> Singleton K.value
 
 let coeffects_of_mode : Alloc_mode.For_allocations.t -> Coeffects.t = function
   | Local _ -> Coeffects.Has_coeffects
@@ -1025,11 +1034,12 @@ let effects_and_coeffects_of_nullary_primitive p : Effects_and_coeffects.t =
     (* This doesn't really have effects, but without effects, these primitives
        get deleted during lambda_to_flambda. *)
     Arbitrary_effects, Has_coeffects, Strict
+  | Dls_get -> No_effects, Has_coeffects, Strict
 
 let nullary_classify_for_printing p =
   match p with
   | Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-  | Begin_try_region | Enter_inlined_apply _ ->
+  | Begin_try_region | Enter_inlined_apply _ | Dls_get ->
     Neither
 
 type unary_primitive =
@@ -2187,7 +2197,7 @@ let free_names t =
   match t with
   | Nullary
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-      | Begin_try_region | Enter_inlined_apply _ ) ->
+      | Begin_try_region | Enter_inlined_apply _ | Dls_get ) ->
     Name_occurrences.empty
   | Unary (prim, x0) ->
     Name_occurrences.union
@@ -2214,7 +2224,7 @@ let apply_renaming t renaming =
   match t with
   | Nullary
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-      | Begin_try_region | Enter_inlined_apply _ ) ->
+      | Begin_try_region | Enter_inlined_apply _ | Dls_get ) ->
     t
   | Unary (prim, x0) ->
     let prim' = apply_renaming_unary_primitive prim renaming in
@@ -2244,7 +2254,7 @@ let ids_for_export t =
   match t with
   | Nullary
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-      | Begin_try_region | Enter_inlined_apply _ ) ->
+      | Begin_try_region | Enter_inlined_apply _ | Dls_get ) ->
     Ids_for_export.empty
   | Unary (prim, x0) ->
     Ids_for_export.union

middle_end/flambda2/terms/flambda_primitive.mli

@@ -325,6 +325,7 @@ type nullary_primitive =
   | Enter_inlined_apply of { dbg : Inlined_debuginfo.t }
       (** Used in classic mode to denote the start of an inlined function body.
           This is then used in to_cmm to correctly add inlined debuginfo. *)
+  | Dls_get  (** Obtain the domain-local state block. *)
 
 (** Untagged binary integer arithmetic operations.
 

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -664,6 +664,7 @@ let nullary_primitive _env res dbg prim =
       "The primitive [Enter_inlined_apply] should not be translated by \
        [to_cmm_primitive] but should instead be handled in [to_cmm_expr] to \
        correctly adjust the inlined debuginfo in the env."
+  | Dls_get -> None, res, C.dls_get ~dbg
 
 let unary_primitive env res dbg f arg =
   match (f : P.unary_primitive) with

ocaml/asmcomp/amd64/emit.mlp

@@ -932,7 +932,7 @@ let emit_instr env fallthrough i =
     I.movzx (res8 i 0) (res i 0)
   | Lop (Idls_get) ->
     if Config.runtime5
-    then  I.mov (domain_field Domainstate.Domain_dls_root) (res i 0)
+    then I.mov (domain_field Domainstate.Domain_dls_root) (res i 0)
     else Misc.fatal_error "Idls_get not implemented in runtime4."
   | Lreloadretaddr ->
       ()

ocaml/middle_end/semantics_of_primitives.ml

@@ -160,7 +160,7 @@ let for_primitive (prim : Clambda_primitives.primitive) =
   | Pget_header _ -> No_effects, No_coeffects
   | Pdls_get ->
       (* only read *)
-      No_effects, No_coeffects
+      No_effects, Has_coeffects
 
 type return_type =
   | Float

ocaml/runtime4/domain.c

@@ -175,3 +175,40 @@ CAMLprim value caml_ml_condition_broadcast(value wrapper)
 
   return (*caml_hook_condition_broadcast)(wrapper);
 }
+
+/* Dummy implementations to enable [Stdlib.Domain] to link. */
+
+CAMLprim value caml_recommended_domain_count(void)
+{
+  caml_failwith("Domains not supported on runtime4");
+}
+
+CAMLprim value caml_ml_domain_cpu_relax(void)
+{
+  caml_failwith("Domains not supported on runtime4");
+}
+
+CAMLprim value caml_init_domain_self(void)
+{
+  caml_failwith("Domains not supported on runtime4");
+}
+
+CAMLprim value caml_domain_spawn(void)
+{
+  caml_failwith("Domains not supported on runtime4");
+}
+
+CAMLprim value caml_ml_domain_id(void)
+{
+  caml_failwith("Domains not supported on runtime4");
+}
+
+CAMLprim value caml_domain_dls_set(void)
+{
+  caml_failwith("Domains not supported on runtime4");
+}
+
+CAMLprim value caml_domain_dls_get(void)
+{
+  caml_failwith("Domains not supported on runtime4");
+}