Runtime cherry picks: upstream trunk -> 5.2

.vscode/settings.json

@@ -8,6 +8,7 @@
                 "smmintrin.h": "c",
                 "tmmintrin.h": "c",
                 "pmmintrin.h": "c",
-                "*.tbl": "c"
+                "*.tbl": "c",
+                "platform.h": "c"
         }
 }

backend/amd64/proc.ml

@@ -751,6 +751,7 @@ let operation_supported = function
   | Cprobe _ | Cprobe_is_enabled _ | Copaque | Cbeginregion | Cendregion
   | Ctuple_field _
   | Cdls_get
+  | Cpoll
     -> true
 
 let trap_size_in_bytes = 16

backend/arm64/emit.mlp

@@ -1197,8 +1197,7 @@ let emit_instr i =
     | Lpushtrap { lbl_handler; } ->
         `	adr	{emit_reg reg_tmp1}, {emit_label lbl_handler}\n`;
         stack_offset := !stack_offset + 16;
-        `	str	{emit_reg reg_trap_ptr}, [sp, -16]!\n`;
-        `	str	{emit_reg reg_tmp1}, [sp, #8]\n`;
+        `	stp	{emit_reg reg_trap_ptr}, {emit_reg reg_tmp1}, [sp, -16]!\n`;
         cfi_adjust_cfa_offset 16;
         `	mov	{emit_reg reg_trap_ptr}, sp\n`
     | Lpoptrap ->
@@ -1218,8 +1217,7 @@ let emit_instr i =
           `{record_frame Reg.Set.empty (Dbg_raise i.dbg)}\n`
         | Lambda.Raise_notrace ->
           `	mov	sp, {emit_reg reg_trap_ptr}\n`;
-          `	ldr	{emit_reg reg_tmp1}, [sp, #8]\n`;
-          `	ldr	{emit_reg reg_trap_ptr}, [sp], 16\n`;
+          `	ldp	{emit_reg reg_trap_ptr}, {emit_reg reg_tmp1}, [sp], 16\n`;
           `	br	{emit_reg reg_tmp1}\n`
       end
     | Lstackcheck { max_frame_size_bytes; } ->

backend/arm64/proc.ml

@@ -513,6 +513,7 @@ let operation_supported = function
   | Cprobe _ | Cprobe_is_enabled _ | Copaque
   | Cbeginregion | Cendregion | Ctuple_field _
   | Cdls_get
+  | Cpoll
     -> true
 
 let trap_size_in_bytes = 16

backend/cmm.ml

@@ -267,6 +267,7 @@ type operation =
   | Cbeginregion | Cendregion
   | Ctuple_field of int * machtype array
   | Cdls_get
+  | Cpoll
 
 type kind_for_unboxing =
   | Any

backend/cmm.mli

@@ -253,6 +253,7 @@ type operation =
   | Ctuple_field of int * machtype array
       (* the [machtype array] refers to the whole tuple *)
   | Cdls_get
+  | Cpoll
 
 (* This is information used exclusively during construction of cmm terms by
    cmmgen, and thus irrelevant for selectgen and flambda2. *)

backend/cmm_helpers.ml

@@ -4234,3 +4234,5 @@ let reperform ~dbg ~eff ~cont ~last_fiber =
         cont;
         last_fiber ],
       dbg )
+
+let poll ~dbg = return_unit dbg (Cop (Cpoll, [], dbg))

backend/cmm_helpers.mli

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

backend/printcmm.ml

@@ -271,6 +271,7 @@ let operation d = function
   | Ctuple_field (field, _ty) ->
     to_string "tuple_field %i" field
   | Cdls_get -> "dls_get"
+  | Cpoll -> "poll"
 
 let rec expr ppf = function
   | Cconst_int (n, _dbg) -> fprintf ppf "%i" n

backend/selectgen.ml

@@ -193,6 +193,7 @@ let oper_result_type = function
   | Cprobe _ -> typ_void
   | Cprobe_is_enabled _ -> typ_int
   | Copaque -> typ_val
+  | Cpoll -> typ_void
   | Cbeginregion ->
     (* This must not be typ_val; the begin-region operation returns a
        naked pointer into the local allocation stack. *)
@@ -495,7 +496,8 @@ method is_simple_expr = function
         (* The following may have side effects *)
       | Capply _ | Cextcall _ | Calloc _ | Cstore _
       | Craise _ | Catomic _
-      | Cprobe _ | Cprobe_is_enabled _ | Copaque -> false
+      | Cprobe _ | Cprobe_is_enabled _ | Copaque
+      | Cpoll -> false
       | Cprefetch _ | Cbeginregion | Cendregion -> false (* avoid reordering *)
         (* The remaining operations are simple if their args are *)
       | Cload _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor
