Merge pull request #13047 from NickBarnes/nick-reinstate-poll-primitive

Add Sys.poll_actions to run pending runtime actions

Changes

@@ -44,6 +44,10 @@ _______________
   (Kate Deplaix and Oscar Butler-Aldridge review by Nicolás Ojeda Bär,
    Craig Ferguson and Gabriel Scherer)
 
+- #13047: Add Sys.poll_actions to (only) run pending runtime actions.
+  (Nick Barnes, review by Gabriel Scherer, Guillaume Munch-Maccagnoni, and
+  Vincent Laviron)
+
 ### Other libraries:
 
 ### Tools:

asmcomp/cmm.ml

@@ -169,6 +169,7 @@ and operation =
   | Ccheckbound
   | Copaque
   | Cdls_get
+  | Cpoll
 
 type expression =
     Cconst_int of int * Debuginfo.t

asmcomp/cmm.mli

@@ -168,6 +168,7 @@ and operation =
                    or equal to the bound. *)
   | Copaque (* Sys.opaque_identity *)
   | Cdls_get
+  | Cpoll
 
 (** Every basic block should have a corresponding [Debuginfo.t] for its
     beginning. *)

asmcomp/cmmgen.ml

@@ -529,7 +529,7 @@ let rec transl env e =
          | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
          | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _
          | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _
-         | Pbbswap _), _)
+         | Pbbswap _ | Ppoll ), _)
         ->
           fatal_error "Cmmgen.transl:prim"
       end
@@ -836,6 +836,9 @@ and transl_prim_1 env p arg dbg =
       Cop(mk_load_atomic Word_int, [transl env arg], dbg)
   | Patomic_load {immediate_or_pointer = Pointer} ->
       Cop(mk_load_atomic Word_val, [transl env arg], dbg)
+  | Ppoll ->
+    (Csequence (remove_unit (transl env arg),
+                return_unit dbg (Cop(Cpoll, [], dbg))))
   | (Pfield_computed | Psequand | Psequor
     | Prunstack | Presume | Preperform
     | Patomic_exchange | Patomic_cas | Patomic_fetch_add
@@ -1038,7 +1041,7 @@ and transl_prim_2 env p arg1 arg2 dbg =
   | Pmakearray (_, _) | Pduparray (_, _) | Parraylength _ | Parraysetu _
   | Parraysets _ | Pbintofint _ | Pintofbint _ | Pcvtbint (_, _)
   | Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _)
-  | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _
+  | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _ | Ppoll
     ->
       fatal_errorf "Cmmgen.transl_prim_2: %a"
         Printclambda_primitives.primitive p
@@ -1116,7 +1119,7 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
   | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _
   | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _)
   | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _
-  | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _
+  | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ | Ppoll
     ->
       fatal_errorf "Cmmgen.transl_prim_3: %a"
         Printclambda_primitives.primitive p
@@ -1149,7 +1152,7 @@ and transl_prim_4 env p arg1 arg2 arg3 arg4 dbg =
   | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _
   | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _)
   | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _
-  | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _
+  | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ | Ppoll
     ->
       fatal_errorf "Cmmgen.transl_prim_3: %a"
         Printclambda_primitives.primitive p

asmcomp/printcmm.ml

@@ -159,6 +159,7 @@ let operation d = function
   | Ccheckbound -> "checkbound" ^ location d
   | Copaque -> "opaque"
   | Cdls_get -> "dls_get"
+  | Cpoll -> "poll"
 
 let rec expr ppf = function
   | Cconst_int (n, _dbg) -> fprintf ppf "%i" n

asmcomp/selectgen.ml

@@ -87,6 +87,7 @@ let oper_result_type = function
   | Craise _ -> typ_void
   | Ccheckbound -> typ_void
   | Copaque -> typ_val
+  | Cpoll -> typ_void
 
 (* Infer the size in bytes of the result of an expression whose evaluation
    may be deferred (cf. [emit_parts]). *)
@@ -325,7 +326,8 @@ method is_simple_expr = function
   | Cop(op, args, _) ->
       begin match op with
         (* The following may have side effects *)
-      | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ | Copaque -> false
+      | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ | Copaque
+      | Cpoll -> false
         (* The remaining operations are simple if their args are *)
       | Cload _ | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor
       | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf
@@ -365,7 +367,7 @@ method effects_of exp =
   | Cop (op, args, _) ->
     let from_op =
       match op with
-      | Capply _ | Cextcall _ | Copaque -> EC.arbitrary
+      | Capply _ | Cextcall _ | Copaque | Cpoll -> EC.arbitrary
       | Calloc -> EC.none
       | Cstore _ -> EC.effect_only Effect.Arbitrary
       | Craise _ | Ccheckbound -> EC.effect_only Effect.Raise
