introduce a watchdog thread to handle exiting the program more gracef…

…ully.

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

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)

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)

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 ()