@@ -542,7 +544,7 @@ method effects_of exp =
       match op with
       | Cextcall { effects = e; coeffects = ce; } ->
         EC.create (select_effects e) (select_coeffects ce)
-      | Capply _ | Cprobe _ | Copaque -> EC.arbitrary
+      | Capply _ | Cprobe _ | Copaque | Cpoll -> EC.arbitrary
       | Calloc Alloc_heap -> EC.none
       | Calloc Alloc_local -> EC.coeffect_only Coeffect.Arbitrary
       | Cstore _ -> EC.effect_only Effect.Arbitrary
@@ -655,6 +657,7 @@ method select_operation op args _dbg =
         (* Inversion addr/datum in Istore *)
       end
   | (Cdls_get, _) -> Idls_get, args
+  | (Cpoll, _) -> (Ipoll { return_label = None }), args
   | (Calloc mode, _) -> (Ialloc {bytes = 0; dbginfo = []; mode}), args
   | (Caddi, _) -> self#select_arith_comm Iadd args
   | (Csubi, _) -> self#select_arith Isub args

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -992,7 +992,7 @@ let close_primitive acc env ~let_bound_ids_with_kinds named
       | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _
       | Punboxed_product_field _ | Pget_header _ | Prunstack | Pperform
       | Presume | Preperform | Patomic_exchange | Patomic_cas
-      | Patomic_fetch_add | Pdls_get | Patomic_load _
+      | Patomic_fetch_add | Pdls_get | Ppoll | Patomic_load _
       | Preinterpret_tagged_int63_as_unboxed_int64
       | Preinterpret_unboxed_int64_as_tagged_int63 ->
         (* Inconsistent with outer match *)

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -758,7 +758,7 @@ let primitive_can_raise (prim : Lambda.primitive) =
     false
   | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ -> false
   | Prunstack | Pperform | Presume | Preperform -> true (* XXX! *)
-  | Pdls_get | Preinterpret_tagged_int63_as_unboxed_int64
+  | Pdls_get | Ppoll | Preinterpret_tagged_int63_as_unboxed_int64
   | Preinterpret_unboxed_int64_as_tagged_int63 ->
     false
 

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -1940,6 +1940,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
   | Patomic_fetch_add, [[atomic]; [i]] ->
     [Binary (Atomic_fetch_and_add, atomic, i)]
   | Pdls_get, _ -> [Nullary Dls_get]
+  | Ppoll, _ -> [Nullary Poll]
   | Preinterpret_unboxed_int64_as_tagged_int63, [[i]] ->
     if not (Target_system.is_64_bit ())
     then

middle_end/flambda2/parser/flambda_to_fexpr.ml

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

middle_end/flambda2/simplify/simplify_nullary_primitive.ml

@@ -54,3 +54,8 @@ let simplify_nullary_primitive dacc original_prim (prim : P.nullary_primitive)
     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
+  | Poll ->
+    let named = Named.create_prim original_prim dbg in
+    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

middle_end/flambda2/terms/code_size.ml

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

middle_end/flambda2/terms/flambda_primitive.ml

@@ -853,10 +853,11 @@ type nullary_primitive =
   | Begin_try_region
   | Enter_inlined_apply of { dbg : Inlined_debuginfo.t }
   | Dls_get
+  | Poll
 
 let nullary_primitive_eligible_for_cse = function
   | Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-  | Begin_try_region | Enter_inlined_apply _ | Dls_get ->
+  | Begin_try_region | Enter_inlined_apply _ | Dls_get | Poll ->
     false
 
 let compare_nullary_primitive p1 p2 =
@@ -870,34 +871,42 @@ let compare_nullary_primitive p1 p2 =
   | Enter_inlined_apply { dbg = dbg1 }, Enter_inlined_apply { dbg = dbg2 } ->
     Inlined_debuginfo.compare dbg1 dbg2
   | Dls_get, Dls_get -> 0
+  | Poll, Poll -> 0
   | ( Invalid _,
       ( Optimised_out _ | Probe_is_enabled _ | Begin_region | Begin_try_region
-      | Enter_inlined_apply _ | Dls_get ) ) ->
+      | Enter_inlined_apply _ | Dls_get | Poll ) ) ->
     -1
   | ( Optimised_out _,
       ( Probe_is_enabled _ | Begin_region | Begin_try_region
-      | Enter_inlined_apply _ | Dls_get ) ) ->
+      | Enter_inlined_apply _ | Dls_get | Poll ) ) ->
     -1
   | Optimised_out _, Invalid _ -> 1
   | ( Probe_is_enabled _,
-      (Begin_region | Begin_try_region | Enter_inlined_apply _ | Dls_get) ) ->
+      (Begin_region | Begin_try_region | Enter_inlined_apply _ | Dls_get | Poll)
+    ) ->
     -1
   | Probe_is_enabled _, (Invalid _ | Optimised_out _) -> 1
