Very dirty refactor

At least, this fixes the problem due to which the tests would hang instead
of terminating: Before, the `single` mode would also try to draw the
pipeline from cache. However, that cache was never inited in that mode
(and shouln'd be in that mode). Now, workflow is a lot cleaner, but the
implementation is still in prototype style.

src/frontend/ocamlmerlin/new/new_merlin.ml

@@ -41,7 +41,7 @@ let commands_help () =
       print_endline doc
     ) New_commands.all_commands
 
-let run = function
+let run ~get_pipeline = function
   | [] ->
     usage ();
     1
@@ -96,7 +96,12 @@ let run = function
         File_id.with_cache @@ fun () ->
         let source = Msource.make (Misc.string_of_file stdin) in
         let file = config.Mconfig.query.filename in
-        let pipeline = Mpipeline.With_cache.get_pipeline file config source in
+        let pipeline =
+          match get_pipeline file config source with
+          | None ->
+            failwith "Why on earth is the pipeline domain down?"
+          | Some p -> p
+        in
         (* let pipeline = Mpipeline.make config source in *)
         let json =
           let class_, message =
@@ -162,18 +167,18 @@ let with_wd ~wd ~old_wd f args =
       wd old_wd;
     f args
 
-let run ~new_env wd args =
+let run ~get_pipeline ~new_env wd args =
   begin match new_env with
   | Some env ->
     Os_ipc.merlin_set_environ env;
     Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ()))
   | None -> () end;
   let old_wd = Sys.getcwd () in
   let run args () = match wd with
-    | Some wd -> with_wd ~wd ~old_wd run args
+    | Some wd -> with_wd ~wd ~old_wd (run ~get_pipeline) args
     | None ->
       log ~title:"run" "No working directory specified (old wd: %S)" old_wd;
-      run args
+      run ~get_pipeline args
   in
   let `Log_file_path log_file, `Log_sections sections =
     Log_info.get ()

src/frontend/ocamlmerlin/ocamlmerlin_server.ml

@@ -9,19 +9,19 @@ module Server = struct
     | exception (Unix.Unix_error(Unix.EINTR, _, _)) -> protect_eintr f
     | result -> result
 
-  let process_request {Os_ipc. wd; environ; argv; context = _}  =
+  let process_request ~get_pipeline {Os_ipc. wd; environ; argv; context = _}  =
     match Array.to_list argv with
     | "stop-server" :: _ -> raise Exit
-    | args -> New_merlin.run ~new_env:(Some environ) (Some wd) args
+    | args -> New_merlin.run ~get_pipeline ~new_env:(Some environ) (Some wd) args
 
-   let process_client client =
+   let process_client ~get_pipeline client =
     let context = client.Os_ipc.context in
     Os_ipc.context_setup context;
     let close_with return_code =
       flush_all ();
       Os_ipc.context_close context ~return_code
     in
-    match process_request client with
+    match process_request ~get_pipeline client with
     | code -> close_with code
     | exception Exit ->
       close_with (-1);
@@ -47,36 +47,36 @@ module Server = struct
     | Some _ as result -> result
     | None -> loop 1.0
 
-  let rec loop merlinid server =
+  let rec loop merlinid server ~get_pipeline =
     match server_accept merlinid server with
     | None -> (* Timeout *)
       ()
     | Some client ->
       let continue =
-        match process_client client with
+        match process_client ~get_pipeline client with
         | exception Exit -> false
         | () -> true
       in
-      if continue then loop merlinid server
-
-  let start socket_path socket_fd =
-    match Os_ipc.server_setup socket_path socket_fd with
-    | None ->
-      Logger.log ~section:"server" ~title:"cannot setup listener" ""
-    | Some server ->
-        let pipeline_cache = Mpipeline.With_cache.init () in
-        ignore @@ loop (File_id.get Sys.executable_name) server;
-        Mpipeline.With_cache.shutdown pipeline_cache;
-        Os_ipc.server_close server
+      if continue then loop merlinid server ~get_pipeline
 end
 
 let main () =
   (* Setup env for extensions *)
   Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ()));
   match List.tl (Array.to_list Sys.argv) with
-  | "single" :: args -> exit (New_merlin.run ~new_env:None None args)
+  | "single" :: args ->
+    let get_pipeline _ a b= Some (Mpipeline.make a b) in
+    exit (New_merlin.run ~get_pipeline ~new_env:None None args)
   | "old-protocol" :: args -> Old_merlin.run args
-  | ["server"; socket_path; socket_fd] -> Server.start socket_path socket_fd
+  | ["server"; socket_path; socket_fd] ->
+    begin
+    match Os_ipc.server_setup socket_path socket_fd with
+    | None ->
+      Logger.log ~section:"server" ~title:"cannot setup listener" ""
+    | Some server ->
+      ignore @@ Mpipeline.make_with_cache (Server.loop (File_id.get Sys.executable_name) server);
+      Os_ipc.server_close server
+    end
   | ("-help" | "--help" | "-h" | "server") :: _ ->
     Printf.eprintf
       "Usage: %s <frontend> <arguments...>\n\

src/kernel/mpipeline.ml

@@ -329,16 +329,13 @@ module With_cache = struct
   (* Info shared from background domain to main domain *)
   type nonrec cache = { pipeline : t; file : string }
 
-  type t = unit Domain.t
-
-
   (* Info shared from main domain to background domain *)
   type input = { config : Mconfig.t; source : Msource.t; file : string }
 
   let cache : cache option Atomic.t = Atomic.make None
   let input : input option Atomic.t = Atomic.make None
   let shut_down : bool Atomic.t = Atomic.make false
-
+  let domain_is_up : bool Atomic.t = Atomic.make false
 
   let trigger_pipeline file config source =
     Atomic.set input (Some { config; source; file })
@@ -357,13 +354,16 @@ module With_cache = struct
         trigger_pipeline file config source;
         let rec loop () =
           match Atomic.get cache with
-          | Some { pipeline; file = _ } -> pipeline
+          | Some { pipeline; file = _ } -> Some pipeline
           | None ->
-              Domain.cpu_relax ();
-              loop ()
+              if Atomic.get domain_is_up then None else
+              begin
+                Domain.cpu_relax ();
+                loop ()
+              end
         in
         loop ()
-    | None -> make config source
+    | None -> Some (make config source)
 
   let bg_domain_main () =
     let rec loop () =
@@ -382,9 +382,17 @@ module With_cache = struct
     loop ()
 
     let init () =
-      Domain.spawn bg_domain_main
+      let d = Domain.spawn bg_domain_main in
+      Atomic.set domain_is_up true;
+      d
 
     let shutdown t =
       Atomic.set shut_down true;
       Domain.join t;
+      Atomic.set domain_is_up false
 end
+
+let make_with_cache loop =
+  let d = With_cache.init () in
+  loop ~get_pipeline:(With_cache.get_pipeline);
+  With_cache.shutdown d

src/kernel/mpipeline.mli

@@ -27,13 +27,4 @@ val typer_errors : t -> exn list
 
 val timing_information : t -> (string * float) list
 
-module With_cache : sig
-    type pipeline
-    type t
-    type cache
-
-    val get_pipeline : string option -> Mconfig.t -> Msource.t -> pipeline
-    val init : unit -> t
-    val shutdown : t -> unit
-end
-with type pipeline := t
+val make_with_cache : (get_pipeline: (string option -> Mconfig.t -> Msource.t -> t option) -> unit) -> unit