Use [caml_something_to_do] both in native and bytecode mode to remember that callbacks are pending.

This make us able to get rid of to xxx_to_do variables in `final.c`
and `memprof.c`. The variable is reset to 0 when entering
`caml_check_urgent_gc`, which is now the main entry point for
asynchronous callbacks. In case a callback raises an exception, we
need to set it back to 1 to make sure no callback is missed.

13 files changed, 94 insertions, 102 deletions

diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
index db812318a7..e6e04a0650 100644
--- a/otherlibs/systhreads/st_stubs.c
+++ b/otherlibs/systhreads/st_stubs.c
@@ -748,12 +748,12 @@ CAMLprim value caml_thread_yield(value unit)        /* ML */
      our blocking section doesn't contain anything interesting, don't bother
      with saving errno.)
   */
-  caml_async_callbacks();
+  caml_check_urgent_gc (Val_unit);
   caml_thread_save_runtime_state();
   st_thread_yield(&caml_master_lock);
   curr_thread = st_tls_get(thread_descriptor_key);
   caml_thread_restore_runtime_state();
-  caml_async_callbacks();
+  caml_check_urgent_gc (Val_unit);
 
   return Val_unit;
 }
diff --git a/runtime/caml/finalise.h b/runtime/caml/finalise.h
index 78da80e681..5c8ea24c52 100644
--- a/runtime/caml/finalise.h
+++ b/runtime/caml/finalise.h
@@ -31,8 +31,6 @@ void caml_final_update_minor_roots(void);
 value caml_final_register (value f, value v);
 void caml_final_invariant_check(void);
 
-extern int caml_final_to_do;
-
 #endif /* CAML_INTERNALS */
 
 #endif /* CAML_FINALISE_H */
diff --git a/runtime/caml/memprof.h b/runtime/caml/memprof.h
index 6bc3a71787..66a842760a 100644
--- a/runtime/caml/memprof.h
+++ b/runtime/caml/memprof.h
@@ -24,7 +24,6 @@
 extern int caml_memprof_suspended;
 
 extern void caml_memprof_handle_postponed();
-extern int caml_memprof_to_do;
 
 extern void caml_memprof_track_alloc_shr(value block);
 extern void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml);
diff --git a/runtime/caml/signals.h b/runtime/caml/signals.h
index b1b39c0217..209027ab50 100644
--- a/runtime/caml/signals.h
+++ b/runtime/caml/signals.h
@@ -31,7 +31,6 @@ extern "C" {
 #endif
 
 #ifdef CAML_INTERNALS
-CAMLextern intnat volatile caml_signals_are_pending;
 CAMLextern intnat volatile caml_pending_signals[];
 CAMLextern int volatile caml_something_to_do;
 extern int volatile caml_requested_major_slice;
@@ -44,7 +43,8 @@ CAMLextern int caml_convert_signal_number (int);
 CAMLextern int caml_rev_convert_signal_number (int);
 void caml_execute_signal(int signal_number, int in_signal_handler);
 void caml_record_signal(int signal_number);
-void caml_async_callbacks(void);
+void caml_set_something_to_do (void);
+void caml_raise_in_async_callback (value exc);
 void caml_process_event(void);
 int caml_set_signal_action(int signo, int action);
 
diff --git a/runtime/finalise.c b/runtime/finalise.c
index 7f485c9f25..ace72846f9 100644
--- a/runtime/finalise.c
+++ b/runtime/finalise.c
@@ -82,14 +82,7 @@ static void alloc_to_do (int size)
   if (to_do_tl == NULL){
     to_do_hd = result;
     to_do_tl = result;
-    if(!running_finalisation_function) {
-      caml_final_to_do = 1;
-#ifndef NATIVE_CODE
-      caml_something_to_do = 1;
-#else
-      caml_young_limit = caml_young_alloc_end;
-#endif
-    }
+    if(!running_finalisation_function) caml_set_something_to_do();
   }else{
     CAMLassert (to_do_tl->next == NULL);
     to_do_tl->next = result;
@@ -209,12 +202,12 @@ void caml_final_do_calls (void)
       caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr;
 #endif
       running_finalisation_function = 0;
-      if (Is_exception_result (res)) caml_raise (Extract_exception (res));
+      if (Is_exception_result (res))
+        caml_raise_in_async_callback(Extract_exception(res));
     }
     caml_gc_message (0x80, "Done calling finalisation functions.\n");
     if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) ();
   }