-  | Begin_region, (Begin_try_region | Enter_inlined_apply _ | Dls_get) -> -1
+  | Begin_region, (Begin_try_region | Enter_inlined_apply _ | Dls_get | Poll) ->
+    -1
   | Begin_region, (Invalid _ | Optimised_out _ | Probe_is_enabled _) -> 1
-  | Begin_try_region, (Enter_inlined_apply _ | Dls_get) -> -1
+  | Begin_try_region, (Enter_inlined_apply _ | Dls_get | Poll) -> -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
+  | Enter_inlined_apply _, (Dls_get | Poll) -> -1
   | ( Dls_get,
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
       | Begin_try_region | Enter_inlined_apply _ ) ) ->
     1
+  | Dls_get, Poll -> -1
+  | ( Poll,
+      ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
+      | Begin_try_region | Enter_inlined_apply _ | Dls_get ) ) ->
+    1
 
 let equal_nullary_primitive p1 p2 = compare_nullary_primitive p1 p2 = 0
 
@@ -917,6 +926,7 @@ let print_nullary_primitive ppf p =
     Format.fprintf ppf "@[<hov 1>(Enter_inlined_apply@ %a)@]"
       Inlined_debuginfo.print dbg
   | Dls_get -> Format.pp_print_string ppf "Dls_get"
+  | Poll -> Format.pp_print_string ppf "Poll"
 
 let result_kind_of_nullary_primitive p : result_kind =
   match p with
@@ -927,6 +937,7 @@ let result_kind_of_nullary_primitive p : result_kind =
   | Begin_try_region -> Singleton K.region
   | Enter_inlined_apply _ -> Unit
   | Dls_get -> Singleton K.value
+  | Poll -> Unit
 
 let coeffects_of_mode : Alloc_mode.For_allocations.t -> Coeffects.t = function
   | Local _ -> Coeffects.Has_coeffects
@@ -950,11 +961,12 @@ let effects_and_coeffects_of_nullary_primitive p : Effects_and_coeffects.t =
        get deleted during lambda_to_flambda. *)
     Arbitrary_effects, Has_coeffects, Strict
   | Dls_get -> No_effects, Has_coeffects, Strict
+  | Poll -> Arbitrary_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 _ | Dls_get ->
+  | Begin_try_region | Enter_inlined_apply _ | Dls_get | Poll ->
     Neither
 
 module Reinterpret_64_bit_word = struct
@@ -2100,7 +2112,7 @@ let free_names t =
   match t with
   | Nullary
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-      | Begin_try_region | Enter_inlined_apply _ | Dls_get ) ->
+      | Begin_try_region | Enter_inlined_apply _ | Dls_get | Poll ) ->
     Name_occurrences.empty
   | Unary (prim, x0) ->
     Name_occurrences.union
@@ -2127,7 +2139,7 @@ let apply_renaming t renaming =
   match t with
   | Nullary
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-      | Begin_try_region | Enter_inlined_apply _ | Dls_get ) ->
+      | Begin_try_region | Enter_inlined_apply _ | Dls_get | Poll ) ->
     t
   | Unary (prim, x0) ->
     let prim' = apply_renaming_unary_primitive prim renaming in
@@ -2157,7 +2169,7 @@ let ids_for_export t =
   match t with
   | Nullary
       ( Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region
-      | Begin_try_region | Enter_inlined_apply _ | Dls_get ) ->
+      | Begin_try_region | Enter_inlined_apply _ | Dls_get | Poll ) ->
     Ids_for_export.empty
   | Unary (prim, x0) ->
     Ids_for_export.union

middle_end/flambda2/terms/flambda_primitive.mli

@@ -300,6 +300,10 @@ type nullary_primitive =
       (** 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. *)
