diff --git a/bin/play.ml b/bin/play.ml index 26cf9bd..4397ec1 100644 --- a/bin/play.ml +++ b/bin/play.ml @@ -1,15 +1,8 @@ let event_to_note tones event = tones (Event.event_to_int event) -let handle_control_c device = +let handle_control_c () = let handle = - Sys.Signal_handle - (fun _ -> - match Midi.Device.shutdown device with - | Ok _ -> () - | Error msg -> - let s = Midi.error_to_string msg in - Printf.eprintf "(ctrl-c handler) Error during device shutdown: %s" s; - exit 1) + Sys.Signal_handle (fun _ -> Atomic.set Watchdog.terminate true) in Sys.(signal sigint handle) @@ -20,7 +13,7 @@ let play ~tracing device_id scale argv = | _ -> failwith "No program given" in let device = Midi.Device.create device_id in - let _ = handle_control_c device in + let _ = handle_control_c () in (* Extract the user supplied program and arguments. *) let proc = Unix.create_process_env prog args diff --git a/bin/simple_engine.ml b/bin/simple_engine.ml index ebf739d..d79a8a3 100644 --- a/bin/simple_engine.ml +++ b/bin/simple_engine.ml @@ -54,10 +54,12 @@ let tracing device child_alive path_pid tones = let runtime_end = runtime_end device tones in let runtime_counter = runtime_counter device tones in let cbs = Callbacks.create ~runtime_begin ~runtime_end ~runtime_counter () in - while child_alive () do + let watchdog_domain = Domain.spawn (Watchdog.watchdog_func child_alive) in + while not (Atomic.get Watchdog.terminate) do ignore (read_poll c cbs None); Unix.sleepf 0.1 - done + done; + Domain.join watchdog_domain let simple_play = Play.play ~tracing let play_t = Term.(const simple_play $ Play.device_id $ Play.scale $ Play.argv) diff --git a/bin/stat_engine.ml b/bin/stat_engine.ml index 28c55a2..c09e20c 100644 --- a/bin/stat_engine.ml +++ b/bin/stat_engine.ml @@ -22,10 +22,10 @@ let runtime_begin _domain_id _ts event = add_to_hashtbl event_table event_table_lock event; add_to_hashtbl quantifier_table quantifier_table_lock event -let polling_main_func child_alive path_pid _ = +let polling_main_func path_pid _ = let c = create_cursor path_pid in let cbs = Callbacks.create ~runtime_begin () in - while child_alive () do + while not (Atomic.get Watchdog.terminate) do ignore (read_poll c cbs None); Unix.sleepf 0.1 done @@ -108,14 +108,18 @@ let rec sequencer_main_func num_beats tones device bpm _ = Hashtbl.clear event_table; Mutex.unlock event_table_lock; (* Unix.sleepf (60. /. Float.of_int bpm); *) - sequencer_main_func (num_beats + 1) tones device bpm () + if Atomic.get Watchdog.terminate then + () + else + sequencer_main_func (num_beats + 1) tones device bpm () let tracing (bpm : int) device child_alive path_pid tones = - let polling_domain = Domain.spawn (polling_main_func child_alive path_pid) in + let polling_domain = Domain.spawn (polling_main_func path_pid) in let sequencer_domain = Domain.spawn (sequencer_main_func 1 tones device bpm) in - List.iter Domain.join [ polling_domain; sequencer_domain ] + let watchdog_domain = Domain.spawn (Watchdog.watchdog_func child_alive) in + List.iter Domain.join [ watchdog_domain; polling_domain; sequencer_domain ] let bpm = Arg.(value & opt int 120 & info [ "bpm"; "--bpm" ] ~docv:"BPM") let stat_play bpm = Play.play ~tracing:(tracing bpm) diff --git a/bin/watchdog.ml b/bin/watchdog.ml new file mode 100644 index 0000000..c16ede7 --- /dev/null +++ b/bin/watchdog.ml @@ -0,0 +1,16 @@ +(* When set to true, all reading threads should stop. *) +let terminate = Atomic.make false + +(* + The watchdog will periodically check that the child process is still alive. + If the child process is gone, then it will set the terminate atomic variable to true. + Threads should be checking for this atomic variable periodically, and shut down gracefully. + Note: It is also possible that the terminate variable is set by a signal handler. +*) +let rec watchdog_func child_alive () = + Unix.sleepf 0.1; + match Atomic.get terminate with + | true -> () + | false -> + if not (child_alive ()) then Atomic.set terminate true + else watchdog_func child_alive ()