lose global compilation server, make the server manage it

src/compiler/args.ml

@@ -44,17 +44,15 @@ let add_libs com libs =
 	match libs with
 	| [] -> []
 	| _ ->
-		let lines = match CompilationServer.get() with
-			| Some cs ->
-				(try
-					(* if we are compiling, really call haxelib since library path might have changed *)
-					if com.display.dms_full_typing then raise Not_found;
-					cs#find_haxelib libs
-				with Not_found ->
-					let lines = call_haxelib() in
-					cs#cache_haxelib libs lines;
-					lines)
-			| _ -> call_haxelib()
+		let lines =
+			try
+				(* if we are compiling, really call haxelib since library path might have changed *)
+				if com.display.dms_full_typing then raise Not_found;
+				com.cs#find_haxelib libs
+			with Not_found ->
+				let lines = call_haxelib() in
+				com.cs#cache_haxelib libs lines;
+				lines
 		in
 		let extra_args = ref [] in
 		let lines = List.fold_left (fun acc l ->

src/compiler/compilationContext.ml

@@ -45,6 +45,7 @@ and compilation_context = {
 type server_accept = unit -> (bool * (bool -> string option) * (string -> unit) * (unit -> unit))
 
 type server_api = {
+	cache : CompilationServer.t;
 	before_anything : compilation_context -> unit;
 	after_arg_parsing : compilation_context -> unit;
 	after_compilation : compilation_context -> unit;

src/compiler/compiler.ml

@@ -223,22 +223,23 @@ let run_or_diagnose ctx f arg =
 let do_type ctx tctx actx =
 	let com = tctx.Typecore.com in
 	let t = Timer.timer ["typing"] in
-	Option.may (fun cs -> CommonCache.maybe_add_context_sign cs com "before_init_macros") (CompilationServer.get ());
+	let cs = com.cs in
+	CommonCache.maybe_add_context_sign cs com "before_init_macros";
 	com.stage <- CInitMacrosStart;
 	List.iter (MacroContext.call_init_macro tctx) (List.rev actx.config_macros);
 	com.stage <- CInitMacrosDone;
 	CommonCache.lock_signature com "after_init_macros";
 	List.iter (fun f -> f ()) (List.rev com.callbacks#get_after_init_macros);
 	run_or_diagnose ctx (fun () ->
-		if com.display.dms_kind <> DMNone then Option.may (DisplayTexpr.check_display_file tctx) (CompilationServer.get ());
+		if com.display.dms_kind <> DMNone then DisplayTexpr.check_display_file tctx cs;
 		List.iter (fun cpath -> ignore(tctx.Typecore.g.Typecore.do_load_module tctx cpath null_pos)) (List.rev actx.classes);
 		Finalization.finalize tctx;
 	) ();
 	com.stage <- CTypingDone;
 	(* If we are trying to find references, let's syntax-explore everything we know to check for the
 		identifier we are interested in. We then type only those modules that contain the identifier. *)
-	begin match !CompilationServer.instance,com.display.dms_kind with
-		| Some cs,(DMUsage _ | DMImplementation) -> FindReferences.find_possible_references tctx cs;
+	begin match com.display.dms_kind with
+		| (DMUsage _ | DMImplementation) -> FindReferences.find_possible_references tctx cs;
 		| _ -> ()
 	end;
 	t()
@@ -496,7 +497,7 @@ let setup_common_context ctx =
 		| CMInfo(_,_) | CMWarning(_,_) -> msg;)
 	) (filter_messages false (fun _ -> true))));
 	com.filter_messages <- (fun predicate -> (ctx.messages <- (List.rev (filter_messages true predicate))));
-	if CompilationServer.runs() then com.run_command <- run_command ctx;
+	com.run_command <- run_command ctx;
 	com.class_path <- get_std_class_paths ();
 	com.std_path <- List.filter (fun p -> ExtString.String.ends_with p "std/" || ExtString.String.ends_with p "std\\") com.class_path
 
