add dumpConfig.ml (#12150)

src-json/define.json

@@ -112,6 +112,13 @@
 		"doc": "Dump typed AST in dump subdirectory using specified mode or non-prettified default.",
 		"params": ["mode: pretty | record | position | legacy"]
 	},
+	{
+		"name": "DumpStage",
+		"define": "dump.stage",
+		"doc": "The compiler stage after which to generate the dump",
+		"params": ["stage: typing | casting | inlining | analyzing | dce"],
+		"default": "dce"
+	},
 	{
 		"name": "DumpPath",
 		"define": "dump-path",

src/codegen/dump.ml

@@ -1,10 +1,8 @@
 open Globals
 open Common
+open DumpConfig
 open Type
 
-let dump_path defines =
-	Define.defined_value_safe ~default:"dump" defines Define.DumpPath
-
 (*
 	Make a dump of the full typed AST of all types
 *)
@@ -16,21 +14,20 @@ let create_dumpfile acc l =
 		close_out ch)
 
 let create_dumpfile_from_path com path =
-	let buf,close = create_dumpfile [] ((dump_path com.defines) :: (platform_name_macro com) :: fst path @ [snd path]) in
+	let buf,close = create_dumpfile [] (com.dump_config.dump_path :: (string_of_dump_stage com.dump_config.dump_stage) :: (platform_name_macro com) :: fst path @ [snd path]) in
 	buf,close
 
 let dump_types com pretty =
-	let print_ids = not (Common.defined com Define.DumpIgnoreVarIds) in
 	let restore =
 		if not pretty then
 			let old = !TPrinting.MonomorphPrinting.show_mono_ids in
-			TPrinting.MonomorphPrinting.show_mono_ids := print_ids;
+			TPrinting.MonomorphPrinting.show_mono_ids := com.dump_config.dump_print_ids;
 			fun () -> TPrinting.MonomorphPrinting.show_mono_ids := old
 		else fun () -> ()
 	in
 	let s_type = s_type (Type.print_context()) in
 	let s_expr,s_type_param = if not pretty then
-		(Type.s_expr_ast print_ids "\t"),(Printer.s_type_param "")
+		(Type.s_expr_ast com.dump_config.dump_print_ids "\t"),(Printer.s_type_param "")
 	else
 		(Type.s_expr_pretty false "\t" true),(s_type_param s_type)
 	in
@@ -177,18 +174,19 @@ let dump_position com =
 	)
 
 let dump_types com =
-	match Common.defined_value_safe com Define.Dump with
-		| "pretty" -> dump_types com true
-		| "record" -> dump_record com
-		| "position" -> dump_position com
-		| _ -> dump_types com false
+	match com.dump_config.dump_mode with
+		| NoDump -> ()
+		| Pretty -> dump_types com true
+		| Record -> dump_record com
+		| Position -> dump_position com
+		| Ast -> dump_types com false
 
 let dump_dependencies ?(target_override=None) com =
 	let target_name = match target_override with
 		| None -> platform_name_macro com
 		| Some s -> s
 	in
-	let dump_dependencies_path = [dump_path com.defines;target_name;"dependencies"] in
+	let dump_dependencies_path = [com.dump_config.dump_path;target_name;"dependencies"] in
 	let buf,close = create_dumpfile [] dump_dependencies_path in
 	let print fmt = Printf.kprintf (fun s -> Buffer.add_string buf s) fmt in
 	let dep = Hashtbl.create 0 in
@@ -211,7 +209,7 @@ let dump_dependencies ?(target_override=None) com =
 		) m.m_extra.m_deps;
 	) com.Common.modules;
 	close();
-	let dump_dependants_path = [dump_path com.defines;target_name;"dependants"] in
+	let dump_dependants_path = [com.dump_config.dump_path;target_name;"dependants"] in
 	let buf,close = create_dumpfile [] dump_dependants_path in
 	let print fmt = Printf.kprintf (fun s -> Buffer.add_string buf s) fmt in
 	Hashtbl.iter (fun n ml ->
@@ -220,4 +218,12 @@ let dump_dependencies ?(target_override=None) com =
 			print "\t%s\n" (Path.UniqueKey.lazy_path m.m_extra.m_file);
 		) ml;
 	) dep;
-	close()
+	close()
+
+let maybe_generate_dump com stage =
+	if com.Common.dump_config.dump_mode <> NoDump && com.dump_config.dump_stage = stage then begin
+		Timer.time com.timer_ctx ["generate";"dump"] (fun () ->
+			dump_types com;
+			Option.may dump_types (com.get_macros());
+		) ();
+	end

src/compiler/compiler.ml

@@ -307,6 +307,7 @@ let do_type ctx mctx actx display_file_dot_path =
 	let tctx = Setup.create_typer_context ctx macros in
 	let display_file_dot_path = DisplayProcessing.maybe_load_display_file_before_typing tctx display_file_dot_path in
 	check_defines ctx.com;
