fix: run console in separate thread

We no longer block on updating the terminal

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

ps-id: 230cf5db-0841-4d20-af31-5f2cf27a8432

src/dune_console/dune

@@ -1,3 +1,3 @@
 (library
  (name dune_console)
- (libraries stdune))
+ (libraries stdune threads.posix))

src/dune_console/dune_console.ml

@@ -54,7 +54,7 @@ module Backend = struct
       flush stderr
   end
 
-  module Progress : S = struct
+  module Progress_no_flush : S = struct
     let status_line = ref Pp.nop
 
     let status_line_len = ref 0
@@ -69,24 +69,21 @@ module Backend = struct
       | None ->
         hide_status_line ();
         status_line := Pp.nop;
-        status_line_len := 0;
-        flush stderr
+        status_line_len := 0
       | Some line ->
         let line = Pp.map_tags line ~f:User_message.Print_config.default in
         let line_len = String.length (Format.asprintf "%a" Pp.to_fmt line) in
         hide_status_line ();
         status_line := line;
         status_line_len := line_len;
-        show_status_line ();
-        flush stderr
+        show_status_line ()
 
     let print_if_no_status_line _msg = ()
 
     let print_user_message msg =
       hide_status_line ();
       Dumb_no_flush.print_user_message msg;
-      show_status_line ();
-      flush stderr
+      show_status_line ()
 
     let reset () = Dumb.reset ()
 
@@ -95,8 +92,6 @@ module Backend = struct
 
   let dumb = (module Dumb : S)
 
-  let progress = (module Progress : S)
-
   let main = ref dumb
 
   let set t = main := t
@@ -123,6 +118,71 @@ module Backend = struct
         A.reset_flush_history ();
         B.reset_flush_history ()
     end : S)
+
+  let spawn_thread = Fdecl.create Dyn.opaque
+
+  let threaded (module Base : S) : (module S) =
+    let module T = struct
+      let mutex = Mutex.create ()
+
+      type state =
+        { messages : User_message.t Queue.t
+        ; mutable status_line : User_message.Style.t Pp.t option
+        }
+
+      let state = { messages = Queue.create (); status_line = None }
+
+      let print_user_message m =
+        Mutex.lock mutex;
+        Queue.push state.messages m;
+        Mutex.unlock mutex
+
+      let set_status_line sl =
+        Mutex.lock mutex;
+        state.status_line <- sl;
+        Mutex.unlock mutex
+
+      let print_if_no_status_line _msg = ()
+
+      let reset () =
+        Mutex.lock mutex;
+        Queue.clear state.messages;
+        state.status_line <- None;
+        Base.reset ();
+        Mutex.unlock mutex
+
+      let reset_flush_history () =
+        Mutex.lock mutex;
+        Queue.clear state.messages;
+        state.status_line <- None;
+        Base.reset_flush_history ();
+        Mutex.unlock mutex
+    end in
+    ( Fdecl.get spawn_thread @@ fun () ->
+      let open T in
+      let last = ref (Unix.gettimeofday ()) in
+      let frame_rate = 1. /. 60. in
+      while true do
+        Mutex.lock mutex;
+        while not (Queue.is_empty state.messages) do
+          Base.print_user_message (Queue.pop_exn state.messages)
+        done;
+        Base.set_status_line state.status_line;
+        flush stderr;
+        Mutex.unlock mutex;
+        let now = Unix.gettimeofday () in
+        let elapsed = now -. !last in
+        if elapsed >= frame_rate then last := now
+        else
+          let delta = frame_rate -. elapsed in
+          Unix.sleepf delta;
+          last := delta +. now
+      done );
+    (module T)
+
+  let progress =
+    let t = lazy (threaded (module Progress_no_flush)) in
+    fun () -> Lazy.force t
 end
 
 let print_user_message msg =

src/dune_console/dune_console.mli

@@ -8,25 +8,7 @@ open Stdune
     application as well as composing backends. *)
 
 module Backend : sig
-  module type S = sig
-    (** Format and print a user message to the console *)
-    val print_user_message : User_message.t -> unit
-
-    (** Change the status line *)
-    val set_status_line : User_message.Style.t Pp.t option -> unit
-
-    (** Print a message if the backend does not display the status line. This is
-        needed so that the important status changes show up even when a [dumb]
-        terminal backend is used. *)
-    val print_if_no_status_line : User_message.Style.t Pp.t -> unit
-
-    (** Reset the log output *)
-    val reset : unit -> unit
-
-    val reset_flush_history : unit -> unit
-  end
-
-  type t = (module S)
+  type t
 
   val set : t -> unit
 
@@ -39,11 +21,21 @@ module Backend : sig
   val dumb : t
 
   (** A backend that just displays the status line in the terminal *)
-  val progress : t
+  val progress : unit -> t
+
+  val spawn_thread : ((unit -> unit) -> unit) Fdecl.t
+
+  val threaded : t -> t
 end
 
-(** The main backend for the application *)
-include Backend.S
+(** Format and print a user message to the console *)
+val print_user_message : User_message.t -> unit
+
+(** Reset the log output and (try) to remove the history *)
+val reset_flush_history : unit -> unit
+
+(** Reset the log output *)
+val reset : unit -> unit
 
 (** [print paragraphs] is a short-hand for:
 

src/dune_engine/scheduler.ml

@@ -39,7 +39,7 @@ module Config = struct
     let console_backend t =
       match t.status_line with
       | false -> Console.Backend.dumb
-      | true -> Console.Backend.progress
+      | true -> Console.Backend.progress ()
   end
 
   type t =
@@ -140,6 +140,11 @@ end = struct
       in
       Thread.create f x
 
+  let () =
+    Fdecl.set Console.Backend.spawn_thread (fun f ->
+        let (_ : Thread.t) = create ~signal_watcher:`Yes f () in
+        ())
+
   let spawn ~signal_watcher f =
     let (_ : Thread.t) = create ~signal_watcher f () in
     ()