From 40e97d969ac958397dcf9e287925126ee48c19ed Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Oct 2024 15:28:04 -0400 Subject: [PATCH 1/4] fix domain pool: block signals in background threads close #35 --- src/dpool/moonpool_dpool.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/dpool/moonpool_dpool.ml b/src/dpool/moonpool_dpool.ml index 953b323d..950e6038 100644 --- a/src/dpool/moonpool_dpool.ml +++ b/src/dpool/moonpool_dpool.ml @@ -95,6 +95,11 @@ let domains_ : (worker_state option * Domain_.t option) Lock.t array = a [Pool.with_] or [Pool.create() … Pool.shutdown()] in a tight loop), and if nothing happens it tries to stop to free resources. *) let work_ idx (st : worker_state) : unit = + Thread.sigmask SIG_BLOCK + [ + Sys.sigpipe; Sys.sigbus; Sys.sigterm; Sys.sigint; Sys.sigusr1; Sys.sigusr2; + ] + |> ignore; let main_loop () = let continue = ref true in while !continue do From a40ea8b41b348a18722a5c83ca980208f0649128 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 9 Oct 2024 00:26:30 -0400 Subject: [PATCH 2/4] avoid recursion in dpool --- src/dpool/moonpool_dpool.ml | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/src/dpool/moonpool_dpool.ml b/src/dpool/moonpool_dpool.ml index 950e6038..25e4fabf 100644 --- a/src/dpool/moonpool_dpool.ml +++ b/src/dpool/moonpool_dpool.ml @@ -15,19 +15,23 @@ module Bb_queue = struct if was_empty then Condition.broadcast self.cond; Mutex.unlock self.mutex - let pop (self : 'a t) : 'a = - Mutex.lock self.mutex; - let rec loop () = - if Queue.is_empty self.q then ( - Condition.wait self.cond self.mutex; - (loop [@tailcall]) () - ) else ( - let x = Queue.pop self.q in - Mutex.unlock self.mutex; - x - ) - in - loop () + let pop (type a) (self : a t) : a = + let module M = struct + exception Found of a + end in + try + Mutex.lock self.mutex; + while true do + if Queue.is_empty self.q then + Condition.wait self.cond self.mutex + else ( + let x = Queue.pop self.q in + Mutex.unlock self.mutex; + raise (M.Found x) + ) + done; + assert false + with M.Found x -> x end module Lock = struct From 794b263d36d4cf335e10f2261da11068b579fecd Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 13 Nov 2025 19:50:40 -0500 Subject: [PATCH 3/4] improve lock --- src/dpool/moonpool_dpool.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/dpool/moonpool_dpool.ml b/src/dpool/moonpool_dpool.ml index 25e4fabf..eda1a8e5 100644 --- a/src/dpool/moonpool_dpool.ml +++ b/src/dpool/moonpool_dpool.ml @@ -42,13 +42,13 @@ module Lock = struct let create content : _ t = { mutex = Mutex.create (); content } - let with_ (self : _ t) f = + let[@inline never] with_ (self : _ t) f = Mutex.lock self.mutex; - try - let x = f self.content in + match f self.content with + | x -> Mutex.unlock self.mutex; x - with e -> + | exception e -> Mutex.unlock self.mutex; raise e From b1688f71e7dac330a8e2945f30d507addfd21931 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 13 Nov 2025 19:53:02 -0500 Subject: [PATCH 4/4] more signal handling --- src/core/worker_loop_.ml | 17 +---------------- src/dpool/moonpool_dpool.ml | 6 +----- src/private/signals_.ml | 15 +++++++++++++++ 3 files changed, 17 insertions(+), 21 deletions(-) create mode 100644 src/private/signals_.ml diff --git a/src/core/worker_loop_.ml b/src/core/worker_loop_.ml index 7ba781a5..d36d1d52 100644 --- a/src/core/worker_loop_.ml +++ b/src/core/worker_loop_.ml @@ -144,22 +144,7 @@ module Fine_grained (Args : FINE_GRAINED_ARGS) () = struct if !state <> New then invalid_arg "worker_loop.setup: not a new instance"; state := Ready; - if block_signals then ( - try - ignore - (Unix.sigprocmask SIG_BLOCK - [ - Sys.sigterm; - Sys.sigpipe; - Sys.sigint; - Sys.sigchld; - Sys.sigalrm; - Sys.sigusr1; - Sys.sigusr2; - ] - : _ list) - with _ -> () - ); + if block_signals then Signals_.ignore_signals_ (); TLS.set Runner.For_runner_implementors.k_cur_runner runner; diff --git a/src/dpool/moonpool_dpool.ml b/src/dpool/moonpool_dpool.ml index eda1a8e5..786c6a9f 100644 --- a/src/dpool/moonpool_dpool.ml +++ b/src/dpool/moonpool_dpool.ml @@ -99,11 +99,7 @@ let domains_ : (worker_state option * Domain_.t option) Lock.t array = a [Pool.with_] or [Pool.create() … Pool.shutdown()] in a tight loop), and if nothing happens it tries to stop to free resources. *) let work_ idx (st : worker_state) : unit = - Thread.sigmask SIG_BLOCK - [ - Sys.sigpipe; Sys.sigbus; Sys.sigterm; Sys.sigint; Sys.sigusr1; Sys.sigusr2; - ] - |> ignore; + Signals_.ignore_signals_ (); let main_loop () = let continue = ref true in while !continue do diff --git a/src/private/signals_.ml b/src/private/signals_.ml new file mode 100644 index 00000000..95f86fb4 --- /dev/null +++ b/src/private/signals_.ml @@ -0,0 +1,15 @@ +let ignore_signals_ () = + try + Thread.sigmask SIG_BLOCK + [ + Sys.sigpipe; + Sys.sigbus; + Sys.sigterm; + Sys.sigchld; + Sys.sigalrm; + Sys.sigint; + Sys.sigusr1; + Sys.sigusr2; + ] + |> ignore + with _ -> ()