@@ -701,7 +702,7 @@ with
 		raise exc
 	| Out_of_memory as exc ->
 		raise exc
-	| e when (try Sys.getenv "OCAMLRUNPARAM" <> "b" || CompilationServer.runs() with _ -> true) && not Helper.is_debug_run ->
+	| e when (try Sys.getenv "OCAMLRUNPARAM" <> "b" with _ -> true) && not Helper.is_debug_run ->
 		error ctx (Printexc.to_string e) null_pos
 
 let compile_ctx server_api comm ctx =
@@ -751,8 +752,8 @@ let compile_ctx server_api comm ctx =
 			error ctx ("Error: " ^ msg) null_pos;
 			false
 
-let create_context comm params = {
-	com = Common.create version params;
+let create_context comm cs params = {
+	com = Common.create cs version params;
 	on_exit = [];
 	messages = [];
 	has_next = false;
@@ -813,10 +814,11 @@ module HighLevel = struct
 		DynArray.to_list compilations
 
 	let entry server_api comm args =
+		let create = create_context comm server_api.cache in
 		let ctxs = try
-			process_params server_api (create_context comm) args
+			process_params server_api create args
 		with Arg.Bad msg ->
-			let ctx = create_context comm args in
+			let ctx = create args in
 			error ctx ("Error: " ^ msg) null_pos;
 			[ctx]
 		in

src/compiler/displayOutput.ml

@@ -412,17 +412,16 @@ let process_global_display_mode com tctx =
 		FindReferences.find_implementations tctx com
 	| DMModuleSymbols (Some "") -> ()
 	| DMModuleSymbols filter ->
-		let symbols = match CompilationServer.get() with
-			| None -> []
-			| Some cs ->
-				let l = cs#get_context_files ((Define.get_signature com.defines) :: (match com.get_macros() with None -> [] | Some com -> [Define.get_signature com.defines])) in
-				List.fold_left (fun acc (file_key,cfile) ->
-					let file = cfile.CompilationServer.c_file_path in
-					if (filter <> None || DisplayPosition.display_position#is_in_file (com.file_keys#get file)) then
-						(file,DocumentSymbols.collect_module_symbols (Some (file,get_module_name_of_cfile file cfile)) (filter = None) (cfile.c_package,cfile.c_decls)) :: acc
-					else
-						acc
-				) [] l
+		let cs = com.cs in
+		let symbols =
+			let l = cs#get_context_files ((Define.get_signature com.defines) :: (match com.get_macros() with None -> [] | Some com -> [Define.get_signature com.defines])) in
+			List.fold_left (fun acc (file_key,cfile) ->
+				let file = cfile.CompilationServer.c_file_path in
+				if (filter <> None || DisplayPosition.display_position#is_in_file (com.file_keys#get file)) then
+					(file,DocumentSymbols.collect_module_symbols (Some (file,get_module_name_of_cfile file cfile)) (filter = None) (cfile.c_package,cfile.c_decls)) :: acc
+				else
+					acc
+			) [] l
 		in
 		raise_module_symbols (DocumentSymbols.Printer.print_module_symbols com symbols filter)
 	| _ -> ()

src/compiler/haxe.ml

@@ -54,8 +54,7 @@ let args = List.tl (Array.to_list Sys.argv) in
 with Not_found ->
 	set_binary_mode_out stdout true;
 	set_binary_mode_out stderr true;
-	let cs = CompilationServer.create () in
-	let sctx = ServerCompilationContext.create false cs in
+	let sctx = ServerCompilationContext.create false in
 	Server.process sctx (Communication.create_stdio ()) args;
 );
 other();

src/compiler/server.ml

@@ -50,7 +50,7 @@ let check_display_flush ctx f_otherwise = match ctx.com.json_out with
 let current_stdin = ref None
 
 let parse_file cs com file p =
-	let cc = CommonCache.get_cache cs com in
+	let cc = CommonCache.get_cache com in
 	let ffile = Path.get_full_path file
 	and fkey = com.file_keys#get file in
 	let is_display_file = DisplayPosition.display_position#is_in_file (com.file_keys#get ffile) in
@@ -117,9 +117,9 @@ module ServerCompilationContext = struct
 		mutable macro_context_setup : bool;
 	}
 
-	let create verbose cs = {
+	let create verbose = {
 		verbose = verbose;
-		cs = cs;
+		cs = new CompilationServer.cache;
 		class_paths = Hashtbl.create 0;
 		changed_directories = Hashtbl.create 0;
 		compilation_step = 0;
@@ -301,7 +301,7 @@ let get_changed_directories sctx (ctx : Typecore.typer) =
    [Some m'] where [m'] is the module responsible for [m] not being reusable. *)
 let check_module sctx ctx m p =
 	let com = ctx.Typecore.com in
-	let cc = CommonCache.get_cache sctx.cs com in
+	let cc = CommonCache.get_cache com in
 	let content_changed m file =
 		let fkey = ctx.com.file_keys#get file in
 		try
@@ -459,7 +459,7 @@ let add_modules sctx ctx m p =
 let type_module sctx (ctx:Typecore.typer) mpath p =
 	let t = Timer.timer ["server";"module cache"] in
 	let com = ctx.Typecore.com in
-	let cc = CommonCache.get_cache sctx.cs com in
+	let cc = CommonCache.get_cache com in
 	sctx.mark_loop <- sctx.mark_loop + 1;
 	try
 		let m = cc#find_module mpath in
@@ -635,6 +635,7 @@ let rec process sctx comm args =
 	ServerMessage.arguments args;
 	reset sctx;
 	let api = {
+		cache = sctx.cs;
 		before_anything = before_anything sctx;
 		after_arg_parsing = after_arg_parsing sctx;
 		after_compilation = after_compilation sctx;
@@ -654,8 +655,8 @@ and wait_loop verbose accept =
 	if verbose then ServerMessage.enable_all ();
 	Sys.catch_break false; (* Sys can never catch a break *)
 	(* Create server context and set up hooks for parsing and typing *)
-	let cs = CompilationServer.create () in
-	let sctx = ServerCompilationContext.create verbose cs in
+	let sctx = ServerCompilationContext.create verbose in
+	let cs = sctx.cs in
 	TypeloadModule.type_module_hook := type_module sctx;
 	MacroContext.macro_enable_cache := true;
 	ServerCompilationContext.ensure_macro_setup sctx;

src/compiler/serverMessage.ml

@@ -56,7 +56,7 @@ let config = {
 
 let sign_string com =
 	let sign = Define.get_signature com.defines in
-	let cs = CompilationServer.force () in
+	let cs = com.cs in
 	let	sign_id = (cs#get_context sign)#get_index in
 	Printf.sprintf "%2i,%3s: " sign_id (short_platform_name com.platform)
 

src/context/common.ml

@@ -353,6 +353,7 @@ type context = {
 	(* typing *)
 	mutable basic : basic_types;
 	memory_marker : float array;
+	cs : CompilationServer.t;
 }
 
 exception Abort of string * pos
@@ -700,9 +701,10 @@ let get_config com =
 
 let memory_marker = [|Unix.time()|]
 
-let create version args =
+let create cs version args =
 	let m = Type.mk_mono() in
 	{
+		cs = cs;
 		cache = None;
 		stage = CCreated;
 		version = version;

src/context/commonCache.ml

@@ -6,8 +6,8 @@ open Type
 let handle_native_lib com lib =
 	com.native_libs.all_libs <- lib#get_file_path :: com.native_libs.all_libs;
 	com.load_extern_type <- com.load_extern_type @ [lib#get_file_path,lib#build];
-	match get() with
-	| Some cs when not (Define.raw_defined com.defines "haxe.noNativeLibsCache") ->
+	if not (Define.raw_defined com.defines "haxe.noNativeLibsCache") then begin
+		let cs = com.cs in
 		let init () =
 			let file = lib#get_file_path in
 			let key = file in
@@ -46,21 +46,21 @@ let handle_native_lib com lib =
 				name,if name = lib#get_file_path then build else f
 			) com.load_extern_type
 		)
-	| _ ->
+	end else
 		(* Offline mode, just read library as usual. *)
 		(fun () -> lib#load)
 
 (* context *)
 
-let get_cache cs com = match com.Common.cache with
+let get_cache com = match com.Common.cache with
 	| None ->
 		let sign = Define.get_signature com.defines in
-		cs#get_context sign
+		com.cs#get_context sign
 	| Some cache ->
 		cache
 
 let rec cache_context cs com =
-	let cc = get_cache cs com in
+	let cc = get_cache com in
 	let sign = Define.get_signature com.defines in
 	let cache_module m =
 		(* If we have a signature mismatch, look-up cache for module. Physical equality check is fine as a heueristic. *)
@@ -76,9 +76,7 @@ let maybe_add_context_sign cs com desc =
 	let sign = Define.get_signature com.defines in
 	ignore(cs#add_info sign desc com.platform com.class_path com.defines)
 
-let lock_signature com name = match CompilationServer.get() with
-	| Some cs ->
-		maybe_add_context_sign cs com name;
-		com.cache <- Some (get_cache cs com)
-	| None ->
-		()
+let lock_signature com name =
+	let cs = com.cs in
+	maybe_add_context_sign cs com name;
+	com.cache <- Some (get_cache com)

src/context/compilationServer.ml

@@ -258,21 +258,6 @@ type context_options =
 	| MacroContext
 	| NormalAndMacroContext
 
-let instance : t option ref = ref None
-
-let create () =
-	let cs = new cache in
-	instance := Some cs;
-	cs
-
-let get () =
-	!instance
-
-let runs () =
-	!instance <> None
-
-let force () = match !instance with None -> die "" __LOC__ | Some i -> i
-
 let get_module_name_of_cfile file cfile = match cfile.c_module_name with
 	| None ->
 		let name = Path.module_name_of_file file in

src/context/display/displayJson.ml

@@ -310,10 +310,7 @@ let parse_input com input report_times =
 		jsonrpc = jsonrpc
 	});
 
-	let cs = match CompilationServer.get() with
-		| Some cs -> cs
-		| None -> send_error [jstring "compilation server not running for some reason"];
-	in
+	let cs = com.cs in
 
 	let display = new display_handler jsonrpc com cs in
 

src/context/display/displayToplevel.ml

@@ -79,10 +79,7 @@ class explore_class_path_task cs com recursive f_pack f_module dir pack = object
 							f_pack (List.rev pack,file);
 							if recursive then begin
 								let task = new explore_class_path_task cs com recursive f_pack f_module (dir ^ file ^ "/") (file :: pack) in
-								begin match cs with
-									| None -> task#run
-									| Some cs' -> cs'#add_task task
-								end
+								cs#add_task task
 							end
 						end
 					| _ ->
@@ -112,15 +109,12 @@ class explore_class_path_task cs com recursive f_pack f_module dir pack = object
 end
 
 let explore_class_paths com timer class_paths recursive f_pack f_module =
-	let cs = CompilationServer.get() in
+	let cs = com.cs in
 	let t = Timer.timer (timer @ ["class path exploration"]) in
 	let tasks = List.map (fun dir ->
 		new explore_class_path_task cs com recursive f_pack f_module dir []
 	) class_paths in
-	begin match cs with
-	| None -> List.iter (fun task -> task#run) tasks
-	| Some cs -> List.iter (fun task -> cs#add_task task) tasks
-	end;
+	List.iter (fun task -> cs#add_task task) tasks;
 	t()
 
 let read_class_paths com timer =
@@ -128,17 +122,15 @@ let read_class_paths com timer =
 		(* Don't parse the display file as that would maybe overwrite the content from stdin with the file contents. *)
 		if not (DisplayPosition.display_position#is_in_file (com.file_keys#get file)) then begin
 			let file,_,pack,_ = Display.parse_module' com path Globals.null_pos in
-			match CompilationServer.get() with
-			| Some cs when pack <> fst path ->
+			if pack <> fst path then begin
 				let file_key = com.file_keys#get file in
-				(CommonCache.get_cache cs com)#remove_file_for_real file_key
-			| _ ->
-				()
+				(CommonCache.get_cache com)#remove_file_for_real file_key
+			end
 		end
 	)
 
 let init_or_update_server cs com timer_name =
-	let cc = CommonCache.get_cache cs com in
+	let cc = CommonCache.get_cache com in
 	if not cc#is_initialized then begin
 		cc#set_initialized true;
 		read_class_paths com timer_name
@@ -464,58 +456,46 @@ let collect ctx tk with_type sort =
 	List.iter add_type (List.rev_map fst ctx.m.module_imports); (* reverse! *)
 
 	(* types from files *)
-	begin match !CompilationServer.instance with
-	| None ->
-		(* offline: explore class paths *)
-		let class_paths = ctx.com.class_path in
-		let class_paths = List.filter (fun s -> s <> "") class_paths in
-		explore_class_paths ctx.com ["display";"toplevel"] class_paths true add_package (fun file path ->
-			if not (path_exists cctx path) then begin
-				let _,decls = Display.parse_module ctx path Globals.null_pos in
-				ignore(process_decls (fst path) (snd path) decls)
-			end
-		)
-	| Some cs ->
-		(* online: iter context files *)
-		init_or_update_server cs ctx.com ["display";"toplevel"];
-		let cc = CommonCache.get_cache cs ctx.com in
-		let files = cc#get_files in
-		(* Sort files by reverse distance of their package to our current package. *)
-		let files = Hashtbl.fold (fun file cfile acc ->
-			let i = pack_similarity curpack cfile.c_package in
-			((file,cfile),i) :: acc
-		) files [] in
-		let files = List.sort (fun (_,i1) (_,i2) -> -compare i1 i2) files in
-		let check_package pack = match List.rev pack with
-			| [] -> ()
-			| s :: sl -> add_package (List.rev sl,s)
-		in
-		List.iter (fun ((file_key,cfile),_) ->
-			let module_name = CompilationServer.get_module_name_of_cfile cfile.c_file_path cfile in
-			let dot_path = s_type_path (cfile.c_package,module_name) in
-			(* In legacy mode we only show toplevel types. *)
-			if is_legacy_completion && cfile.c_package <> [] then begin
-				(* And only toplevel packages. *)
-				match cfile.c_package with
-				| [s] -> add_package ([],s)
-				| _ -> ()
-			end else if (List.exists (fun e -> ExtString.String.starts_with dot_path (e ^ ".")) !exclude) then
-				()
-			else begin
-				Hashtbl.replace ctx.com.module_to_file (cfile.c_package,module_name) cfile.c_file_path;
-				if process_decls cfile.c_package module_name cfile.c_decls then check_package cfile.c_package;
-			end
-		) files;
-		List.iter (fun file ->
-			match cs#get_native_lib file with
-			| Some lib ->
-				Hashtbl.iter (fun path (pack,decls) ->
-					if process_decls pack (snd path) decls then check_package pack;
-				) lib.c_nl_files
-			| None ->
-				()
-		) ctx.com.native_libs.all_libs
-	end;
+	let cs = ctx.com.cs in
+	(* online: iter context files *)
+	init_or_update_server cs ctx.com ["display";"toplevel"];
+	let cc = CommonCache.get_cache ctx.com in
+	let files = cc#get_files in
+	(* Sort files by reverse distance of their package to our current package. *)
+	let files = Hashtbl.fold (fun file cfile acc ->
+		let i = pack_similarity curpack cfile.c_package in
+		((file,cfile),i) :: acc
+	) files [] in
+	let files = List.sort (fun (_,i1) (_,i2) -> -compare i1 i2) files in
+	let check_package pack = match List.rev pack with
+		| [] -> ()
+		| s :: sl -> add_package (List.rev sl,s)
+	in
+	List.iter (fun ((file_key,cfile),_) ->
+		let module_name = CompilationServer.get_module_name_of_cfile cfile.c_file_path cfile in
+		let dot_path = s_type_path (cfile.c_package,module_name) in
+		(* In legacy mode we only show toplevel types. *)
+		if is_legacy_completion && cfile.c_package <> [] then begin
+			(* And only toplevel packages. *)
+			match cfile.c_package with
+			| [s] -> add_package ([],s)
+			| _ -> ()
+		end else if (List.exists (fun e -> ExtString.String.starts_with dot_path (e ^ ".")) !exclude) then
+			()
+		else begin
+			Hashtbl.replace ctx.com.module_to_file (cfile.c_package,module_name) cfile.c_file_path;
+			if process_decls cfile.c_package module_name cfile.c_decls then check_package cfile.c_package;
+		end
+	) files;
+	List.iter (fun file ->
+		match cs#get_native_lib file with
+		| Some lib ->
+			Hashtbl.iter (fun path (pack,decls) ->
+				if process_decls pack (snd path) decls then check_package pack;
+			) lib.c_nl_files
+		| None ->
+			()
+	) ctx.com.native_libs.all_libs;
 
 	(* packages *)
 	Hashtbl.iter (fun path _ ->

src/context/display/syntaxExplorer.ml

@@ -161,7 +161,7 @@ let find_in_syntax symbols (pack,decls) =
 
 let explore_uncached_modules tctx cs symbols =
 	DisplayToplevel.init_or_update_server cs tctx.com ["display";"references"];
-	let cc = CommonCache.get_cache cs tctx.com in
+	let cc = CommonCache.get_cache tctx.com in
 	let files = cc#get_files in
 	let modules = cc#get_modules in
 	let t = Timer.timer ["display";"references";"candidates"] in

src/context/memory.ml

@@ -237,53 +237,50 @@ let display_memory com =
 	let mem = Gc.stat() in
 	print ("Total Allocated Memory " ^ fmt_size (mem.Gc.heap_words * (Sys.word_size asr 8)));
 	print ("Free Memory " ^ fmt_size (mem.Gc.free_words * (Sys.word_size asr 8)));
-	(match get() with
-	| None ->
-		print "No cache found";
-	| Some c ->
-		print ("Total cache size " ^ size c);
-		(* print ("  haxelib " ^ size c.c_haxelib); *)
-		(* print ("  parsed ast " ^ size c.c_files ^ " (" ^ string_of_int (Hashtbl.length c.c_files) ^ " files stored)"); *)
-		(* print ("  typed modules " ^ size c.c_modules ^ " (" ^ string_of_int (Hashtbl.length c.c_modules) ^ " modules stored)"); *)
-		let module_list = c#get_modules in
-		let all_modules = List.fold_left (fun acc m -> PMap.add m.m_id m acc) PMap.empty module_list in
-		let modules = List.fold_left (fun acc m ->
-			let (size,r) = get_module_memory c all_modules m in
-			(m,size,r) :: acc
-		) [] module_list in
-		let cur_key = ref "" and tcount = ref 0 and mcount = ref 0 in
-		List.iter (fun (m,size,(reached,deps,out,leaks)) ->
-			let key = m.m_extra.m_sign in
-			if key <> !cur_key then begin
-				print (Printf.sprintf ("    --- CONFIG %s ----------------------------") (Digest.to_hex key));
-				cur_key := key;
-			end;
-			print (Printf.sprintf "    %s : %s" (s_type_path m.m_path) (fmt_size size));
-			(if reached then try
-				incr mcount;
-				let lcount = ref 0 in
-				let leak l =
-					incr lcount;
-					incr tcount;
-					print (Printf.sprintf "      LEAK %s" l);
-					if !lcount >= 3 && !tcount >= 100 && not verbose then begin
-						print (Printf.sprintf "      ...");
-						raise Exit;
-					end;
-				in
-				List.iter leak leaks;
-			with Exit ->
-				());
-			if verbose then begin
-				print (Printf.sprintf "      %d total deps" (List.length deps));
-				PMap.iter (fun _ md ->
-					print (Printf.sprintf "      dep %s%s" (s_type_path md.m_path) (module_sign key md));
-				) m.m_extra.m_deps;
-			end;
-			flush stdout
-		) (List.sort (fun (m1,s1,_) (m2,s2,_) ->
-			let k1 = m1.m_extra.m_sign and k2 = m2.m_extra.m_sign in
-			if k1 = k2 then s1 - s2 else if k1 > k2 then 1 else -1
-		) modules);
-		if !mcount > 0 then print ("*** " ^ string_of_int !mcount ^ " modules have leaks !");
-		print "Cache dump complete")
+	let c = com.cs in
+	print ("Total cache size " ^ size c);
+	(* print ("  haxelib " ^ size c.c_haxelib); *)
+	(* print ("  parsed ast " ^ size c.c_files ^ " (" ^ string_of_int (Hashtbl.length c.c_files) ^ " files stored)"); *)
+	(* print ("  typed modules " ^ size c.c_modules ^ " (" ^ string_of_int (Hashtbl.length c.c_modules) ^ " modules stored)"); *)
+	let module_list = c#get_modules in
+	let all_modules = List.fold_left (fun acc m -> PMap.add m.m_id m acc) PMap.empty module_list in
+	let modules = List.fold_left (fun acc m ->
+		let (size,r) = get_module_memory c all_modules m in
+		(m,size,r) :: acc
+	) [] module_list in
+	let cur_key = ref "" and tcount = ref 0 and mcount = ref 0 in
+	List.iter (fun (m,size,(reached,deps,out,leaks)) ->
+		let key = m.m_extra.m_sign in
+		if key <> !cur_key then begin
+			print (Printf.sprintf ("    --- CONFIG %s ----------------------------") (Digest.to_hex key));
+			cur_key := key;
+		end;
+		print (Printf.sprintf "    %s : %s" (s_type_path m.m_path) (fmt_size size));
+		(if reached then try
+			incr mcount;
+			let lcount = ref 0 in
+			let leak l =
+				incr lcount;
+				incr tcount;
+				print (Printf.sprintf "      LEAK %s" l);
+				if !lcount >= 3 && !tcount >= 100 && not verbose then begin
+					print (Printf.sprintf "      ...");
+					raise Exit;
+				end;
+			in
+			List.iter leak leaks;
+		with Exit ->
+			());
+		if verbose then begin
+			print (Printf.sprintf "      %d total deps" (List.length deps));
+			PMap.iter (fun _ md ->
+				print (Printf.sprintf "      dep %s%s" (s_type_path md.m_path) (module_sign key md));
+			) m.m_extra.m_deps;
+		end;
+		flush stdout
+	) (List.sort (fun (m1,s1,_) (m2,s2,_) ->
+		let k1 = m1.m_extra.m_sign and k2 = m2.m_extra.m_sign in
+		if k1 = k2 then s1 - s2 else if k1 > k2 then 1 else -1
+	) modules);
+	if !mcount > 0 then print ("*** " ^ string_of_int !mcount ^ " modules have leaks !");
+	print "Cache dump complete"

src/macro/macroApi.ml

@@ -1981,8 +1981,8 @@ let macro_api ccom get_api =
 			vnull
 		);
 		"server_invalidate_files", vfun1 (fun a ->
-			let cs = match CompilationServer.get() with Some cs -> cs | None -> failwith "compilation server not running" in
 			let com = ccom() in
+			let cs = com.cs in
 			List.iter (fun v ->
 				let s = decode_string v in
 				let s = com.file_keys#get s in