-  caml_final_to_do = 0;
 }
 
 /* Call a scanning_action [f] on [x]. */
diff --git a/runtime/gc_ctrl.c b/runtime/gc_ctrl.c
index 8485f6b2cc..b830b53843 100644
--- a/runtime/gc_ctrl.c
+++ b/runtime/gc_ctrl.c
@@ -516,7 +516,7 @@ CAMLprim value caml_gc_minor(value v)
   CAMLassert (v == Val_unit);
   caml_request_minor_gc ();
   caml_gc_dispatch ();
-  caml_async_callbacks ();
+  caml_check_urgent_gc (Val_unit);
   CAML_INSTR_TIME (tmr, "explicit/gc_minor");
   return Val_unit;
 }
@@ -544,7 +544,7 @@ CAMLprim value caml_gc_major(value v)
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
   test_and_compact ();
-  caml_async_callbacks ();
+  caml_check_urgent_gc (Val_unit);
   CAML_INSTR_TIME (tmr, "explicit/gc_major");
   return Val_unit;
 }
@@ -556,11 +556,11 @@ CAMLprim value caml_gc_full_major(value v)
   caml_gc_message (0x1, "Full major GC cycle requested\n");
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
-  caml_async_callbacks ();
+  caml_check_urgent_gc (Val_unit);
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
   test_and_compact ();
-  caml_async_callbacks ();
+  caml_check_urgent_gc (Val_unit);
   CAML_INSTR_TIME (tmr, "explicit/gc_full_major");
   return Val_unit;
 }
@@ -581,11 +581,11 @@ CAMLprim value caml_gc_compaction(value v)
   caml_gc_message (0x10, "Heap compaction requested\n");
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
-  caml_async_callbacks ();
+  caml_check_urgent_gc (Val_unit);
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
   caml_compact_heap ();
-  caml_async_callbacks ();
+  caml_check_urgent_gc (Val_unit);
   CAML_INSTR_TIME (tmr, "explicit/gc_compact");
   return Val_unit;
 }
diff --git a/runtime/interp.c b/runtime/interp.c
index c2541c0fc4..82f7e39b7b 100644
--- a/runtime/interp.c
+++ b/runtime/interp.c
@@ -891,7 +891,6 @@ value caml_interprete(code_t prog, asize_t prog_size)
       Next;
 
     process_signal:
-      caml_something_to_do = 0;
       Setup_for_event;
       caml_process_event();
       Restore_after_event;
diff --git a/runtime/memprof.c b/runtime/memprof.c
index 16dbeb5d22..e26fbce076 100644
--- a/runtime/memprof.c
+++ b/runtime/memprof.c
@@ -128,7 +128,6 @@ static uintnat mt_generate_binom(uintnat len)
 /**** Interface with the OCaml code. ****/
 
 static void purge_postponed_queue(void);
