Upstream lyrm in merlin domains

src/commands/new_commands.mli

@@ -35,7 +35,11 @@ type command =
       * Marg.docstring
       * ([ `Mandatory | `Optional | `Many ] * 'args Marg.spec) list
       * 'args
-      * (Mpipeline.t -> 'args -> json)
+      * (Mpipeline.shared ->
+        Mconfig.t ->
+        Msource.t ->
+        'args ->
+        json * Mpipeline.t option)
       -> command
 
 val all_commands : command list

src/frontend/ocamlmerlin/new/new_merlin.ml

@@ -47,7 +47,7 @@ let commands_help () =
       print_endline doc)
     New_commands.all_commands
 
-let run =
+let run shared =
   let query_num = ref (-1) in
   function
   | [] ->
@@ -109,37 +109,42 @@ let run =
               (float_of_int (60 * Mconfig.(config.merlin.cache_lifespan)))
             ();
           File_id.with_cache @@ fun () ->
+          let store = Mpipeline.Cache.get config in
+          Local_store.open_store store;
           let source = Msource.make (Misc.string_of_file stdin) in
-          let pipeline = Mpipeline.make config source in
+          (* let pipeline = Mpipeline.get shared config source in *)
           let json =
-            let class_, message =
+            let class_, message, pipeline =
               Printexc.record_backtrace true;
-              match
-                Mpipeline.with_pipeline pipeline @@ fun () ->
-                command_action pipeline command_args
-              with
-              | result -> ("return", result)
+              match command_action shared config source command_args with
+              | result, pipeline -> ("return", result, pipeline)
               | exception Failure str ->
                 let trace = Printexc.get_backtrace () in
                 log ~title:"run" "Command error backtrace: %s" trace;
-                ("failure", `String str)
+                ("failure", `String str, None)
               | exception exn -> (
                 let trace = Printexc.get_backtrace () in
                 log ~title:"run" "Command error backtrace: %s" trace;
                 match Location.error_of_exn exn with
                 | None | Some `Already_displayed ->
-                  ("exception", `String (Printexc.to_string exn ^ "\n" ^ trace))
+                  ( "exception",
+                    `String (Printexc.to_string exn ^ "\n" ^ trace),
+                    None )
                 | Some (`Ok err) ->
                   Location.print_main Format.str_formatter err;
-                  ("error", `String (Format.flush_str_formatter ())))
+                  ("error", `String (Format.flush_str_formatter ()), None))
             in
+
+            Local_store.close_store store;
             let cpu_time = Misc.time_spent () -. start_cpu in
             let gc_stats = Gc.quick_stat () in
             let heap_mbytes =
               gc_stats.heap_words * (Sys.word_size / 8) / 1_000_000
             in
             let clock_time = (Unix.gettimeofday () *. 1000.) -. start_clock in
-            let timing = Mpipeline.timing_information pipeline in
+            let timing =
+              Option.fold ~none:[] ~some:Mpipeline.timing_information pipeline
+            in
             let pipeline_time =
               List.fold_left (fun acc (_, k) -> k +. acc) 0.0 timing
             in
@@ -152,13 +157,17 @@ let run =
               `String (Printf.sprintf "%s: %s" section msg)
             in
             let format_timing (k, v) = (k, `Int (int_of_float (0.5 +. v))) in
+            let cache =
+              Option.fold ~none:(`Assoc []) ~some:Mpipeline.cache_information
+                pipeline
+            in
             `Assoc
               [ ("class", `String class_);
                 ("value", message);
                 ("notifications", `List (List.rev_map notify !notifications));
                 ("timing", `Assoc (List.map format_timing timing));
                 ("heap_mbytes", `Int heap_mbytes);
-                ("cache", Mpipeline.cache_information pipeline);
+                ("cache", cache);
                 ("query_num", `Int !query_num)
               ]
           in
@@ -186,7 +195,7 @@ let with_wd ~wd ~old_wd f args =
       old_wd;
     f args
 
-let run ~new_env wd args =
+let run ~new_env shared wd args =
   begin
     match new_env with
     | Some env ->
@@ -197,10 +206,10 @@ let run ~new_env wd args =
   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 shared) args
     | None ->
       log ~title:"run" "No working directory specified (old wd: %S)" old_wd;
-      run args
+      run shared args
   in
   let `Log_file_path log_file, `Log_sections sections = Log_info.get () in
   Logger.with_log_file log_file ~sections @@ run args

src/frontend/ocamlmerlin/ocamlmerlin_server.ml

@@ -2,19 +2,19 @@ let merlin_timeout =
   try float_of_string (Sys.getenv "MERLIN_TIMEOUT") with _ -> 600.0
 
 module Server = struct
-  let process_request { Os_ipc.wd; environ; argv; context = _ } =
+  let process_request { Os_ipc.wd; environ; argv; context = _ } shared =
     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 ~new_env:(Some environ) shared (Some wd) args
 
-  let process_client client =
+  let process_client client shared =
     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 client shared with
     | code -> close_with code
     | exception Exit ->
       close_with (-1);
@@ -38,34 +38,49 @@ module Server = struct
     | Some _ as result -> result
     | None -> loop 1.0
 
-  let rec loop merlinid server =
+  let rec loop merlinid server shared =
     match server_accept merlinid server with
     | None ->
       (* Timeout *)
       ()
     | Some client ->
       let continue =
-        match process_client client with
+        match process_client client shared with
         | exception Exit -> false
         | () -> true
       in
-      if continue then loop merlinid server
+      if continue then loop merlinid server shared
 
   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 ->
       (* If the client closes its connection, don't let it kill us with a SIGPIPE. *)
+      let shared = Mpipeline.create_shared () in
+      let domain_typer = Domain.spawn @@ Mpipeline.domain_typer shared in
       if Sys.unix then Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
-      loop (File_id.get Sys.executable_name) server;
+      loop (File_id.get Sys.executable_name) server shared;
+
+      Atomic.set Mpipeline.(shared.closed) `True;
+      Shared.signal shared.curr_config;
+
+      Domain.join domain_typer;
       Os_ipc.server_close server
 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 shared = Mpipeline.create_shared () in
+    let domain_typer = Domain.spawn @@ Mpipeline.domain_typer shared in
+    let vexit = New_merlin.run ~new_env:None shared None args in
+    Atomic.set Mpipeline.(shared.closed) `True;
+    (* to unlock the typer domain *)
+    Shared.signal shared.curr_config;
+    Domain.join domain_typer;
+    exit vexit
   | "old-protocol" :: args -> Old_merlin.run args
   | [ "server"; socket_path; socket_fd ] -> Server.start socket_path socket_fd
   | ("-help" | "--help" | "-h" | "server") :: _ ->

src/kernel/mocaml.mli

@@ -1,5 +1,5 @@
 (* An instance of load path, environment cache & btype unification log  *)
-type typer_state
+type typer_state = Local_store.store
 
 val new_state : unit -> typer_state
 val with_state : typer_state -> (unit -> 'a) -> 'a