+	DumpConfig.update_from_defines com.dump_config com.defines;
 	CommonCache.lock_signature com "after_init_macros";
 	Option.may (fun mctx -> MacroContext.finalize_macro_api tctx mctx) mctx;
 	(try begin
@@ -393,6 +394,7 @@ let compile ctx actx callbacks =
 		DisplayProcessing.handle_display_after_typing ctx tctx display_file_dot_path;
 		let ectx = ExceptionInit.create_exception_context tctx in
 		finalize_typing ctx tctx;
+		Dump.maybe_generate_dump ctx.com AfterTyping;
 		let is_compilation = is_compilation com in
 		com.callbacks#add_after_save (fun () ->
 			callbacks.after_save ctx;
@@ -412,7 +414,8 @@ let compile ctx actx callbacks =
 		if is_compilation then Generate.check_auxiliary_output com actx;
 		enter_stage com CGenerationStart;
 		ServerMessage.compiler_stage com;
-		Generate.maybe_generate_dump ctx tctx;
+		Dump.maybe_generate_dump ctx.com AfterDce;
+		Generate.maybe_generate_dump_dependencies ctx tctx;
 		if not actx.no_output then Generate.generate ctx tctx ext actx;
 		enter_stage com CGenerationDone;
 		ServerMessage.compiler_stage com;

src/compiler/generate.ml

@@ -128,15 +128,9 @@ let parse_swf_header ctx h = match ExtString.String.nsplit h ":" with
 
 let delete_file f = try Sys.remove f with _ -> ()
 
-let maybe_generate_dump ctx tctx =
+let maybe_generate_dump_dependencies ctx tctx =
 	let com = tctx.Typecore.com in
-	if Common.defined com Define.Dump then begin
-		Timer.time ctx.timer_ctx ["generate";"dump"] (fun () ->
-			Dump.dump_types com;
-			Option.may Dump.dump_types (com.get_macros());
-		) ();
-	end;
-	if Common.defined com Define.DumpDependencies then begin
+	if com.dump_config.dump_dependencies then begin
 		Dump.dump_dependencies com;
 		if not com.is_macro_context then match tctx.Typecore.g.Typecore.macros with
 			| None -> ()

src/context/common.ml

@@ -258,6 +258,7 @@ type context = {
 	mutable package_rules : (string,package_rule) PMap.t;
 	mutable report_mode : report_mode;
 	parser_state : parser_state;
+	dump_config : DumpConfig.t;
 	(* communication *)
 	mutable print : string -> unit;
 	mutable error : Gctx.error_function;
@@ -784,7 +785,8 @@ let create timer_ctx compilation_step cs version args display_mode =
 			had_parser_resume = false;
 			delayed_syntax_completion = Atomic.make None;
 			special_identifier_files = ThreadSafeHashtbl.create 0;
-		}
+		};
+		dump_config = DumpConfig.create_default ();
 	} in
 	com
 

src/context/dumpConfig.ml

@@ -0,0 +1,60 @@
+type dump_mode =
+	| NoDump
+	| Ast
+	| Pretty
+	| Record
+	| Position
+
+
+type dump_stage =
+	| AfterTyping
+	| AfterCasting
+	| AfterInlining
+	| AfterAnalyzing
+	| AfterSanitizing
+	| AfterDce
+
+type t = {
+	mutable dump_mode : dump_mode;
+	mutable dump_path : string;
+	mutable dump_stage : dump_stage;
+	mutable dump_print_ids : bool;
+	mutable dump_dependencies : bool;
+}
+
+let create_default () = {
+	dump_mode = NoDump;
+	dump_path = "dump";
+	dump_stage = AfterDce;
+	dump_print_ids = false;
+	dump_dependencies = false;
+}
+
+let update_from_defines conf def =
+	conf.dump_mode <- begin match Define.defined_value_safe def Dump with
+		| "1" -> Ast
+		| "pretty" -> Pretty
+		| "record" -> Record
+		| "position" -> Position
+		| _ -> NoDump
+	end;
+	conf.dump_path <- Define.defined_value_safe ~default:"dump" def DumpPath;
+	conf.dump_stage <- begin match Define.defined_value_safe def DumpStage with
+		| "typing" -> AfterTyping
+		| "casting" -> AfterCasting
+		| "inlining" -> AfterInlining
+		| "analyzing" -> AfterAnalyzing
+		| "sanitizing" -> AfterSanitizing
+		| "dce" -> AfterDce
+		| _ -> AfterDce
+	end;
+	conf.dump_print_ids <- not (Define.defined def Define.DumpIgnoreVarIds);
+	conf.dump_dependencies <- Define.defined def Define.DumpDependencies
+
+let string_of_dump_stage = function
+	| AfterTyping -> "AfterTyping"
+	| AfterCasting -> "AfterCasting"
+	| AfterInlining -> "AfterInlining"
+	| AfterAnalyzing -> "AfterAnalyzing"
+	| AfterSanitizing -> "AfterSanitizing"
+	| AfterDce -> "AfterDce"