+  | Poll
+      (** Poll for runtime actions. May run pending actions such as signal
+          handlers, finalizers, memprof callbacks, etc, as well as GCs and
+          GC slices, so should not be moved or optimised away. *)
 
 (** Untagged binary integer arithmetic operations.
 

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -678,6 +678,7 @@ let nullary_primitive _env res dbg prim =
        [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
+  | Poll -> None, res, C.poll ~dbg
 
 let unary_primitive env res dbg f arg =
   match (f : P.unary_primitive) with

ocaml/bytecomp/bytegen.ml

@@ -195,7 +195,7 @@ let preserve_tailcall_for_prim = function
   | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _
   | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
   | Pdls_get | Preinterpret_tagged_int63_as_unboxed_int64
-  | Preinterpret_unboxed_int64_as_tagged_int63 ->
+  | Preinterpret_unboxed_int64_as_tagged_int63 | Ppoll ->
       false
 
 (* Add a Kpop N instruction in front of a continuation *)
@@ -603,6 +603,7 @@ let comp_primitive stack_info p sz args =
   | Patomic_cas -> Kccall("caml_atomic_cas", 3)
   | Patomic_fetch_add -> Kccall("caml_atomic_fetch_add", 2)
   | Pdls_get -> Kccall("caml_domain_dls_get", 1)
+  | Ppoll -> Kccall("caml_process_pending_actions_with_root", 1)
   | Pstring_load_128 _ | Pbytes_load_128 _ | Pbytes_set_128 _
   | Pbigstring_load_128 _ | Pbigstring_set_128 _
   | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ | Pint_array_load_128 _

ocaml/configure.ac

@@ -1146,6 +1146,10 @@ AC_CHECK_HEADER([stdatomic.h], [AC_DEFINE([HAS_STDATOMIC_H])])
 
 AC_CHECK_HEADER([sys/mman.h], [AC_DEFINE([HAS_SYS_MMAN_H])])
 
+AS_CASE([$host],
+  [*-*-linux*],
+    [AC_CHECK_HEADER([linux/futex.h], [AC_DEFINE([HAS_LINUX_FUTEX_H])])])
+
 # Checks for types
 
 ## off_t
@@ -2766,11 +2770,12 @@ ocamlc_cppflags="$common_cppflags $CPPFLAGS"
 
 AS_CASE([$host],
   [*-*-mingw32*],
-    [cclibs="$cclibs -lole32 -luuid -lversion"],
+    [cclibs="$cclibs -lole32 -luuid -lversion -lshlwapi -lsynchronization"],
   [*-pc-windows],
-    [# For whatever reason, flexlink includes -ladvapi32 for mingw-w64, but
-    # doesn't include advapi32.lib for MSVC
-    cclibs="$cclibs ole32.lib uuid.lib advapi32.lib version.lib"])
+    [# For whatever reason, flexlink includes -ladvapi32 and -lshell32 for
+    # mingw-w64, but doesn't include advapi32.lib and shell32.lib for MSVC
+    cclibs="$cclibs ole32.lib uuid.lib advapi32.lib shell32.lib version.lib \
+shlwapi.lib synchronization.lib"])
 
 AC_CONFIG_COMMANDS_PRE([cclibs="$cclibs $mathlib $DLLIBS $PTHREAD_LIBS"])
 

ocaml/lambda/lambda.ml

@@ -313,6 +313,8 @@ type primitive =
   | Pget_header of alloc_mode
   (* Fetching domain-local state *)
   | Pdls_get
+  (* Poll for runtime actions *)
+  | Ppoll
 
 and extern_repr =
   | Same_as_ocaml_repr of Jkind.Sort.const
@@ -1808,8 +1810,9 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pobj_magic _ -> None
   | Punbox_float _ | Punbox_int _ -> None
   | Pbox_float (_, m) | Pbox_int (_, m) -> Some m
-  | Prunstack | Presume | Pperform | Preperform ->
+  | Prunstack | Presume | Pperform | Preperform
     (* CR mshinwell: check *)
+  | Ppoll ->
     Some alloc_heap
   | Patomic_load _
   | Patomic_exchange
@@ -2011,6 +2014,7 @@ let primitive_result_layout (p : primitive) =
   | Patomic_cas
   | Patomic_fetch_add
   | Pdls_get -> layout_any_value
+  | Ppoll -> layout_unit
   | Preinterpret_tagged_int63_as_unboxed_int64 -> layout_unboxed_int64
   | Preinterpret_unboxed_int64_as_tagged_int63 -> layout_int
 

ocaml/lambda/lambda.mli

@@ -313,6 +313,10 @@ type primitive =
      if the value is locally allocated *)
   (* Fetching domain-local state *)
   | Pdls_get
+  (* Poll for runtime actions. May run pending actions such as signal
+     handlers, finalizers, memprof callbacks, etc, as well as GCs and
+     GC slices, so should not be moved or optimised away. *)
+  | Ppoll
 
 (** This is the same as [Primitive.native_repr] but with [Repr_poly]
     compiled away. *)