[server] Add define to see what modules trigger most invalidation

src-json/define.json

@@ -111,6 +111,12 @@
 		"define": "dump-dependencies",
 		"doc": "Dump the classes dependencies in a dump subdirectory."
 	},
+	{
+		"name": "DumpInvalidationStats",
+		"define": "dump-invalidation-stats",
+		"params": ["depth"],
+		"doc": "Dump some module invalidation stats in a dump subdirectory"
+	},
 	{
 		"name": "DumpIgnoreVarIds",
 		"define": "dump-ignore-var-ids",

src/codegen/codegen.ml

@@ -407,6 +407,67 @@ module Dump = struct
 			) ml;
 		) dep;
 		close()
+
+	type invalidation_stats_entry = {
+		inv_path : Globals.path;
+		inv_direct : int;
+		inv_total : int;
+		inv_children : invalidation_stats_entry list;
+	}
+
+	let dump_invalidation_stats com =
+		let max_depth = int_of_string (Define.defined_value_safe ~default:"0" com.defines DumpInvalidationStats) in
+
+		let rec loop stats l depth max_len =
+			if depth <= max_depth then begin
+				List.fold_left (fun (acc,total,max_len) path ->
+					match Hashtbl.find_opt stats path with
+					| None ->
+						(acc, total, max_len)
+					| Some l ->
+						let (children,sub,new_max_len) = loop stats l (depth + 1) max_len in
+						(* Only consider data with something interesting *)
+						if sub > List.length l then begin
+							let new_max_len = max new_max_len (String.length (s_type_path path) + depth * 2) in
+							let entry = { inv_path = path; inv_direct = List.length l; inv_total = sub; inv_children = children } in
+							(entry :: acc, total + sub, new_max_len)
+						end else
+							(acc, total + sub, max_len)
+				) ([], List.length l, max_len) l
+			end else
+				([], List.length l, max_len)
+		in
+
+		let cc = CommonCache.get_cache com in
+		let target_name = platform_name_macro com in
+		let dump_stats_path = [dump_path com;target_name;"invalidation_stats"] in
+
+		let stats = cc#get_invalidation_stats in
+		let l = Hashtbl.fold (fun p _ l -> p :: l) stats [] in
+		let (entries, total, max_len) = loop stats l 0 0 in
+
+		let buf,close = create_dumpfile [] dump_stats_path in
+		if total > 0 then begin
+			let rec loop l depth =
+				let l = List.sort (fun a b -> b.inv_total - a.inv_total) l in
+
+				let pad = String.make (depth * 2) ' ' in
+				List.iter (fun e ->
+					let spath = pad ^ s_type_path e.inv_path in
+					let rpad = max_len + 2 - String.length spath in
+					let spath = if rpad > 0 then spath ^ String.make rpad ' ' else spath in
+					Buffer.add_string buf (Printf.sprintf "%s | %6i | %6i |\n" spath e.inv_direct e.inv_total);
+					loop e.inv_children (depth + 1)
+				) l
+			in
+
+			let rpad = max_len + 2 - String.length "module" in
+			let header = "module" ^ (String.make rpad ' ') ^ " | direct |  total |" in
+			Buffer.add_string buf (header ^ "\n");
+			Buffer.add_string buf (String.make (String.length header) '-' ^ "\n");
+			loop entries 0;
+		end;
+		close();
 end
 
 (*

src/compiler/compilationCache.ml

@@ -35,6 +35,7 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 	val files : (Path.UniqueKey.t,cached_file) Hashtbl.t = Hashtbl.create 0
 	val modules : (path,module_def) Hashtbl.t = Hashtbl.create 0
 	val binary_cache : (path,HxbData.module_cache) Hashtbl.t = Hashtbl.create 0
+	val invalidation_stats : (path,path list) Hashtbl.t = Hashtbl.create 0
 	val removed_files = Hashtbl.create 0
 	val mutable json = JNull
 	val mutable initialized = false
@@ -96,6 +97,7 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 	method get_index = index
 	method get_files = files
 	method get_modules = modules
+	method get_invalidation_stats = invalidation_stats
 
 	method get_hxb = binary_cache
 	method get_hxb_module path = Hashtbl.find binary_cache path

src/compiler/compiler.ml

@@ -398,7 +398,7 @@ 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;
+		Generate.maybe_generate_dump 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

@@ -104,7 +104,7 @@ 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 tctx =
 	let com = tctx.Typecore.com in
 	if Common.defined com Define.Dump then begin
 		Codegen.Dump.dump_types com;
@@ -117,6 +117,12 @@ let maybe_generate_dump ctx tctx =
 			| Some(_,ctx) -> Codegen.Dump.dump_dependencies ~target_override:(Some "macro") ctx.Typecore.com
 	end
 
+let maybe_generate_stats_dump com =
+	if Common.defined com Define.DumpInvalidationStats then begin
+		Codegen.Dump.dump_invalidation_stats com;
+		Option.may Codegen.Dump.dump_invalidation_stats (com.get_macros())
+	end
+
 let generate ctx tctx ext actx =
 	let com = tctx.Typecore.com in
 	(* check file extension. In case of wrong commandline, we don't want

src/compiler/server.ml

@@ -318,9 +318,21 @@ let check_module sctx com m_path m_extra p =
 				with Not_found ->
 					die (Printf.sprintf "Could not find dependency %s of %s in the cache" (s_type_path mpath) (s_type_path m_path)) __LOC__;
 				in
-				match check mpath m2_extra with
+				(match check mpath m2_extra with
 				| None -> ()
-				| Some reason -> raise (Dirty (DependencyDirty(mpath,reason)))
+				| Some reason ->
+					if Define.defined com.defines DumpInvalidationStats then begin
+						let invalidation_stats = (com.cs#get_context sign)#get_invalidation_stats in
+						let value = match Hashtbl.find_opt invalidation_stats mpath with
+							| None -> [m_path]
+							| Some l ->
+								Hashtbl.remove invalidation_stats mpath;
+								m_path :: l
+						in
+						Hashtbl.add invalidation_stats mpath value;
+					end;
+
+					raise (Dirty (DependencyDirty(mpath,reason))))
 			) m_extra.m_deps;
 		in
 		let check () =
@@ -628,7 +640,7 @@ let after_save sctx ctx =
 		maybe_cache_context sctx ctx.com
 
 let after_compilation sctx ctx =
-	()
+	Generate.maybe_generate_stats_dump ctx.com
 
 let mk_length_prefixed_communication allow_nonblock chin chout =
 	let sin = Unix.descr_of_in_channel chin in

src/core/define.ml

@@ -154,7 +154,7 @@ let get_signature def =
 			*)
 			| "display" | "use_rtti_doc" | "macro_times" | "display_details" | "no_copt" | "display_stdin" | "hxb.stats"
 			| "message.reporting" | "message.log_file" | "message.log_format" | "message.no_color"
-			| "dump" | "dump_dependencies" | "dump_ignore_var_ids" -> acc
+			| "dump" | "dump_dependencies" | "dump_ignore_var_ids" | "dump_invalidation_stats" -> acc
 			| _ -> (k ^ "=" ^ v) :: acc
 		) def.values [] in
 		let str = String.concat "@" (List.sort compare defines) in