diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index c43c2baa9..374ddc0bc 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/src/frontend/ocamlmerlin/new/new_merlin.ml @@ -112,9 +112,7 @@ let run = 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.get ~state:(Mpipeline.Cache.get config) config source - in + let pipeline = Mpipeline.get config source in let json = let class_, message = Printexc.record_backtrace true; diff --git a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml index 35ca8a3a6..6641b0af1 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml @@ -56,8 +56,12 @@ module Server = struct | 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 domain_typer = Domain.spawn Mpipeline.domain_typer in if Sys.unix then Sys.set_signal Sys.sigpipe Sys.Signal_ignore; loop (File_id.get Sys.executable_name) server; + + Atomic.set Mpipeline.close_typer `True; + Domain.join domain_typer; Os_ipc.server_close server end @@ -65,7 +69,12 @@ 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 domain_typer = Domain.spawn Mpipeline.domain_typer in + let vexit = New_merlin.run ~new_env:None None args in + Atomic.set Mpipeline.close_typer `True; + 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") :: _ -> diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 953ef47cf..79e285d97 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -321,8 +321,6 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) let make config source = process (Mconfig.normalize config) source -let get ?state config source = process ?state (Mconfig.normalize config) source - let for_completion position { config; state; @@ -367,3 +365,45 @@ let cache_information t = ("cmt", cmt); ("cmi", cmi) ] + +let shared_config = Atomic.make None +let shared_pipeline = Atomic.make None + +let close_typer = Atomic.make `False + +let domain_typer () = + let rec loop () = + if Atomic.get close_typer = `True then () + else + match Atomic.get shared_config with + | None -> + Domain.cpu_relax (); + loop () + | Some (config, source) as curr -> ( + try + let pipeline = make config source in + if Atomic.compare_and_set shared_config curr None then + Atomic.set shared_pipeline (Some pipeline); + loop () + with exn -> Atomic.set close_typer (`Exn exn)) + in + loop () + +let get config source = + Atomic.set shared_config (Some (config, source)); + + let rec loop count = + match Atomic.get shared_pipeline with + | None -> begin + match Atomic.get close_typer with + | `Exn exn -> raise exn + | `True -> assert false + | _ -> + Domain.cpu_relax (); + loop (count + 1) + end + | Some pipeline -> + Atomic.set shared_pipeline None; + pipeline + in + loop 0 diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index c7e9ba80b..2586132ff 100644 --- a/src/kernel/mpipeline.mli +++ b/src/kernel/mpipeline.mli @@ -1,6 +1,6 @@ type t val make : Mconfig.t -> Msource.t -> t -val get : ?state:Mocaml.typer_state -> Mconfig.t -> Msource.t -> t +val get : Mconfig.t -> Msource.t -> t val with_pipeline : t -> (unit -> 'a) -> 'a val for_completion : Msource.position -> t -> t @@ -33,3 +33,7 @@ val cache_information : t -> Std.json module Cache : sig val get : Mconfig.t -> Mocaml.typer_state end + +val close_typer : [ `True | `False | `Exn of exn ] Atomic.t + +val domain_typer : unit -> unit