[server] allow message configuration

src/compiler/main.ml

@@ -737,7 +737,7 @@ try
 				| _ ->
 					let host, port = (try ExtString.String.split hp ":" with _ -> "127.0.0.1", hp) in
 					let port = try int_of_string port with _ -> raise (Arg.Bad "Invalid port") in
-					init_wait_socket com.verbose host port
+					init_wait_socket host port
 			in
 			wait_loop process_params com.verbose accept
 		),"[[host:]port]|stdio]","wait on the given port (or use standard i/o) for commands to run)");

src/compiler/server.ml

@@ -26,16 +26,222 @@ type context = {
 	mutable has_error : bool;
 }
 
-type server_message =
-	| AddedDirectory of string
-	| FoundDirectories of (string * float ref) list
-	| ChangedDirectories of (string * float) list
-	| ModulePathChanged of (module_def * float * string)
-	| NotCached of module_def
-	| Parsed of (string * string)
-	| RemovedDirectory of string
-	| Reusing of module_def
-	| SkippingDep of (module_def * module_def)
+module ServerMessage = struct
+	type t =
+		| AddedDirectory of string
+		| FoundDirectories of (string * float ref) list
+		| ChangedDirectories of (string * float) list
+		| ModulePathChanged of (module_def * float * string)
+		| NotCached of module_def
+		| Parsed of (string * string)
+		| RemovedDirectory of string
+		| Reusing of module_def
+		| SkippingDep of (module_def * module_def)
+		| UnchangedContent of string
+		| CachedModules of int
+		| ClassPathsChanged
+
+	type server_message_options = {
+		mutable print_added_directory : bool;
+		mutable print_found_directories : bool;
+		mutable print_changed_directories : bool;
+		mutable print_module_path_changed : bool;
+		mutable print_not_cached : bool;
+		mutable print_parsed : bool;
+		mutable print_removed_directory : bool;
+		mutable print_reusing : bool;
+		mutable print_skipping_dep : bool;
+		mutable print_unchanged_content : bool;
+		mutable print_cached_modules : bool;
+		mutable print_class_paths_changed : bool;
+		mutable print_arguments : bool;
+		mutable print_completion : bool;
+		mutable print_defines : bool;
+		mutable print_signature : bool;
+		mutable print_display_position : bool;
+		mutable print_stats : bool;
+		mutable print_message : bool;
+		mutable print_socket_message : bool;
+		mutable print_uncaught_error : bool;
+		mutable print_new_context : bool;
+	}
+
+	let config = {
+		print_added_directory = false;
+		print_found_directories = false;
+		print_changed_directories = false;
+		print_module_path_changed = false;
+		print_not_cached = false;
+		print_parsed = false;
+		print_removed_directory = false;
+		print_reusing = false;
+		print_skipping_dep = false;
+		print_unchanged_content = false;
+		print_cached_modules = false;
+		print_class_paths_changed = false;
+		print_arguments = false;
+		print_completion = false;
+		print_defines = false;
+		print_signature = false;
+		print_display_position = false;
+		print_stats = false;
+		print_message = false;
+		print_socket_message = false;
+		print_uncaught_error = true;
+		print_new_context = true;
+	}
+
+	let test_server_messages = DynArray.create ()
+
+	let sign_string com =
+		let sign = Define.get_signature com.defines in
+		let cs = CompilationServer.force () in
+		let	sign_id =
+			try
+				CompilationServer.get_sign cs sign;
+			with Not_found ->
+				let i = CompilationServer.add_sign cs sign in
+				if config.print_new_context then print_endline (Printf.sprintf "Found context %s:\n%s" i (dump_context com));
+				i
+		in
+		Printf.sprintf "%2s,%3s: " sign_id (short_platform_name com.platform)
+
+	let process_server_message com tabs =
+		if Common.raw_defined com "compilation-server-test" then (fun message ->
+			let module_path m = JString (s_type_path m.m_path) in
+			let kind,data = match message with
+				| AddedDirectory dir -> "addedDirectory",JString dir
+				| FoundDirectories dirs -> "foundDirectories",JInt (List.length dirs)
+				| ChangedDirectories dirs -> "changedDirectories",JArray (List.map (fun (s,_) -> JString s) dirs)
+				| ModulePathChanged(m,time,file) -> "modulePathChanged",module_path m
+				| NotCached m -> "notCached",module_path m
+				| Parsed(ffile,_) -> "parsed",JString ffile
+				| RemovedDirectory dir -> "removedDirectory",JString dir
+				| Reusing m -> "reusing",module_path m
+				| SkippingDep(m,m') -> "skipping",JObject ["skipped",module_path m;"dependency",module_path m']
+				| UnchangedContent file -> "unchangedContent",JString file
+				| CachedModules i -> "cachedModules",JInt i
+				| ClassPathsChanged -> "classPathsChanged",JNull
+			in
+			let js = JObject [("kind",JString kind);("data",data)] in
+			DynArray.add test_server_messages js;
+		) else
+		(fun message -> match message with
+			| AddedDirectory dir -> print_endline (Printf.sprintf "%sadded directory %s" (sign_string com) dir)
+			| FoundDirectories dirs -> print_endline (Printf.sprintf "%sfound %i directories" (sign_string com) (List.length dirs));
+			| ChangedDirectories dirs ->
+				print_endline (Printf.sprintf "%schanged directories: [%s]" (sign_string com) (String.concat ", " (List.map (fun (s,_) -> "\"" ^ s ^ "\"") dirs)))
+			| ModulePathChanged(m,time,file) ->
+				print_endline (Printf.sprintf "%smodule path might have changed: %s\n\twas: %2.0f %s\n\tnow: %2.0f %s"
+					(sign_string com) (s_type_path m.m_path) m.m_extra.m_time m.m_extra.m_file time file);
+			| NotCached m -> print_endline (Printf.sprintf "%s%s not cached (%s)" (sign_string com) (s_type_path m.m_path) (if m.m_extra.m_time = -1. then "macro-in-macro" else "modified"));
+			| Parsed(ffile,info) -> print_endline (Printf.sprintf "%sparsed %s (%s)" (sign_string com) ffile info)
+			| RemovedDirectory dir -> print_endline (Printf.sprintf "%sremoved directory %s" (sign_string com) dir);
+			| Reusing m ->  print_endline (Printf.sprintf "%s%sreusing %s" (sign_string com) tabs (s_type_path m.m_path));
+			| SkippingDep(m,m') -> print_endline (Printf.sprintf "%sskipping %s%s" (sign_string com) (s_type_path m.m_path) (if m == m' then "" else Printf.sprintf "(%s)" (s_type_path m'.m_path)));
+			| UnchangedContent file -> print_endline (Printf.sprintf "%s%s changed time not but content, reusing" (sign_string com) file)
+			| CachedModules i -> print_endline (Printf.sprintf "%sCached %i modules" (sign_string com) i);
+			| ClassPathsChanged -> print_endline (Printf.sprintf "%sclass paths changed, resetting directories" (sign_string com))
+		)
+
+	let added_directory com tabs x =
+		if config.print_added_directory then process_server_message com tabs (AddedDirectory x)
+
+	let found_directories com tabs x =
+		if config.print_found_directories then process_server_message com tabs (FoundDirectories x)
+
+	let changed_directories com tabs x =
+		if config.print_changed_directories then process_server_message com tabs (ChangedDirectories x)
+
+	let module_path_changed com tabs arg =
+		if config.print_module_path_changed then process_server_message com tabs (ModulePathChanged arg)
+
+	let not_cached com tabs x =
+		if config.print_not_cached then process_server_message com tabs (NotCached x)
+
+	let parsed com tabs x =
+		if config.print_parsed then process_server_message com tabs (Parsed x)
+
+	let removed_directory com tabs x =
+		if config.print_removed_directory then process_server_message com tabs (RemovedDirectory x)
+
+	let reusing com tabs x =
+		if config.print_reusing then process_server_message com tabs (Reusing x)
+
+	let skipping_dep com tabs x =
+		if config.print_skipping_dep then process_server_message com tabs (SkippingDep x)
+
+	let unchanged_content com tabs x =
+		if config.print_unchanged_content then process_server_message com tabs (UnchangedContent x)
+
+	let cached_modules com tabs x =
+		if config.print_cached_modules then process_server_message com tabs (CachedModules x)
+
+	let class_paths_changed com tabs =
+		if config.print_class_paths_changed then process_server_message com tabs ClassPathsChanged
+
+	let arguments data =
+		if config.print_arguments then print_endline (("Processing Arguments [" ^ String.concat "," data ^ "]"))
+
+	let completion str =
+		if config.print_completion then print_endline ("Completion Response =\n" ^ str)
+
+	let defines com tabs =
+		if config.print_defines then begin
+			let defines = PMap.foldi (fun k v acc -> (k ^ "=" ^ v) :: acc) com.defines.Define.values [] in
+			print_endline ("Defines " ^ (String.concat "," (List.sort compare defines)))
+		end
+
+	let signature com tabs sign =
+		if config.print_signature then print_endline ("Using signature " ^ Digest.to_hex sign)
+
+	let display_position com tabs p =
+		if config.print_display_position then print_endline ("Display position: " ^ (Printer.s_pos p))
+
+	let stats stats time =
+		if config.print_stats then begin
+			print_endline (Printf.sprintf "Stats = %d files, %d classes, %d methods, %d macros" !(stats.s_files_parsed) !(stats.s_classes_built) !(stats.s_methods_typed) !(stats.s_macros_called));
+			print_endline (Printf.sprintf "Time spent : %.3fs" time)
+		end
+
+	let message s =
+		if config.print_message then print_endline ("> " ^ s)
+
+	let gc_stats time =
+		if config.print_stats then begin
+			let stat = Gc.quick_stat() in
+			let size = (float_of_int stat.Gc.heap_words) *. 4. in
+			print_endline (Printf.sprintf "Compacted memory %.3fs %.1fMB" time (size /. (1024. *. 1024.)));
+		end
+
+	let socket_message s =
+		if config.print_socket_message then print_endline s
+
+	let uncaught_error s =
+		if config.print_uncaught_error then print_endline ("Uncaught Error : " ^ s)
+
+	let enable_all () =
+		config.print_added_directory <- true;
+		config.print_found_directories <- true;
+		config.print_changed_directories <- true;
+		config.print_module_path_changed <- true;
+		config.print_not_cached <- true;
+		config.print_parsed <- true;
+		config.print_removed_directory <- true;
+		config.print_reusing <- true;
+		config.print_skipping_dep <- true;
+		config.print_unchanged_content <- true;
+		config.print_cached_modules <- true;
+		config.print_completion <- true;
+		config.print_defines <- true;
+		config.print_signature <- true;
+		config.print_display_position <- true;
+		config.print_stats <- true;
+		config.print_message <- true;
+		config.print_socket_message <- true;
+		config.print_uncaught_error <- true;
+		config.print_new_context <- true;
+end
 
 let s_version =
 	Printf.sprintf "%d.%d.%d%s" version_major version_minor version_revision (match Version.version_extra with None -> "" | Some v -> " " ^ v)
@@ -115,53 +321,10 @@ let ssend sock str =
 	loop 0 (Bytes.length str)
 
 let rec wait_loop process_params verbose accept =
+	if verbose then ServerMessage.enable_all ();
 	Sys.catch_break false; (* Sys can never catch a break *)
 	let has_parse_error = ref false in
-	let test_server_messages = DynArray.create () in
 	let cs = CompilationServer.create () in
-	let sign_string com =
-		let sign = Define.get_signature com.defines in
-		let	sign_id =
-			try
-				CompilationServer.get_sign cs sign;
-			with Not_found ->
-				let i = CompilationServer.add_sign cs sign in
-				print_endline (Printf.sprintf "Found context %s:\n%s" i (dump_context com));
-				i
-		in
-		Printf.sprintf "%2s,%3s: " sign_id (short_platform_name com.platform)
-	in
-	let process_server_message com tabs =
-		if Common.raw_defined com "compilation-server-test" then (fun message ->
-			let module_path m = JString (s_type_path m.m_path) in
-			let kind,data = match message with
-				| AddedDirectory dir -> "addedDirectory",JString dir
-				| FoundDirectories dirs -> "foundDirectories",JInt (List.length dirs)
-				| ChangedDirectories dirs -> "changedDirectories",JArray (List.map (fun (s,_) -> JString s) dirs)
-				| ModulePathChanged(m,time,file) -> "modulePathChanged",module_path m
-				| NotCached m -> "notCached",module_path m
-				| Parsed(ffile,_) -> "parsed",JString ffile
-				| RemovedDirectory dir -> "removedDirectory",JString dir
-				| Reusing m -> "reusing",module_path m
-				| SkippingDep(m,m') -> "skipping",JObject ["skipped",module_path m;"dependency",module_path m']
-			in
-			let js = JObject [("kind",JString kind);("data",data)] in
-			DynArray.add test_server_messages js;
-		) else (fun message -> match message with
-			| AddedDirectory dir -> print_endline (Printf.sprintf "%sadded directory %s" (sign_string com) dir)
-			| FoundDirectories dirs -> print_endline (Printf.sprintf "%sfound %i directories" (sign_string com) (List.length dirs));
-			| ChangedDirectories dirs ->
-				print_endline (Printf.sprintf "%schanged directories: [%s]" (sign_string com) (String.concat ", " (List.map (fun (s,_) -> "\"" ^ s ^ "\"") dirs)))
-			| ModulePathChanged(m,time,file) ->
-				print_endline (Printf.sprintf "%smodule path might have changed: %s\n\twas: %2.0f %s\n\tnow: %2.0f %s"
-					(sign_string com) (s_type_path m.m_path) m.m_extra.m_time m.m_extra.m_file time file);
-			| NotCached m -> print_endline (Printf.sprintf "%s%s not cached (%s)" (sign_string com) (s_type_path m.m_path) (if m.m_extra.m_time = -1. then "macro-in-macro" else "modified"));
-			| Parsed(ffile,info) -> print_endline (Printf.sprintf "%sparsed %s (%s)" (sign_string com) ffile info)
-			| RemovedDirectory dir -> print_endline (Printf.sprintf "%sremoved directory %s" (sign_string com) dir);
-			| Reusing m -> print_endline (Printf.sprintf "%s%sreusing %s" (sign_string com) tabs (s_type_path m.m_path));
-			| SkippingDep(m,m') -> print_endline (Printf.sprintf "%sskipping %s%s" (sign_string com) (s_type_path m.m_path) (if m == m' then "" else Printf.sprintf "(%s)" (s_type_path m'.m_path)));
-		)
-	in
 	MacroContext.macro_enable_cache := true;
 	let current_stdin = ref None in
 	TypeloadParse.parse_hook := (fun com2 file p ->
@@ -194,7 +357,7 @@ let rec wait_loop process_params verbose accept =
 						CompilationServer.cache_file cs fkey (ftime,data);
 						"cached",false
 				end in
-				if verbose && is_unusual then process_server_message com2 "" (Parsed(ffile,info));
+				if is_unusual then ServerMessage.parsed com2 "" (ffile,info);
 				data
 	);
 	let check_module_shadowing com paths m =
@@ -203,7 +366,7 @@ let rec wait_loop process_params verbose accept =
 			if Sys.file_exists file then begin
 				let time = file_time file in
 				if time > m.m_extra.m_time then begin
-					if verbose then process_server_message com "" (ModulePathChanged(m,time,file));
+					ServerMessage.module_path_changed com "" (m,time,file);
 					raise Not_found
 				end
 			end
@@ -235,7 +398,7 @@ let rec wait_loop process_params verbose accept =
 							List.iter (fun dir ->
 								if not (CompilationServer.has_directory cs sign dir) then begin
 									let time = stat dir in
-									if verbose then process_server_message com "" (AddedDirectory dir);
+									ServerMessage.added_directory com "" dir;
 									CompilationServer.add_directory cs sign (dir,ref time)
 								end;
 							) sub_dirs;
@@ -244,10 +407,10 @@ let rec wait_loop process_params verbose accept =
 							acc
 					with Unix.Unix_error _ ->
 						CompilationServer.remove_directory cs sign dir;
-						if verbose then process_server_message com "" (RemovedDirectory dir);
+						ServerMessage.removed_directory com "" dir;
 						acc
 				) [] all_dirs in
-				if verbose then process_server_message com "" (ChangedDirectories dirs);
+				ServerMessage.changed_directories com "" dirs;
 				dirs
 			with Not_found ->
 				(* There were no directories in the cache, so this must be a new context. Let's add
@@ -265,7 +428,7 @@ let rec wait_loop process_params verbose accept =
 					in
 					List.iter add_dir com.class_path;
 					List.iter add_dir (Path.find_directories (platform_name com.platform) true com.class_path);
-					if verbose then process_server_message com "" (FoundDirectories !dirs);
+					ServerMessage.found_directories com "" !dirs;
 					CompilationServer.add_directories cs sign !dirs
 				) :: !delays;
 				(* Returning [] should be fine here because it's a new context, so we won't do any
@@ -309,19 +472,19 @@ let rec wait_loop process_params verbose accept =
 					(* if we have a file then this will override our extern type *)
 					let has_file = (try check_module_shadowing com2 directories m; true with Not_found -> false) in
 					if has_file then begin
-						if verbose then print_endline ("A file is masking the library file " ^ s_type_path m.m_path);
+						if verbose then print_endline ("A file is masking the library file " ^ s_type_path m.m_path); (* TODO *)
 						raise Not_found;
 					end;
 					let rec loop = function
 						| [] ->
-							if verbose then print_endline ("No library file was found for " ^ s_type_path m.m_path);
+							if verbose then print_endline ("No library file was found for " ^ s_type_path m.m_path); (* TODO *)
 							raise Not_found (* no extern registration *)
 						| load :: l ->
 							match load m.m_path p with
 							| None -> loop l
 							| Some (file,_) ->
 								if Path.unique_full_path file <> m.m_extra.m_file then begin
-									if verbose then print_endline ("Library file was changed for " ^ s_type_path m.m_path);
+									if verbose then print_endline ("Library file was changed for " ^ s_type_path m.m_path); (* TODO *)
 									raise Not_found;
 								end
 					in
@@ -336,9 +499,9 @@ let rec wait_loop process_params verbose accept =
 			let check_file () =
 				if file_time m.m_extra.m_file <> m.m_extra.m_time then begin
 					if has_policy CheckFileContentModification && not (content_changed m m.m_extra.m_file) then begin
-						if verbose then print_endline (Printf.sprintf "%s%s changed time not but content, reusing" (sign_string com2) m.m_extra.m_file)
+						ServerMessage.unchanged_content com2 "" m.m_extra.m_file;
 					end else begin
-						if verbose then process_server_message com2 "" (NotCached m);
+						ServerMessage.not_cached com2 "" m;
 						if m.m_extra.m_kind = MFake then Hashtbl.remove Typecore.fake_modules m.m_extra.m_file;
 						raise Not_found;
 					end
@@ -380,7 +543,7 @@ let rec wait_loop process_params verbose accept =
 					(* this was just a dependency to check : do not add to the context *)
 					PMap.iter (Hashtbl.replace com2.resources) m.m_extra.m_binded_res;
 				| _ ->
-					if verbose then process_server_message com2 tabs (Reusing m);
+					ServerMessage.reusing com2 tabs m;
 					m.m_extra.m_added <- !compilation_step;
 					List.iter (fun t ->
 						match t with
@@ -412,7 +575,7 @@ let rec wait_loop process_params verbose accept =
 			begin match check m with
 			| None -> ()
 			| Some m' ->
-				if verbose then process_server_message com2 "" (SkippingDep(m,m'));
+				ServerMessage.skipping_dep com2 "" (m,m');
 				tcheck();
 				raise Not_found;
 			end;
@@ -434,7 +597,7 @@ let rec wait_loop process_params verbose accept =
 			if com.display.dms_full_typing then begin
 				was_compilation := true;
 				CompilationServer.cache_context cs com;
-				if verbose then print_endline (Printf.sprintf "%sCached %i modules" (sign_string com) (List.length com.modules));
+				ServerMessage.cached_modules com "" (List.length com.modules);
 			end;
 		in
 		let create params =
@@ -446,7 +609,7 @@ let rec wait_loop process_params verbose accept =
 					(fun msg ->
 						let s = compiler_message_string msg in
 						write (s ^ "\n");
-						if verbose then print_endline ("> " ^ s)
+						ServerMessage.message s;
 					)
 					(List.rev ctx.messages);
 				if ctx.has_error then begin
@@ -456,12 +619,9 @@ let rec wait_loop process_params verbose accept =
 			);
 			ctx.setup <- (fun() ->
 				let sign = Define.get_signature ctx.com.defines in
-				if verbose then begin
-					let defines = PMap.foldi (fun k v acc -> (k ^ "=" ^ v) :: acc) ctx.com.defines.Define.values [] in
-					print_endline ("Defines " ^ (String.concat "," (List.sort compare defines)));
-					print_endline ("Using signature " ^ Digest.to_hex sign);
-					print_endline ("Display position: " ^ (Printer.s_pos !Parser.resume_display));
-				end;
+				ServerMessage.defines ctx.com "";
+				ServerMessage.signature ctx.com "" sign;
+				ServerMessage.display_position ctx.com "" (!Parser.resume_display);
 				Parser.display_error := (fun e p -> has_parse_error := true; ctx.com.error (Parser.error_msg e) p);
 				if ctx.com.display.dms_display then begin
 					let file = (!Parser.resume_display).pfile in
@@ -472,7 +632,7 @@ let rec wait_loop process_params verbose accept =
 				end;
 				try
 					if (Hashtbl.find arguments sign) <> ctx.com.class_path then begin
-						if verbose then print_endline (Printf.sprintf "%sclass paths changed, resetting directories" (sign_string ctx.com));
+						ServerMessage.class_paths_changed ctx.com "";
 						Hashtbl.replace arguments sign ctx.com.class_path;
 						CompilationServer.clear_directories cs sign;
 					end;
@@ -495,9 +655,9 @@ let rec wait_loop process_params verbose accept =
 					s
 			in
 			let data = parse_hxml_data hxml in
-			if verbose then print_endline ("Processing Arguments [" ^ String.concat "," data ^ "]");
+			ServerMessage.arguments data;
 			(try
-				DynArray.clear test_server_messages;
+				DynArray.clear ServerMessage.test_server_messages;
 				Hashtbl.clear changed_directories;
 				Common.display_default := DMNone;
 				Parser.resume_display := null_pos;
@@ -518,26 +678,23 @@ let rec wait_loop process_params verbose accept =
 				if !measure_times then report_times (fun s -> write (s ^ "\n"))
 			with
 			| Completion str ->
-				if verbose then print_endline ("Completion Response =\n" ^ str);
+				ServerMessage.completion str;
 				write str
 			| Arg.Bad msg ->
 				print_endline ("Error: " ^ msg);
 			);
-			if DynArray.length test_server_messages > 0 then begin
-				write (string_of_json (JArray (DynArray.to_list test_server_messages)))
+			if DynArray.length ServerMessage.test_server_messages > 0 then begin
+				write (string_of_json (JArray (DynArray.to_list ServerMessage.test_server_messages)))
 			end;
 			let fl = !delays in
 			delays := [];
 			List.iter (fun f -> f()) fl;
-			if verbose then begin
-				print_endline (Printf.sprintf "Stats = %d files, %d classes, %d methods, %d macros" !(stats.s_files_parsed) !(stats.s_classes_built) !(stats.s_methods_typed) !(stats.s_macros_called));
-				print_endline (Printf.sprintf "Time spent : %.3fs" (get_time() -. t0));
-			end;
+			ServerMessage.stats stats (get_time() -. t0);
 		with Unix.Unix_error _ ->
-			if verbose then print_endline "Connection Aborted"
+			ServerMessage.socket_message "Connection Aborted"
 		| e ->
 			let estr = Printexc.to_string e in
-			if verbose then print_endline ("Uncaught Error : " ^ estr);
+			ServerMessage.uncaught_error estr;
 			(try write estr with _ -> ());
 			if is_debug_run() then print_endline (Printexc.get_backtrace());
 		);
@@ -548,11 +705,7 @@ let rec wait_loop process_params verbose accept =
 		if !run_count mod 10 = 0 then begin
 			let t0 = get_time() in
 			Gc.compact();
-			if verbose then begin
-				let stat = Gc.quick_stat() in
-				let size = (float_of_int stat.Gc.heap_words) *. 4. in
-				print_endline (Printf.sprintf "Compacted memory %.3fs %.1fMB" (get_time() -. t0) (size /. (1024. *. 1024.)));
-			end
+			ServerMessage.gc_stats (get_time() -. t0);
 		end else Gc.minor();
 	done
 
@@ -578,18 +731,18 @@ and init_wait_stdio() =
 		Buffer.clear berr;
 		read, write, close
 
-and init_wait_socket verbose host port =
+and init_wait_socket host port =
 	let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 	(try Unix.setsockopt sock Unix.SO_REUSEADDR true with _ -> ());
 	(try Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_of_string host,port)) with _ -> failwith ("Couldn't wait on " ^ host ^ ":" ^ string_of_int port));
-	if verbose then print_endline ("Waiting on " ^ host ^ ":" ^ string_of_int port);
+	ServerMessage.socket_message ("Waiting on " ^ host ^ ":" ^ string_of_int port);
 	Unix.listen sock 10;
 	let bufsize = 1024 in
 	let tmp = Bytes.create bufsize in
 	let accept() = (
 		let sin, _ = Unix.accept sock in
 		Unix.set_nonblock sin;
-		if verbose then print_endline "Client connected";
+		ServerMessage.socket_message "Client connected";
 		let b = Buffer.create 0 in
 		let rec read_loop count =
 			try
@@ -597,7 +750,7 @@ and init_wait_socket verbose host port =
 				if r = 0 then
 					failwith "Incomplete request"
 				else begin
-					if verbose then Printf.printf "Reading %d bytes\n" r;
+					ServerMessage.socket_message (Printf.sprintf "Reading %d bytes\n" r);
 					Buffer.add_subbytes b tmp 0 r;
 					if Bytes.get tmp (r-1) = '\000' then
 						Buffer.sub b 0 (Buffer.length b - 1)
@@ -608,7 +761,7 @@ and init_wait_socket verbose host port =
 				if count = 100 then
 					failwith "Aborting inactive connection"
 				else begin
-					if verbose then print_endline "Waiting for data...";
+					ServerMessage.socket_message "Waiting for data...";
 					ignore(Unix.select [] [] [] 0.05); (* wait a bit *)
 					read_loop (count + 1);
 				end

src/context/common.ml

@@ -218,6 +218,8 @@ module CompilationServer = struct
 	let runs () =
 		!instance <> None
 
+	let force () = match !instance with None -> assert false | Some i -> i
+
 	let is_initialized cs =
 		cs.initialized = true