-static void check_to_do(void);
 
 CAMLprim value caml_memprof_set(value v)
 {
@@ -183,6 +182,12 @@ enum ml_alloc_kind {
   Serialized = Val_long(2)
 };
 
+/* When we call do_callback, we suspend/resume sampling. In order to
+   to avoid a systematic unnecessary calls to [caml_check_urgent_gc]
+   after each memprof callback, we do not set [caml_something_to_do]
+   when resuming. Therefore, any call to [do_callback] has to also
+   make sure the postponed queue will be handled fully at some
+   point. */
 static value do_callback(tag_t tag, uintnat wosize, uintnat occurrences,
                          value callstack, enum ml_alloc_kind cb_kind) {
   CAMLparam1(callstack);
@@ -202,14 +207,20 @@ static value do_callback(tag_t tag, uintnat wosize, uintnat occurrences,
   res = caml_callback_exn(memprof_callback, sample_info);
 
   caml_memprof_suspended = 0;
-  check_to_do();
+
+  if (Is_exception_result(res))
+    /* We are not necessarily called from `caml_check_urgent_gc`, but
+       this is OK to call this regardless of this fact.  */
+    caml_raise_in_async_callback(Extract_exception(res));
 
   CAMLreturn(res);
 }
 
 /**** Capturing the call stack *****/
 
-static value capture_callstack_major(void)
+/* This function is called for postponed blocks, so it guarantees
+   that the GC is not called. */
+static value capture_callstack_postponed(void)
 {
   value res;
   uintnat wosize = caml_current_callstack_size(callstack_size);
@@ -220,7 +231,7 @@ static value capture_callstack_major(void)
   return res;
 }
 
-static value capture_callstack_minor(void)
+static value capture_callstack(void)
 {
   value res;
   uintnat wosize = caml_current_callstack_size(callstack_size);
@@ -228,7 +239,6 @@ static value capture_callstack_minor(void)
   caml_memprof_suspended = 1; /* => no samples in the call stack. */
   res = caml_alloc(wosize, 0);
   caml_memprof_suspended = 0;
-  check_to_do();
   caml_current_callstack_write(res);
   return res;
 }
@@ -284,7 +294,7 @@ static void register_postponed_callback(value block, uintnat occurrences,
   value callstack;
   struct postponed_block* new_hd;
   if (occurrences == 0) return;
-  callstack = capture_callstack_major();
+  callstack = capture_callstack_postponed();
   if (callstack == 0) return;    /* OOM */
 
   new_hd = postponed_hd + 1;
@@ -321,7 +331,7 @@ static void register_postponed_callback(value block, uintnat occurrences,
   postponed_hd->kind = kind;
   postponed_hd = new_hd;
 
-  check_to_do();
+  if (!caml_memprof_suspended) caml_set_something_to_do();
 }
 
 void caml_memprof_handle_postponed(void)
@@ -347,7 +357,6 @@ void caml_memprof_handle_postponed(void)
     ephe = do_callback(Tag_val(block), Wosize_val(block),
                        pb.occurrences, pb.callstack, pb.kind);
 
-    if (Is_exception_result(ephe)) caml_raise(Extract_exception(ephe));
     if (Is_block(ephe)) caml_ephemeron_set_key(Field(ephe, 0), 0, block);
   }
 
@@ -355,18 +364,6 @@ void caml_memprof_handle_postponed(void)
   CAMLreturn0;
 }
 
-static void check_to_do(void)
-{
-  if (!caml_memprof_suspended && postponed_tl != postponed_hd) {
-    caml_memprof_to_do = 1;
-#ifndef NATIVE_CODE
-    caml_something_to_do = 1;
-#else
-    caml_young_limit = caml_young_alloc_end;
-#endif
-  }
-}
-
 /**** Sampling procedures ****/
 
 void caml_memprof_track_alloc_shr(value block)
@@ -458,11 +455,9 @@ void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml)
      order. */
   caml_memprof_handle_postponed();
 
-  callstack = capture_callstack_minor();
+  callstack = capture_callstack();
   ephe = do_callback(tag, wosize, occurrences, callstack, Minor);
 
-  if (Is_exception_result(ephe)) caml_raise(Extract_exception(ephe));
-
   /* We can now restore the minor heap in the state needed by
      [Alloc_small_aux]. */
   if (caml_young_ptr - whsize < caml_young_trigger) {
diff --git a/runtime/meta.c b/runtime/meta.c
index 297e195012..53b8422287 100644
--- a/runtime/meta.c
+++ b/runtime/meta.c
@@ -290,7 +290,6 @@ value * caml_stack_threshold;
 value * caml_extern_sp;
 value * caml_trapsp;
 int caml_callback_depth;
-int volatile caml_something_to_do;
 void (* volatile caml_async_action_hook)(void);
 struct longjmp_buffer * caml_external_raise;
 
diff --git a/runtime/minor_gc.c b/runtime/minor_gc.c
index f9e2c6e9da..c265fb95a0 100644
--- a/runtime/minor_gc.c
+++ b/runtime/minor_gc.c
@@ -473,7 +473,7 @@ void caml_alloc_small_dispatch (tag_t tag, intnat wosize, int flags)
     caml_young_ptr += Whsize_wosize (wosize);
     CAML_INSTR_INT ("force_minor/alloc_small@", 1);
     caml_gc_dispatch ();
-    if(flags & CAML_FROM_CAML) caml_async_callbacks();
+    if(flags & CAML_FROM_CAML) caml_check_urgent_gc (Val_unit);
     caml_young_ptr -= Whsize_wosize (wosize);
   }
   if(caml_young_ptr < caml_memprof_young_trigger){
@@ -500,17 +500,6 @@ CAMLexport void caml_minor_collection (void)
   caml_gc_dispatch ();
 }
 
