[debug] add compiler stage debug

src/compiler/compiler.ml

@@ -276,10 +276,12 @@ let do_type ctx mctx actx =
 	let cs = com.cs in
 	CommonCache.maybe_add_context_sign cs com "before_init_macros";
 	com.stage <- CInitMacrosStart;
+	ServerMessage.compiler_stage com;
 	let (mctx, api) = List.fold_left (fun (mctx,api) path ->
 		(MacroContext.call_init_macro ctx.com mctx api path)
 	) (Option.map (fun (_,mctx) -> mctx) mctx, None) (List.rev actx.config_macros) in
 	com.stage <- CInitMacrosDone;
+	ServerMessage.compiler_stage com;
 	let macros = match mctx with None -> None | Some mctx -> mctx.g.macros in
 	let tctx = Setup.create_typer_context ctx macros actx.native_libs in
 	check_defines ctx.com;
@@ -291,6 +293,7 @@ let do_type ctx mctx actx =
 		Finalization.finalize tctx;
 	) ();
 	com.stage <- CTypingDone;
+	ServerMessage.compiler_stage com;
 	(* 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 com.display.dms_kind with
@@ -304,6 +307,7 @@ let finalize_typing ctx tctx =
 	let t = Timer.timer ["finalize"] in
 	let com = ctx.com in
 	com.stage <- CFilteringStart;
+	ServerMessage.compiler_stage com;
 	let main, types, modules = run_or_diagnose ctx Finalization.generate tctx in
 	com.main <- main;
 	com.types <- types;
@@ -349,11 +353,13 @@ let compile ctx actx callbacks =
 	List.iter (fun f -> f()) (List.rev (actx.pre_compilation));
 	t();
 	com.stage <- CInitialized;
+	ServerMessage.compiler_stage com;
 	if actx.classes = [([],"Std")] && not actx.force_typing then begin
 		if actx.cmds = [] && not actx.did_something then actx.raise_usage();
 	end else begin
 		(* Actual compilation starts here *)
 		com.stage <- CTyperCreated;
+		ServerMessage.compiler_stage com;
 		(* let display_file_dot_path = DisplayProcessing.maybe_load_display_file_before_typing tctx display_file_dot_path in *)
 		let tctx = try
 			do_type ctx mctx actx
@@ -369,8 +375,10 @@ let compile ctx actx callbacks =
 		if ctx.has_error then raise Abort;
 		Generate.check_auxiliary_output com actx;
 		com.stage <- CGenerationStart;
+		ServerMessage.compiler_stage com;
 		if not actx.no_output then Generate.generate ctx tctx ext actx;
 		com.stage <- CGenerationDone;
+		ServerMessage.compiler_stage com;
 	end;
 	Sys.catch_break false;
 	com.callbacks#run com.callbacks#get_after_generation;

src/compiler/serverMessage.ml

@@ -4,6 +4,7 @@ open CompilationCache
 open Type
 
 type server_message_options = {
+	mutable print_compiler_stage : bool;
 	mutable print_added_directory : bool;
 	mutable print_found_directories : bool;
 	mutable print_changed_directories : bool;
@@ -30,6 +31,7 @@ type server_message_options = {
 }
 
 let config = {
+	print_compiler_stage = false;
 	print_added_directory = false;
 	print_found_directories = false;
 	print_changed_directories = false;
@@ -61,6 +63,9 @@ let sign_string com =
 	let	sign_id = (cs#get_context sign)#get_index in
 	Printf.sprintf "%2i,%3s: " sign_id (short_platform_name com.platform)
 
+let compiler_stage com =
+	if config.print_compiler_stage then print_endline (Printf.sprintf "compiler stage: %s" (s_compiler_stage com.stage))
+
 let added_directory com tabs dir =
 	if config.print_added_directory then print_endline (Printf.sprintf "%sadded directory %s" (sign_string com) dir)
 
@@ -156,6 +161,7 @@ let uncaught_error s =
 	if config.print_uncaught_error then print_endline ("Uncaught Error : " ^ s)
 
 let enable_all () =
+	config.print_compiler_stage <- true;
 	config.print_added_directory <- true;
 	config.print_found_directories <- true;
 	config.print_changed_directories <- true;
@@ -180,6 +186,7 @@ let enable_all () =
 	config.print_new_context <- true
 
 let set_by_name name value = match name with
+	| "compilerStage" -> config.print_compiler_stage <- value
 	| "addedDirectory" -> config.print_added_directory <- value
 	| "foundDirectories" -> config.print_found_directories <- value;
 	| "changedDirectories" -> config.print_changed_directories <- value;

src/context/common.ml

@@ -271,6 +271,24 @@ type compiler_stage =
 	| CGenerationStart  (* Generation is about to begin. *)
 	| CGenerationDone   (* Generation just finished. *)
 
+let s_compiler_stage = function
+	| CCreated          -> "CCreated"
+	| CInitialized      -> "CInitialized"
+	| CTyperCreated     -> "CTyperCreated"
+	| CInitMacrosStart  -> "CInitMacrosStart"
+	| CInitMacrosDone   -> "CInitMacrosDone"
+	| CTypingDone       -> "CTypingDone"
+	| CFilteringStart   -> "CFilteringStart"
+	| CAnalyzerStart    -> "CAnalyzerStart"
+	| CAnalyzerDone     -> "CAnalyzerDone"
+	| CSaveStart        -> "CSaveStart"
+	| CSaveDone         -> "CSaveDone"
+	| CDceStart         -> "CDceStart"
+	| CDceDone          -> "CDceDone"
+	| CFilteringDone    -> "CFilteringDone"
+	| CGenerationStart  -> "CGenerationStart"
+	| CGenerationDone   -> "CGenerationDone"
+
 type report_mode =
 	| RMNone
 	| RMDiagnostics of Path.UniqueKey.t list