[hxb] load less things during display requests

Note that this still loads a lot of dependencies that are not really
needed for display requests, but those are harder to skip without
breaking everything.

src/compiler/hxb/hxbReader.ml

@@ -4,6 +4,8 @@ open Type
 open HxbData
 open HxbReaderApi
 
+exception IgnoredModule
+
 type field_reader_context = {
 	t_pool : Type.t Array.t;
 	pos : pos ref;
@@ -153,6 +155,7 @@ class hxb_reader
 = object(self)
 	val mutable api = Obj.magic ""
 	val mutable current_module = null_module
+	val mutable sig_only = false
 
 	val mutable ch = BytesWithPosition.create (Bytes.create 0)
 	val mutable has_string_pool = (string_pool <> None)
@@ -176,9 +179,23 @@ class hxb_reader
 	val mutable field_type_parameter_offset = 0
 	val empty_anon = mk_anon (ref Closed)
 
+	method is_sig_dep (sig_deps : (int,module_dep) PMap.t option) (path : path) = match sig_deps with
+		| None ->
+			true
+		| Some deps ->
+			PMap.fold (fun md found -> found || md.md_path = path) deps false
+
+	method is_module_ignored path =
+		sig_only
+		&& current_module.m_path <> path
+		&& not (self#is_sig_dep current_module.m_extra.m_sig_deps path)
+
 	method resolve_type pack mname tname =
 		try
-			api#resolve_type pack mname tname
+			if self#is_module_ignored (pack,mname) then
+				raise IgnoredModule
+			else
+				api#resolve_type pack mname tname
 		with Not_found ->
 			dump_backtrace();
 			error (Printf.sprintf "[HXB] [%s] Cannot resolve type %s" (s_type_path current_module.m_path) (s_type_path ((pack @ [mname]),tname)))
@@ -1787,51 +1804,56 @@ class hxb_reader
 		let l = read_uleb128 ch in
 		classes <- (Array.init l (fun i ->
 				let (pack,mname,tname) = self#read_full_path in
-				match self#resolve_type pack mname tname with
-				| TClassDecl c ->
-					c
-				| _ ->
-					error ("Unexpected type where class was expected: " ^ (s_type_path (pack,tname)))
+				try (match self#resolve_type pack mname tname with
+					| TClassDecl c ->
+						c
+					| _ ->
+						error ("Unexpected type where class was expected: " ^ (s_type_path (pack,tname)))
+				) with IgnoredModule -> null_class
 		))
 
 	method read_abr =
 		let l = read_uleb128 ch in
 		abstracts <- (Array.init l (fun i ->
 			let (pack,mname,tname) = self#read_full_path in
-			match self#resolve_type pack mname tname with
-			| TAbstractDecl a ->
-				a
-			| _ ->
-				error ("Unexpected type where abstract was expected: " ^ (s_type_path (pack,tname)))
+			try (match self#resolve_type pack mname tname with
+				| TAbstractDecl a ->
+					a
+				| _ ->
+					error ("Unexpected type where abstract was expected: " ^ (s_type_path (pack,tname)))
+			) with IgnoredModule -> null_abstract
 		))
 
 	method read_enr =
 		let l = read_uleb128 ch in
 		enums <- (Array.init l (fun i ->
 			let (pack,mname,tname) = self#read_full_path in
-			match self#resolve_type pack mname tname with
-			| TEnumDecl en ->
-				en
-			| _ ->
-				error ("Unexpected type where enum was expected: " ^ (s_type_path (pack,tname)))
+			try (match self#resolve_type pack mname tname with
+				| TEnumDecl en ->
+					en
+				| _ ->
+					error ("Unexpected type where enum was expected: " ^ (s_type_path (pack,tname)))
+			) with IgnoredModule -> null_enum
 		))
 
 	method read_tdr =
 		let l = read_uleb128 ch in
 		typedefs <- (Array.init l (fun i ->
 			let (pack,mname,tname) = self#read_full_path in
-			match self#resolve_type pack mname tname with
-			| TTypeDecl tpd ->
-				tpd
-			| _ ->
-				error ("Unexpected type where typedef was expected: " ^ (s_type_path (pack,tname)))
+			try (match self#resolve_type pack mname tname with
+				| TTypeDecl tpd ->
+					tpd
+				| _ ->
+					error ("Unexpected type where typedef was expected: " ^ (s_type_path (pack,tname)))
+			) with IgnoredModule -> null_typedef
 		))
 
 	method read_mdr =
 		let length = read_uleb128 ch in
 		for _ = 0 to length - 1 do
 			let path = self#read_path in
-			ignore(api#resolve_module path)
+			if not (self#is_module_ignored path) then
+				ignore(api#resolve_module path)
 		done
 
 	method read_mtf =
@@ -2011,10 +2033,11 @@ class hxb_reader
 		close()
 
 	method read_chunks (new_api : hxb_reader_api) (chunks : cached_chunks) =
-		fst (self#read_chunks_until new_api chunks EOM)
+		fst (self#read_chunks_until new_api chunks EOM false)
 
-	method read_chunks_until (new_api : hxb_reader_api) (chunks : cached_chunks) end_chunk =
+	method read_chunks_until (new_api : hxb_reader_api) (chunks : cached_chunks) end_chunk skip_expr =
 		api <- new_api;
+		sig_only <- skip_expr;
 		let rec loop = function
 			| (kind,data) :: chunks ->
 				ch <- BytesWithPosition.create data;

src/compiler/hxb/hxbWriter.ml

@@ -415,6 +415,9 @@ type hxb_writer = {
 	docs : StringPool.t;
 	mutable chunk : Chunk.t;
 
+	mutable in_expr : bool;
+	mutable sig_deps : module_def list;
+
 	classes : (path,tclass) Pool.t;
 	enums : (path,tenum) Pool.t;
 	typedefs : (path,tdef) Pool.t;
@@ -866,20 +869,29 @@ module HxbWriter = struct
 
 	(* References *)
 
+	let maybe_add_sig_dep writer m =
+		if not writer.in_expr then
+			if m.m_path <> writer.current_module.m_path && not (List.exists (fun m' -> m'.m_path = m.m_path) writer.sig_deps) then
+				writer.sig_deps <- m :: writer.sig_deps
+
 	let write_class_ref writer (c : tclass) =
 		let i = Pool.get_or_add writer.classes c.cl_path c in
+		maybe_add_sig_dep writer c.cl_module;
 		Chunk.write_uleb128 writer.chunk i
 
 	let write_enum_ref writer (en : tenum) =
 		let i = Pool.get_or_add writer.enums en.e_path en in
+		maybe_add_sig_dep writer en.e_module;
 		Chunk.write_uleb128 writer.chunk i
 
 	let write_typedef_ref writer (td : tdef) =
 		let i = Pool.get_or_add writer.typedefs td.t_path td in
+		maybe_add_sig_dep writer td.t_module;
 		Chunk.write_uleb128 writer.chunk i
 
 	let write_abstract_ref writer (a : tabstract) =
 		let i = Pool.get_or_add writer.abstracts a.a_path a in
+		maybe_add_sig_dep writer a.a_module;
 		Chunk.write_uleb128 writer.chunk i
 
 	let write_tmono_ref writer (mono : tmono) =
@@ -1785,15 +1797,21 @@ module HxbWriter = struct
 			| Some e when not write_expr_immediately ->
 				Chunk.write_u8 writer.chunk 2;
 				let fctx,close = start_texpr writer e.epos in
+				let old = writer.in_expr in
+				writer.in_expr <- true;
 				write_texpr writer fctx e;
 				Chunk.write_option writer.chunk cf.cf_expr_unoptimized (write_texpr writer fctx);
+				writer.in_expr <- old;
 				let expr_chunk = close() in
 				Some expr_chunk
 			| Some e ->
 				Chunk.write_u8 writer.chunk 1;
 				let fctx,close = start_texpr writer e.epos in
+				let old = writer.in_expr in
+				writer.in_expr <- true;
 				write_texpr writer fctx e;
 				Chunk.write_option writer.chunk cf.cf_expr_unoptimized (write_texpr writer fctx);
+				writer.in_expr <- old;
 				let expr_pre_chunk,expr_chunk = close() in
 				Chunk.export_data expr_pre_chunk writer.chunk;
 				Chunk.export_data expr_chunk writer.chunk;
@@ -2240,6 +2258,15 @@ module HxbWriter = struct
 			end
 		end;
 
+		(* Note: this is only a start, and is still including a lot of dependencies *)
+		(* that are not actually needed for signature only. *)
+		let sig_deps = ref (PMap.map (fun m -> m) m.m_extra.m_manual_deps) in
+		List.iter (fun mdep ->
+			let dep = {md_sign = mdep.m_extra.m_sign; md_path = mdep.m_path; md_kind = mdep.m_extra.m_kind} in
+			sig_deps := PMap.add mdep.m_id dep !sig_deps;
+		) writer.sig_deps;
+		m.m_extra.m_sig_deps <- Some !sig_deps;
+
 		start_chunk writer EOT;
 		start_chunk writer EOF;
 		start_chunk writer EOM;
@@ -2277,6 +2304,8 @@ let create config string_pool warn anon_id =
 		chunks = DynArray.create ();
 		cp = cp;
 		has_own_string_pool;
+		sig_deps = [];
+		in_expr = false;
 		docs = StringPool.create ();
 		chunk = Obj.magic ();
 		classes = Pool.create ();

src/compiler/server.ml

@@ -309,6 +309,7 @@ let check_module sctx com m_path m_extra p =
 		let find_module_extra sign mpath =
 			(com.cs#get_context sign)#find_module_extra mpath
 		in
+		let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m_extra.m_file) in
 		let check_dependencies () =
 			PMap.iter (fun _ mdep ->
 				let sign = mdep.md_sign in
@@ -321,7 +322,11 @@ let check_module sctx com m_path m_extra p =
 				match check mpath m2_extra with
 				| None -> ()
 				| Some reason -> raise (Dirty (DependencyDirty(mpath,reason)))
-			) m_extra.m_deps;
+			) (match m_extra.m_sig_deps with
+				| None -> m_extra.m_deps
+				| Some _ when com.is_macro_context || com.display.dms_full_typing || is_display_file -> m_extra.m_deps
+				| Some deps -> deps
+			);
 		in
 		let check () =
 			try
@@ -418,19 +423,20 @@ class hxb_reader_api_server
 			m
 		| BinaryModule mc ->
 			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats (Some cc#get_string_pool_arr) (Common.defined com Define.HxbTimes) in
+			let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key mc.mc_extra.m_file) in
+			let sig_only = not (com.is_macro_context || com.display.dms_full_typing || is_display_file) in
 			let f_next chunks until =
 				let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in
-				let r = reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) chunks until in
+				let r = reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) chunks until sig_only in
 				t_hxb();
 				r
 			in
-			let m,chunks = f_next mc.mc_chunks EOF in
+			let m,chunks = f_next mc.mc_chunks EOT in
 
 			(* We try to avoid reading expressions as much as possible, so we only do this for
 				 our current display file if we're in display mode. *)
-			let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in
-			if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM)
-			else delay (fun () -> ignore(f_next chunks EOM));
+			if not sig_only then ignore(f_next chunks EOM)
+			else delay (fun () -> ignore(f_next chunks EOF));
 			m
 		| BadModule reason ->
 			die (Printf.sprintf "Unexpected BadModule %s" (s_type_path path)) __LOC__
@@ -490,6 +496,7 @@ let rec add_modules sctx com delay (m : module_def) (from_binary : bool) (p : po
 				if not from_binary || m != m then
 					com.module_lut#add m.m_path m;
 				handle_cache_bound_objects com m.m_extra.m_cache_bound_objects;
+				let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in
 				PMap.iter (fun _ mdep ->
 					let mpath = mdep.md_path in
 					if mdep.md_sign = own_sign then begin
@@ -508,7 +515,11 @@ let rec add_modules sctx com delay (m : module_def) (from_binary : bool) (p : po
 						in
 						add_modules (tabs ^ "  ") m0 m2
 					end
-				) m.m_extra.m_deps
+				) (match m.m_extra.m_sig_deps with
+					| None -> m.m_extra.m_deps
+					| Some _ when com.is_macro_context || com.display.dms_full_typing || is_display_file -> m.m_extra.m_deps
+					| Some deps -> deps
+				);
 			)
 		end
 	in
@@ -568,6 +579,8 @@ and type_module sctx com delay mpath p =
 			begin match check_module sctx mpath mc.mc_extra p with
 				| None ->
 					let reader = new HxbReader.hxb_reader mpath com.hxb_reader_stats (Some cc#get_string_pool_arr) (Common.defined com Define.HxbTimes) in
+					let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key mc.mc_extra.m_file) in
+					let sig_only = not (com.is_macro_context || com.display.dms_full_typing || is_display_file) in
 					let api = match com.hxb_reader_api with
 						| Some api ->
 							api
@@ -578,16 +591,15 @@ and type_module sctx com delay mpath p =
 					in
 					let f_next chunks until =
 						let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in
-						let r = reader#read_chunks_until api chunks until in
+						let r = reader#read_chunks_until api chunks until sig_only in
 						t_hxb();
 						r
 					in
-					let m,chunks = f_next mc.mc_chunks EOF in
+					let m,chunks = f_next mc.mc_chunks EOT in
 					(* We try to avoid reading expressions as much as possible, so we only do this for
 					   our current display file if we're in display mode. *)
-					let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in
-					if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM)
-					else delay (fun () -> ignore(f_next chunks EOM));
+					if not sig_only then ignore(f_next chunks EOM)
+					else delay (fun () -> ignore(f_next chunks EOF));
 					add_modules true m;
 				| Some reason ->
 					skip mpath reason

src/context/display/displayJson.ml

@@ -140,7 +140,7 @@ class hxb_reader_api_com
 		with Not_found ->
 			let mc = cc#get_hxb_module m_path in
 			let reader = new HxbReader.hxb_reader mc.mc_path com.hxb_reader_stats (Some cc#get_string_pool_arr) (Common.defined com Define.HxbTimes) in
-			fst (reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) mc.mc_chunks (if headers_only then MTF else EOM))
+			fst (reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) mc.mc_chunks (if headers_only then MTF else EOM) headers_only)
 
 	method basic_types =
 		com.basic

src/core/tFunctions.ml

@@ -171,6 +171,8 @@ let module_extra file sign time kind added policy =
 		m_time = time;
 		m_processed = 0;
 		m_deps = PMap.empty;
+		m_manual_deps = PMap.empty;
+		m_sig_deps = None;
 		m_kind = kind;
 		m_cache_bound_objects = DynArray.create ();
 		m_features = Hashtbl.create 0;
@@ -297,6 +299,15 @@ let add_dependency ?(skip_postprocess=false) m mdep =
 		if not skip_postprocess then m.m_extra.m_processed <- 0
 	end
 
+(* TODO: cleanup *)
+let add_manual_dependency ?(skip_postprocess=false) m mdep =
+	if m != null_module && mdep != null_module && (m.m_path != mdep.m_path || m.m_extra.m_sign != mdep.m_extra.m_sign) then begin
+		m.m_extra.m_deps <- PMap.add mdep.m_id ({md_sign = mdep.m_extra.m_sign; md_path = mdep.m_path; md_kind = mdep.m_extra.m_kind}) m.m_extra.m_deps;
+		m.m_extra.m_manual_deps <- PMap.add mdep.m_id ({md_sign = mdep.m_extra.m_sign; md_path = mdep.m_path; md_kind = mdep.m_extra.m_kind}) m.m_extra.m_manual_deps;
+		(* In case the module is cached, we'll have to run post-processing on it again (issue #10635) *)
+		if not skip_postprocess then m.m_extra.m_processed <- 0
+	end
+
 let arg_name (a,_) = a.v_name
 
 let t_infos t : tinfos =

src/core/tType.ml

@@ -418,6 +418,8 @@ and module_def_extra = {
 	mutable m_checked : int;
 	mutable m_processed : int;
 	mutable m_deps : (int,module_dep) PMap.t;
+	mutable m_manual_deps : (int,module_dep) PMap.t;
+	mutable m_sig_deps : (int,module_dep) PMap.t option;
 	mutable m_kind : module_kind;
 	mutable m_cache_bound_objects : cache_bound_object DynArray.t;
 	mutable m_features : (string,bool) Hashtbl.t;

src/typing/macroContext.ml

@@ -469,7 +469,7 @@ let make_macro_api ctx mctx p =
 				let mdep = Option.map_default (fun s -> TypeloadModule.load_module ctx (parse_path s) pos) ctx.m.curmod mdep in
 				let mnew = TypeloadModule.type_module ctx.com ctx.g ~dont_check_path:(has_native_meta) m (Path.UniqueKey.lazy_path mdep.m_extra.m_file) [tdef,pos] pos in
 				mnew.m_extra.m_kind <- if is_macro then MMacro else MFake;
-				add_dependency mnew mdep;
+				add_manual_dependency mnew mdep;
 				ctx.com.module_nonexistent_lut#clear;
 			in
 			add false ctx;
@@ -499,7 +499,7 @@ let make_macro_api ctx mctx p =
 			with Not_found ->
 				let mnew = TypeloadModule.type_module ctx.com ctx.g mpath (Path.UniqueKey.lazy_path ctx.m.curmod.m_extra.m_file) types pos in
 				mnew.m_extra.m_kind <- MFake;
-				add_dependency mnew ctx.m.curmod;
+				add_manual_dependency mnew ctx.m.curmod;
 				ctx.com.module_nonexistent_lut#clear;
 			end
 		);
@@ -510,7 +510,7 @@ let make_macro_api ctx mctx p =
 				ctx.m.curmod.m_extra.m_deps <- old_deps;
 				m
 			) in
-			add_dependency m (TypeloadCacheHook.create_fake_module ctx.com file);
+			add_manual_dependency m (TypeloadCacheHook.create_fake_module ctx.com file);
 		);
 		MacroApi.current_module = (fun() ->
 			ctx.m.curmod
@@ -811,7 +811,7 @@ let load_macro ctx com mctx api display cpath f p =
 	let meth,mloaded = load_macro'' com mctx display cpath f p in
 	let _,_,{cl_path = cpath},_ = meth in
 	let call args =
-		add_dependency ctx.m.curmod mloaded;
+		add_manual_dependency ctx.m.curmod mloaded;
 		do_call_macro ctx.com api cpath f args p
 	in
 	mctx, meth, call