-CAMLexport value caml_check_urgent_gc (value extra_root)
-{
-  CAMLparam1 (extra_root);
-  if (caml_requested_major_slice || caml_requested_minor_gc){
-    CAML_INSTR_INT ("force_minor/check_urgent_gc@", 1);
-    caml_gc_dispatch();
-  }
-  caml_async_callbacks();
-  CAMLreturn (extra_root);
-}
-
 static void realloc_generic_table
 (struct generic_table *tbl, asize_t element_size,
  char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error)
diff --git a/runtime/signals.c b/runtime/signals.c
index cd1fa412df..efa9bb1b98 100644
--- a/runtime/signals.c
+++ b/runtime/signals.c
@@ -41,9 +41,11 @@
 #define NSIG 64
 #endif
 
+CAMLexport int volatile caml_something_to_do = 0;
+
 /* The set of pending signals (received but not yet processed) */
 
-CAMLexport intnat volatile caml_signals_are_pending = 0;
+static intnat volatile signals_are_pending = 0;
 CAMLexport intnat volatile caml_pending_signals[NSIG];
 
 #ifdef POSIX_SIGNALS
@@ -70,12 +72,9 @@ void caml_process_pending_signals(void)
   sigset_t set;
 #endif
 
-  if(!caml_signals_are_pending)
+  if(!signals_are_pending)
     return;
-  caml_signals_are_pending = 0;
-#ifdef NATIVE_CODE
-  caml_update_young_limit();
-#endif
+  signals_are_pending = 0;
 
   /* Check that there is indeed a pending signal before issuing the
      syscall in [caml_sigmask_hook]. */
@@ -103,6 +102,18 @@ void caml_process_pending_signals(void)
   }
 }
 
+void caml_set_something_to_do(void)
+{
+  caml_something_to_do = 1;
+#ifdef NATIVE_CODE
+  /* When this function is called without [caml_c_call] (e.g., in
+     [caml_modify]), this is only moderately effective on ports that
+     cache [caml_young_limit] in a register, so it may take a while
+     before the register is reloaded from [caml_young_limit]. */
+  caml_young_limit = caml_young_alloc_end;
+#endif
+}
+
 /* Record the delivery of a signal, and arrange for it to be processed
    as soon as possible:
    - in bytecode: via caml_something_to_do, processed in caml_process_event
@@ -112,13 +123,9 @@ void caml_process_pending_signals(void)
 
 void caml_record_signal(int signal_number)
 {
+  caml_set_something_to_do();
   caml_pending_signals[signal_number] = 1;
-  caml_signals_are_pending = 1;
-#ifndef NATIVE_CODE
-  caml_something_to_do = 1;
-#else
-  caml_young_limit = caml_young_alloc_end;
-#endif
+  signals_are_pending = 1;
 }
 
 /* Management of blocking sections. */
@@ -155,11 +162,11 @@ CAMLexport void caml_enter_blocking_section(void)
 {
   while (1){
     /* Process all pending signals now */
-    caml_async_callbacks();
+    caml_check_urgent_gc (Val_unit);
     caml_enter_blocking_section_hook ();
     /* Check again for pending signals.
        If none, done; otherwise, try again */
-    if (! caml_signals_are_pending) break;
+    if (! caml_something_to_do) break;
     caml_leave_blocking_section_hook ();
   }
 }
@@ -172,7 +179,7 @@ CAMLexport void caml_leave_blocking_section(void)
   caml_leave_blocking_section_hook ();
 
   /* Some other thread may have switched
-     [caml_signals_are_pending] to 0 even though there are still
+     [signals_are_pending] to 0 even though there are still
      pending signals (masked in the other thread). To handle this
      case, we force re-examination of all signals by setting it back
      to 1.
@@ -181,10 +188,10 @@ CAMLexport void caml_leave_blocking_section(void)
      setting) is when the blocking section unmasks a pending signal:
      If the signal is pending and masked but has already been
      examined by [caml_process_pending_signals], then
-     [caml_signals_are_pending] is 0 but the signal needs to be
+     [signals_are_pending] is 0 but the signal needs to be
      handled at this point. */
-  caml_signals_are_pending = 1;
-  caml_async_callbacks();
+  signals_are_pending = 1;
+  caml_check_urgent_gc (Val_unit);
 
   errno = saved_errno;
 }
@@ -248,7 +255,8 @@ void caml_execute_signal(int signal_number, int in_signal_handler)
     caml_sigmask_hook(SIG_SETMASK, &sigs, NULL);
   }
 #endif