@@ -433,6 +435,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, _) -> (Ialloc {bytes = 0; dbginfo = []}), args
   | (Caddi, _) -> self#select_arith_comm Iadd args
   | (Csubi, _) -> self#select_arith Isub args

asmcomp/thread_sanitizer.ml

@@ -146,7 +146,7 @@ let wrap_entry_exit expr =
           ( ( Calloc | Caddi | Csubi | Cmuli | Cdivi | Cmodi | Cand | Cmulhi
             | Cor | Cxor | Clsl | Clsr | Casr | Caddv | Cadda | Cnegf | Cabsf
             | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat
-            | Ccheckbound | Copaque | Cdls_get | Capply _ | Cextcall _
+            | Ccheckbound | Copaque | Cdls_get | Cpoll | Capply _ | Cextcall _
             | Cload _ | Cstore _ | Ccmpi _ | Ccmpa _ | Ccmpf _ | Craise _ ),
             _,
             _ )
@@ -254,8 +254,8 @@ let instrument body =
         ( (( Capply _ | Caddi | Calloc | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
            | Cand | Cor | Cxor | Clsl | Clsr | Casr | Caddv | Cadda | Cnegf
            | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat
-           | Ccheckbound | Copaque | Cdls_get | Cextcall _ | Ccmpi _ | Ccmpa _
-           | Ccmpf _ ) as op),
+           | Ccheckbound | Copaque | Cdls_get | Cpoll | Cextcall _ | Ccmpi _
+           | Ccmpa _ | Ccmpf _ ) as op),
           es,
           dbg_none ) ->
       Cop (op, List.map aux es, dbg_none)

bytecomp/bytegen.ml

@@ -142,7 +142,7 @@ let rec is_tailcall = function
 
 let preserve_tailcall_for_prim = function
   | Popaque | Psequor | Psequand
-  | Prunstack | Pperform | Presume | Preperform ->
+  | Prunstack | Pperform | Presume | Preperform | Ppoll ->
       true
   | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
   | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _
@@ -493,6 +493,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)
   (* The cases below are handled in [comp_expr] before the [comp_primitive] call
      (in the order in which they appear below),
      so they should never be reached in this function. *)

lambda/lambda.ml

@@ -151,6 +151,8 @@ type primitive =
   | Popaque
   (* Fetching domain-local state *)
   | Pdls_get
+  (* Poll for runtime actions *)
+  | Ppoll
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

lambda/lambda.mli

@@ -161,6 +161,10 @@ type primitive =
   | Popaque
   (* 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
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

lambda/printlambda.ml

@@ -359,6 +359,7 @@ let primitive ppf = function
   | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add"
   | Popaque -> fprintf ppf "opaque"
   | Pdls_get -> fprintf ppf "dls_get"
+  | Ppoll -> fprintf ppf "poll"
 
 let name_of_primitive = function
   | Pbytes_of_string -> "Pbytes_of_string"
@@ -474,6 +475,7 @@ let name_of_primitive = function
   | Pperform -> "Pperform"
   | Preperform -> "Preperform"
   | Pdls_get -> "Pdls_get"
+  | Ppoll -> "Ppoll"
 
 let function_attribute ppf t =
   if t.is_a_functor then

lambda/tmc.ml

@@ -895,6 +895,7 @@ let rec choice ctx t =
     | Pbbswap _
     | Pint_as_pointer
     | Psequand | Psequor
+    | Ppoll
       ->
         let primargs = traverse_list ctx primargs in
         Choice.lambda (Lprim (prim, primargs, loc))

lambda/translprim.ml

@@ -374,6 +374,7 @@ let primitives_table =
     "%perform", Primitive (Pperform, 1);
     "%resume", Primitive (Presume, 4);
     "%dls_get", Primitive (Pdls_get, 1);
+    "%poll", Primitive (Ppoll, 1);
   ]
 
 
@@ -813,7 +814,7 @@ let lambda_primitive_needs_event_after = function
   | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _
   | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _
   | Prunstack | Pperform | Preperform | Presume
-  | Pbbswap _ -> true
+  | Pbbswap _ | Ppoll -> true
 
   | Pbytes_to_string | Pbytes_of_string | Pignore | Psetglobal _
   | Pgetglobal _ | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _

lambda/value_rec_compiler.ml

@@ -197,11 +197,12 @@ let compute_static_size lam =
     | Pbytes_set_64 _
     | Pbigstring_set_16 _
     | Pbigstring_set_32 _
