Sort out server module marks (#10640)

* [server] sort out module marks

* [server] give a new compilation step to each context

* [server] this part was actually correct

src/compiler/compilationContext.ml

@@ -46,6 +46,7 @@ type server_accept = unit -> (bool * (bool -> string option) * (string -> unit)
 
 type server_api = {
 	cache : CompilationCache.t;
+	on_context_create : unit -> int;
 	before_anything : compilation_context -> unit;
 	after_arg_parsing : compilation_context -> unit;
 	after_compilation : compilation_context -> unit;

src/compiler/compiler.ml

@@ -764,8 +764,8 @@ let compile_ctx server_api comm ctx =
 			error ctx ("Error: " ^ msg) null_pos;
 			false
 
-let create_context comm cs params = {
-	com = Common.create cs version params;
+let create_context compilation_step comm cs params = {
+	com = Common.create compilation_step cs version params;
 	on_exit = [];
 	messages = [];
 	has_next = false;
@@ -826,7 +826,7 @@ module HighLevel = struct
 		DynArray.to_list compilations
 
 	let entry server_api comm args =
-		let create = create_context comm server_api.cache in
+		let create = create_context (server_api.on_context_create()) comm server_api.cache in
 		let ctxs = try
 			process_params server_api create args
 		with Arg.Bad msg ->

src/compiler/server.ml

@@ -103,12 +103,8 @@ module ServerCompilationContext = struct
 		cs : CompilationCache.t;
 		(* A list of class paths per-signature *)
 		class_paths : (Digest.t,string list) Hashtbl.t;
-		(* Increased for each typed module *)
-		mutable mark_loop : int;
 		(* Increased for each compilation *)
 		mutable compilation_step : int;
-		(* The [mark_loop] value at which we started the current compilation *)
-		mutable compilation_mark : int;
 		(* A list of delays which are run after compilation *)
 		mutable delays : (unit -> unit) list;
 		(* True if it's an actual compilation, false if it's a display operation *)
@@ -123,8 +119,6 @@ module ServerCompilationContext = struct
 		class_paths = Hashtbl.create 0;
 		changed_directories = Hashtbl.create 0;
 		compilation_step = 0;
-		compilation_mark = 0;
-		mark_loop = 0;
 		delays = [];
 		was_compilation = false;
 		macro_context_setup = false;
@@ -152,8 +146,6 @@ module ServerCompilationContext = struct
 		stats.s_methods_typed := 0;
 		stats.s_macros_called := 0;
 		Hashtbl.clear Timer.htimers;
-		sctx.compilation_step <- sctx.compilation_step + 1;
-		sctx.compilation_mark <- sctx.mark_loop;
 		Helper.start_time := get_time()
 
 	let maybe_cache_context sctx com =
@@ -207,8 +199,6 @@ module Communication = struct
 			write s
 		);
 		flush = (fun ctx ->
-			sctx.compilation_step <- sctx.compilation_step + 1;
-			sctx.compilation_mark <- sctx.mark_loop;
 			check_display_flush ctx (fun () ->
 				List.iter
 					(fun msg ->
@@ -325,8 +315,7 @@ let check_module sctx ctx m p =
 			end
 		) paths
 	in
-	let mark = sctx.mark_loop in
-	let start_mark = sctx.compilation_mark in
+	let start_mark = sctx.compilation_step in
 	let rec check m =
 		let check_module_path () =
 			let directories = get_changed_directories sctx ctx in
@@ -390,26 +379,34 @@ let check_module sctx ctx m p =
 				| Some _ -> raise (Dirty (DependencyDirty m2.m_path))
 			) m.m_extra.m_deps;
 		in
-		begin match m.m_extra.m_dirty with
-		| Some path ->
-			Some path
-		| None ->
-			if m.m_extra.m_mark = mark then
-				None
-			else try
-				let old_mark = m.m_extra.m_mark in
-				m.m_extra.m_mark <- mark;
-				if old_mark <= start_mark then begin
-					if not (has_policy NoCheckShadowing) then check_module_path();
-					if not (has_policy NoCheckFileTimeModification) || file_extension (Path.UniqueKey.lazy_path m.m_extra.m_file) <> "hx" then check_file();
-				end;
+		let check () =
+			try
+				if not (has_policy NoCheckShadowing) then check_module_path();
+				if not (has_policy NoCheckFileTimeModification) || file_extension (Path.UniqueKey.lazy_path m.m_extra.m_file) <> "hx" then check_file();
 				if not (has_policy NoCheckDependencies) then check_dependencies();
 				None
 			with
 			| Dirty reason ->
-				m.m_extra.m_dirty <- Some reason;
 				Some reason
-			end
+		in
+		(* If the module mark matches our compilation mark, we are done *)
+		if m.m_extra.m_checked = start_mark then
+			m.m_extra.m_dirty
+		else begin
+			(* Otherwise, set to current compilation mark for recursion *)
+			m.m_extra.m_checked <- start_mark;
+			let dirty = match m.m_extra.m_dirty with
+				| Some _ as dirty ->
+					(* If we are already dirty, stick to it. *)
+					dirty
+				| None ->
+					(* Otherwise, run the checks *)
+					check ()
+			in
+			(* Update the module now. It will use this dirty status for the remainder of this compilation. *)
+			m.m_extra.m_dirty <- dirty;
+			dirty
+		end
 	in
 	check m
 
@@ -424,8 +421,8 @@ let add_modules sctx ctx m p =
 				(* this was just a dependency to check : do not add to the context *)
 				PMap.iter (Hashtbl.replace com.resources) m.m_extra.m_binded_res;
 			| _ ->
-				ServerMessage.reusing com tabs m;
 				m.m_extra.m_added <- sctx.compilation_step;
+				ServerMessage.reusing com tabs m;
 				List.iter (fun t ->
 					match t with
 					| TClassDecl c -> c.cl_restore()
@@ -456,7 +453,6 @@ let type_module sctx (ctx:Typecore.typer) mpath p =
 	let t = Timer.timer ["server";"module cache"] in
 	let com = ctx.Typecore.com in
 	let cc = CommonCache.get_cache com in
-	sctx.mark_loop <- sctx.mark_loop + 1;
 	try
 		let m = cc#find_module mpath in
 		let tcheck = Timer.timer ["server";"module cache";"check"] in
@@ -624,11 +620,21 @@ let do_connect host port args =
 	process();
 	if !has_error then exit 1
 
+let enable_cache_mode sctx =
+	TypeloadModule.type_module_hook := type_module sctx;
+	MacroContext.macro_enable_cache := true;
+	ServerCompilationContext.ensure_macro_setup sctx;
+	TypeloadParse.parse_hook := parse_file sctx.cs
+
 let rec process sctx comm args =
 	let t0 = get_time() in
 	ServerMessage.arguments args;
 	reset sctx;
 	let api = {
+		on_context_create = (fun () ->
+			sctx.compilation_step <- sctx.compilation_step + 1;
+			sctx.compilation_step;
+		);
 		cache = sctx.cs;
 		before_anything = before_anything sctx;
 		after_arg_parsing = after_arg_parsing sctx;
@@ -651,10 +657,7 @@ and wait_loop verbose accept =
 	(* Create server context and set up hooks for parsing and typing *)
 	let sctx = ServerCompilationContext.create verbose in
 	let cs = sctx.cs in
-	TypeloadModule.type_module_hook := type_module sctx;
-	MacroContext.macro_enable_cache := true;
-	ServerCompilationContext.ensure_macro_setup sctx;
-	TypeloadParse.parse_hook := parse_file cs;
+	enable_cache_mode sctx;
 	let ring = Ring.create 10 0. in
 	let gc_heap_stats () =
 		let stats = Gc.quick_stat() in

src/context/common.ml

@@ -292,6 +292,7 @@ type report_mode =
 	| RMStatistics
 
 type context = {
+	compilation_step : int;
 	mutable stage : compiler_stage;
 	mutable cache : CompilationCache.context_cache option;
 	(* config *)
@@ -706,9 +707,10 @@ let get_config com =
 
 let memory_marker = [|Unix.time()|]
 
-let create cs version args =
+let create compilation_step cs version args =
 	let m = Type.mk_mono() in
 	{
+		compilation_step = compilation_step;
 		cs = cs;
 		cache = None;
 		stage = CCreated;

src/core/tFunctions.ml

@@ -160,7 +160,7 @@ let module_extra file sign time kind policy =
 		};
 		m_dirty = None;
 		m_added = 0;
-		m_mark = 0;
+		m_checked = 0;
 		m_time = time;
 		m_processed = 0;
 		m_deps = PMap.empty;

src/core/tPrinting.ml

@@ -646,7 +646,7 @@ module Printer = struct
 			"m_time",string_of_float me.m_time;
 			"m_dirty",s_opt s_module_skip_reason me.m_dirty;
 			"m_added",string_of_int me.m_added;
-			"m_mark",string_of_int me.m_mark;
+			"m_checked",string_of_int me.m_checked;
 			"m_deps",s_pmap string_of_int (fun m -> snd m.m_path) me.m_deps;
 			"m_processed",string_of_int me.m_processed;
 			"m_kind",s_module_kind me.m_kind;

src/core/tType.ml

@@ -365,9 +365,9 @@ and module_def_extra = {
 	mutable m_time : float;
 	mutable m_dirty : module_skip_reason option;
 	mutable m_added : int;
-	mutable m_mark : int;
-	mutable m_deps : (int,module_def) PMap.t;
+	mutable m_checked : int;
 	mutable m_processed : int;
+	mutable m_deps : (int,module_def) PMap.t;
 	mutable m_kind : module_kind;
 	mutable m_binded_res : (string, string) PMap.t;
 	mutable m_if_feature : (string *(tclass * tclass_field * bool)) list;

src/filters/filters.ml

@@ -717,18 +717,13 @@ let check_reserved_type_paths ctx t =
 
 (* PASS 3 end *)
 
-let pp_counter = ref 1
-
-let is_cached t =
+let is_cached com t =
 	let m = (t_infos t).mt_module.m_extra in
-	if m.m_processed = 0 then m.m_processed <- !pp_counter;
-	m.m_processed <> !pp_counter
+	if m.m_processed = 0 then m.m_processed <- com.compilation_step;
+	m.m_processed <> com.compilation_step
 
 let apply_filters_once ctx filters t =
-	if not (is_cached t) then run_expression_filters None ctx filters t
-
-let next_compilation() =
-	incr pp_counter
+	if not (is_cached ctx.com t) then run_expression_filters None ctx filters t
 
 let iter_expressions fl mt =
 	match mt with
@@ -773,7 +768,7 @@ end
 let run com tctx main =
 	let detail_times = Common.defined com DefineList.FilterTimes in
 	let new_types = List.filter (fun t ->
-		let cached = is_cached t in
+		let cached = is_cached com t in
 		begin match t with
 			| TClassDecl cls ->
 				List.iter (fun (iface,_) -> add_descendant iface cls) cls.cl_implements;
@@ -856,7 +851,6 @@ let run com tctx main =
 		"mark_switch_break_loops",mark_switch_break_loops;
 	] in
 	List.iter (run_expression_filters (timer_label detail_times ["expr 2"]) tctx filters) new_types;
-	next_compilation();
 	let t = filter_timer detail_times ["callbacks"] in
 	List.iter (fun f -> f()) (List.rev com.callbacks#get_before_save); (* macros onGenerate etc. *)
 	t();

src/typing/macroContext.ml

@@ -484,8 +484,7 @@ and flush_macro_context mint ctx =
 	in
 	(try Interp.add_types mint types ready
 	with Error (e,p) -> t(); raise (Fatal_error(error_msg e,p)));
-	t();
-	Filters.next_compilation()
+	t()
 
 let create_macro_interp ctx mctx =
 	let com2 = mctx.com in