Add -D dump-invalidation-stats

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,77 @@ 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 ->
+					let max_len = max max_len (String.length (s_type_path path) + depth * 2) in
+					match Hashtbl.find_opt stats path with
+					| None ->
+						let entry = { inv_path = path; inv_direct = 0; inv_total = 0; inv_children = []} in
+						(entry :: acc, total, max_len)
+					| Some l ->
+						let (children,sub,max_len) = loop stats l (depth + 1) max_len in
+						let entry = { inv_path = path; inv_direct = List.length l; inv_total = sub; inv_children = children } in
+						(entry :: acc, total + sub, max_len)
+				) ([], List.length l, max_len) l
+			end else
+				(List.map (fun p -> { inv_path = p; inv_direct = 0; inv_total = 0; inv_children = [] }) l, List.length l, max_len)
+		in
+
+		let dump_stats com =
+			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
+
+			if total > 0 then begin
+				let buf,close = create_dumpfile [] dump_stats_path in
+				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 ->
+						(* TODO: this might be too much hiding.. *)
+						if e.inv_total > e.inv_direct then begin
+							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);
+
+							(* Only display children if something interesting is in there *)
+							(* TODO: sometimes we might want to display those? *)
+							(* if e.inv_total > e.inv_direct then *)
+								loop e.inv_children (depth + 1)
+						end
+					) 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;
+				close();
+			end
+		in
+
+		dump_stats com;
+		Option.may dump_stats (com.get_macros())
+
 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/generate.ml

@@ -115,7 +115,9 @@ let maybe_generate_dump ctx tctx =
 		if not com.is_macro_context then match tctx.Typecore.g.Typecore.macros with
 			| None -> ()
 			| Some(_,ctx) -> Codegen.Dump.dump_dependencies ~target_override:(Some "macro") ctx.Typecore.com
-	end
+	end;
+	if Common.defined ctx.com Define.DumpInvalidationStats then
+		Codegen.Dump.dump_invalidation_stats com
 
 let generate ctx tctx ext actx =
 	let com = tctx.Typecore.com in

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 () =