-  if (Is_exception_result(res)) caml_raise(Extract_exception(res));
+  if (Is_exception_result(res))
+    caml_raise_in_async_callback(Extract_exception(res));
 }
 
 void caml_update_young_limit (void)
@@ -258,8 +266,7 @@ void caml_update_young_limit (void)
     caml_young_trigger : caml_memprof_young_trigger;
 
 #ifdef NATIVE_CODE
-  if(caml_requested_major_slice || caml_requested_minor_gc ||
-     caml_final_to_do || caml_signals_are_pending || caml_memprof_to_do)
+  if(caml_something_to_do)
     caml_young_limit = caml_young_alloc_end;
 #endif
 }
@@ -272,36 +279,50 @@ int volatile caml_requested_minor_gc = 0;
 void caml_request_major_slice (void)
 {
   caml_requested_major_slice = 1;
-#ifndef NATIVE_CODE
-  caml_something_to_do = 1;
-#else
-  caml_young_limit = caml_young_alloc_end;
-  /* This is only moderately effective on ports that cache [caml_young_limit]
-     in a register, since [caml_modify] is called directly, not through
-     [caml_c_call], so it may take a while before the register is reloaded
-     from [caml_young_limit]. */
-#endif
+  caml_set_something_to_do();
 }
 
 void caml_request_minor_gc (void)
 {
   caml_requested_minor_gc = 1;
-#ifndef NATIVE_CODE
-  caml_something_to_do = 1;
-#else
-  caml_young_limit = caml_young_alloc_end;
-  /* Same remark as above in [caml_request_major_slice]. */
-#endif
+  caml_set_something_to_do();
 }
 
-void caml_async_callbacks (void)
+
+CAMLexport value caml_check_urgent_gc (value extra_root)
 {
-  caml_memprof_handle_postponed();
-  caml_final_do_calls();
-  caml_process_pending_signals();
+  CAMLparam1 (extra_root);
+  caml_something_to_do = 0;
 #ifdef NATIVE_CODE
   caml_update_young_limit();
 #endif
+  if (caml_requested_major_slice || caml_requested_minor_gc){
+    CAML_INSTR_INT ("force_minor/check_urgent_gc@", 1);
+    caml_gc_dispatch();
+  }
+  caml_memprof_handle_postponed();
+  caml_final_do_calls();
+  caml_process_pending_signals();
+  CAMLreturn (extra_root);
+}
+
+
+/* If an exception is raised during an asynchronous callback (i.e.,
+   from an OCaml function called in `caml_check_urgent_gc`), then it
+   might be the case that we did not run all the callbacks we needed
+   to run even though [caml_something_to_do] has been reset to 0 at
+   the begining of [caml_check_urgent_gc]. Therefore, we set
+   [caml_something_to_do] in order to force reexamination of
+   callbacks.
+
+   Apart from a reasonable performance penalty (an extra call to
+   `caml_check_urgent_gc`), it is OK to call this function where
+   `caml_raise` would have been more appropriate (i.e., not called
+   from `caml_check_urgent_gc`). */
+void caml_raise_in_async_callback (value exc)
+{
+  caml_set_something_to_do();
+  caml_raise(exc);
 }
 
 /* OS-independent numbering of signals */
diff --git a/runtime/signals_byt.c b/runtime/signals_byt.c
index ee1bc5708f..b6b32b5798 100644
--- a/runtime/signals_byt.c
+++ b/runtime/signals_byt.c
@@ -36,7 +36,6 @@ extern sighandler caml_win32_signal(int sig, sighandler action);
 #define signal(sig,act) caml_win32_signal(sig,act)
 #endif
 
-CAMLexport int volatile caml_something_to_do = 0;
 CAMLexport void (* volatile caml_async_action_hook)(void) = NULL;
 
 void caml_process_event(void)
diff --git a/runtime/signals_nat.c b/runtime/signals_nat.c
index d74257746a..38ca0b7dda 100644
--- a/runtime/signals_nat.c
+++ b/runtime/signals_nat.c
@@ -97,7 +97,7 @@ void caml_garbage_collection(void)
   }
 #endif
 
-  caml_async_callbacks();
+  caml_check_urgent_gc (Val_unit);
 }
 
 DECLARE_SIGNAL_HANDLER(handle_signal)