src/context/safeCom.ml

@@ -19,6 +19,7 @@ type t = {
 	is_macro_context : bool;
 	foptimize : bool;
 	doinline : bool;
+	dump_config : DumpConfig.t;
 	exceptions : exn list ref;
 	exceptions_mutex : Mutex.t;
 	warnings : saved_warning list ref;
@@ -41,6 +42,7 @@ let of_com (com : Common.context) = {
 	is_macro_context = com.is_macro_context;
 	foptimize = com.foptimize;
 	doinline = com.doinline;
+	dump_config = com.dump_config;
 	exceptions = ref [];
 	exceptions_mutex = Mutex.create ();
 	warnings = ref [];

src/filters/filters.ml

@@ -417,7 +417,7 @@ let might_need_cf_unoptimized c cf =
 	| _ ->
 		has_class_field_flag cf CfGeneric
 
-let run_safe_filters ectx (scom : SafeCom.t) new_types_array cv_wrapper_impl rename_locals_config pool =
+let run_safe_filters ectx com (scom : SafeCom.t) new_types_array cv_wrapper_impl rename_locals_config pool =
 	let detail_times = Timer.level_from_define scom.defines Define.FilterTimes in
 
 	let filters_before_inlining = [
@@ -448,12 +448,18 @@ let run_safe_filters ectx (scom : SafeCom.t) new_types_array cv_wrapper_impl ren
 	] in
 
 	Parallel.ParallelArray.iter pool (SafeCom.run_expression_filters_safe scom detail_times filters_before_inlining) new_types_array;
+	Dump.maybe_generate_dump com AfterCasting;
+
 	Parallel.ParallelArray.iter pool (SafeCom.run_expression_filters_safe scom detail_times filters_before_analyzer) new_types_array;
+	Dump.maybe_generate_dump com AfterInlining;
 
-	(* enter_stage com CAnalyzerStart; *)
+	Common.enter_stage com CAnalyzerStart;
 	if scom.platform <> Cross then Analyzer.Run.run_on_types scom pool new_types_array;
-	(* enter_stage com CAnalyzerDone; *)
-	Parallel.ParallelArray.iter pool (SafeCom.run_expression_filters_safe scom detail_times filters_after_analyzer) new_types_array
+	Dump.maybe_generate_dump com AfterAnalyzing;
+	Common.enter_stage com CAnalyzerDone;
+
+	Parallel.ParallelArray.iter pool (SafeCom.run_expression_filters_safe scom detail_times filters_after_analyzer) new_types_array;
+	Dump.maybe_generate_dump com AfterSanitizing
 
 let run com ectx main before_destruction =
 	let scom = SafeCom.of_com com in
@@ -500,7 +506,7 @@ let run com ectx main before_destruction =
 	let rename_locals_config = RenameVars.init scom.SafeCom.platform_config com.types in
 	Parallel.run_in_new_pool scom.timer_ctx (fun pool ->
 		SafeCom.run_with_scom com scom (fun () ->
-			run_safe_filters ectx scom new_types_array cv_wrapper_impl rename_locals_config pool
+			run_safe_filters ectx com scom new_types_array cv_wrapper_impl rename_locals_config pool
 		)
 	);
 	with_timer com.timer_ctx detail_times "callbacks" None (fun () ->

src/optimization/analyzer.ml

@@ -875,7 +875,7 @@ module Debug = struct
 		else platform_name com.platform
 
 	let get_dump_path ctx c cf =
-		(Dump.dump_path ctx.com.defines) :: [platform_name_macro ctx.com] @ (fst c.cl_path) @ [Printf.sprintf "%s.%s" (snd c.cl_path) cf.cf_name]
+		(ctx.com.dump_config.DumpConfig.dump_path) :: [platform_name_macro ctx.com] @ (fst c.cl_path) @ [Printf.sprintf "%s.%s" (snd c.cl_path) cf.cf_name]
 
 	let dot_debug ctx c cf =
 		let g = ctx.graph in

src/typing/macroContext.ml

@@ -41,7 +41,7 @@ let macro_interp_cache = ref None
 
 let safe_decode com v expected t p f =
 	let raise_decode_error s =
-		let path = [Dump.dump_path com.defines;"decoding_error"] in
+		let path = [com.dump_config.DumpConfig.dump_path;"decoding_error"] in
 		let ch = Path.create_file false ".txt" [] path  in
 		Printf.fprintf ch "%s: %s\n" (TPrinting.Printer.s_pos p) s;
 		let errors = Interp.handle_decoding_error (output_string ch) v t in