-    | Pbigstring_set_64 _ ->
+    | Pbigstring_set_64 _
+    | Ppoll ->
         (* Unit-returning primitives. Most of these are only generated from
            external declarations and not special-cased by [Value_rec_check],
            but it doesn't hurt to be consistent. *)
-        Constant
+      Constant
 
     | Pduprecord (repres, size) ->
         begin match repres with

middle_end/clambda_primitives.ml

@@ -128,6 +128,8 @@ type primitive =
   | Popaque
   (* Fetch domain-local state *)
   | Pdls_get
+  (* Poll for runtime actions *)
+  | Ppoll
 
 and integer_comparison = Lambda.integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

middle_end/clambda_primitives.mli

@@ -131,7 +131,8 @@ type primitive =
   | Popaque
   (* Fetch domain-local state *)
   | Pdls_get
-
+  (* Poll for runtime actions *)
+  | Ppoll
 
 and integer_comparison = Lambda.integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

middle_end/convert_primitives.ml

@@ -151,6 +151,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Patomic_fetch_add -> Patomic_fetch_add
   | Popaque -> Popaque
   | Pdls_get -> Pdls_get
+  | Ppoll -> Ppoll
   | Pbytes_to_string
   | Pbytes_of_string
   | Pctconst _

middle_end/internal_variable_names.ml

@@ -178,6 +178,7 @@ let pperform = "Pperform"
 let presume = "Presume"
 let preperform = "Preperform"
 let pdls_get = "Pdls_get"
+let ppoll = "Ppoll"
 
 let pabsfloat_arg = "Pabsfloat_arg"
 let paddbint_arg = "Paddbint_arg"
@@ -290,6 +291,7 @@ let pperform_arg = "Pperform_arg"
 let presume_arg = "Presume_arg"
 let preperform_arg = "Preperform_arg"
 let pdls_get_arg = "Pdls_get_arg"
+let ppoll_arg = "Ppoll_arg"
 
 let raise = "raise"
 let raise_arg = "raise_arg"
@@ -434,6 +436,7 @@ let of_primitive : Lambda.primitive -> string = function
   | Presume -> presume
   | Preperform -> preperform
   | Pdls_get -> pdls_get
+  | Ppoll -> ppoll
 
 let of_primitive_arg : Lambda.primitive -> string = function
   | Pbytes_of_string -> pbytes_of_string_arg
@@ -546,3 +549,4 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Presume -> presume_arg
   | Preperform -> preperform_arg
   | Pdls_get -> pdls_get_arg
+  | Ppoll -> ppoll_arg

middle_end/printclambda_primitives.ml

@@ -222,3 +222,4 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
   | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add"
   | Popaque -> fprintf ppf "opaque"
   | Pdls_get -> fprintf ppf "dls_get"
+  | Ppoll -> fprintf ppf "poll"

middle_end/semantics_of_primitives.ml

@@ -133,7 +133,7 @@ let for_primitive (prim : Clambda_primitives.primitive) =
   | Pbswap16
   | Pbbswap _ -> No_effects, No_coeffects
   | Pint_as_pointer -> No_effects, No_coeffects
-  | Popaque -> Arbitrary_effects, Has_coeffects
+  | Popaque | Ppoll -> Arbitrary_effects, Has_coeffects
   | Psequand
   | Psequor ->
       (* Removed by [Closure_conversion] in the flambda pipeline. *)

runtime/signals.c

@@ -389,7 +389,7 @@ value caml_process_pending_actions_with_root_exn(value root)
   return root;
 }
 
-value caml_process_pending_actions_with_root(value root)
+CAMLprim value caml_process_pending_actions_with_root(value root)
 {
   return caml_raise_if_exception(
     caml_process_pending_actions_with_root_exn(root));

stdlib/sys.ml.in

@@ -47,6 +47,7 @@ let max_floatarray_length = max_array_length / (64 / word_size)
 let max_string_length = word_size / 8 * max_array_length - 1
 external runtime_variant : unit -> string = "caml_runtime_variant"
 external runtime_parameters : unit -> string = "caml_runtime_parameters"
+external poll_actions : unit -> unit = "%poll"
 
 external file_exists: string -> bool = "caml_sys_file_exists"
 external is_directory : string -> bool = "caml_sys_is_directory"

stdlib/sys.mli

@@ -208,6 +208,10 @@ external runtime_parameters : unit -> string = "caml_runtime_parameters"
     as the contents of the [OCAMLRUNPARAM] environment variable.
     @since 4.03 *)
 
+external poll_actions : unit -> unit = "%poll"
+(** Run any pending runtime actions, such as minor collections, major
+    GC slices, signal handlers, finalizers, or memprof callbacks. *)
+
 
 (** {1 Signal handling} *)