Make compilation server aware of native libs (#8638)

* [server] make compilation server aware of native libs

* [tests] add a pos to find the timeout

* fix some ordering problems

* fix issues professionally

* [cs] remove forced lib evaluation

* clean up a bit and hide behind a flag

src/codegen/dotnet.ml

@@ -1220,9 +1220,8 @@ let add_net_lib com file std =
 			failwith (".NET lib " ^ file ^ " not found")
 	in
 	let net_lib = new net_library com file real_file std in
-	com.load_extern_type <- com.load_extern_type @ [net_lib#build];
 	com.native_libs.net_libs <- (net_lib :> (net_lib_type,unit) native_library) :: com.native_libs.net_libs;
-	com.native_libs.all_libs <- net_lib#get_file_path :: com.native_libs.all_libs
+	CompilationServer.handle_native_lib com net_lib
 
 let before_generate com =
 	(* netcore version *)
@@ -1300,7 +1299,4 @@ let before_generate com =
 				Unix.closedir f
 		in
 		loop()
-	) !matched;
-
-	(* now force all libraries to initialize *)
-	List.iter (function net_lib -> ignore (net_lib#lookup ([],""))) com.native_libs.net_libs
+	) !matched

src/codegen/java.ml

@@ -936,129 +936,129 @@ class virtual java_library com name file_path = object(self)
 
 	method build path (p : pos) : (string * Ast.package) option =
 		let rec build ctx path p types =
-		try
-			if List.mem path !types then
-				None
-			else begin
-				let first = match !types with
-					| [ ["java";"lang"], "String" ] | [] -> true
-					| p :: _ ->
-						false
-				in
-				types := path :: !types;
-				match self#lookup path, path with
+			try
+				if List.mem path !types then
+					None
+				else begin
+					let first = match !types with
+						| [ ["java";"lang"], "String" ] | [] -> true
+						| p :: _ ->
+							false
+					in
+					types := path :: !types;
+					match self#lookup path, path with
 					| None, ([], c) -> build ctx (["haxe";"root"], c) p types
-				| None, _ -> None
-				| Some (cls, real_path, pos_path), _ ->
-						let is_disallowed_inner = first && String.exists (snd cls.cpath) "$" in
-						let is_disallowed_inner = if is_disallowed_inner then begin
-								let outer, inner = String.split (snd cls.cpath) "$" in
-								match self#lookup (fst path, outer) with
-									| None -> false
-									| _ -> true
-							end else
-								false
-						in
-						if is_disallowed_inner then
-							None
-						else begin
-							if ctx.jcom.verbose then print_endline ("Parsed Java class " ^ (s_type_path cls.cpath));
-							let old_types = ctx.jtparams in
-							ctx.jtparams <- cls.ctypes :: ctx.jtparams;
-
-							let pos = { pfile = pos_path; pmin = 0; pmax = 0; } in
-
-							let pack = match fst path with | ["haxe";"root"] -> [] | p -> p in
-
-							let ppath = self#convert_path path in
-							let inner = List.fold_left (fun acc (path,out,_,_) ->
-								let path = jpath_to_hx path in
-								(if out <> Some ppath then
-									acc
-									else match build ctx path p types with
-									| Some(_,(_, classes)) ->
-										let base = snd ppath ^ "$" in
-										(List.map (fun (def,p) ->
-											self#replace_canonical_name p (fst ppath) base (snd ppath ^ ".") def, p) classes) @ acc
-									| _ -> acc);
-							) [] cls.cinner_types in
-
-							(* add _Statics class *)
-							let inner = try
-								if not (List.mem JInterface cls.cflags) then raise Not_found;
-								let smethods = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cmethods in
-								let sfields = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cfields in
-								if not (smethods <> [] || sfields <> []) then raise Not_found;
-								let obj = TObject( (["java";"lang"],"Object"), []) in
-								let ncls = convert_java_class ctx pos { cls with cmethods = smethods; cfields = sfields; cflags = []; csuper = obj; cinterfaces = []; cinner_types = []; ctypes = [] } in
-								match ncls with
-								| EClass c :: imports ->
-									(EClass { c with d_name = (fst c.d_name ^ "_Statics"),snd c.d_name }, pos) :: inner @ List.map (fun i -> i,pos) imports
-								| _ -> assert false
-							with | Not_found ->
-								inner
+					| None, _ -> None
+					| Some (cls, real_path, pos_path), _ ->
+							let is_disallowed_inner = first && String.exists (snd cls.cpath) "$" in
+							let is_disallowed_inner = if is_disallowed_inner then begin
+									let outer, inner = String.split (snd cls.cpath) "$" in
+									match self#lookup (fst path, outer) with
+										| None -> false
+										| _ -> true
+								end else
+									false
 							in
-							let inner_alias = ref SS.empty in
-							List.iter (fun x ->
-								match fst x with
-								| EClass c ->
-									inner_alias := SS.add (fst c.d_name) !inner_alias;
-								| _ -> ()
-							) inner;
-							let alias_list = ref [] in
-							List.iter (fun x ->
-								match x with
-								| (EClass c, pos) -> begin
-									let parts = String.nsplit (fst c.d_name) "_24" in
-									match parts with
-										| _ :: _ ->
-											let alias_name = String.concat "_" parts in
-											if (not (SS.mem alias_name !inner_alias)) && (not (String.exists (snd path) "_24")) then begin
-												let alias_def = ETypedef {
-													d_name = alias_name,null_pos;
-													d_doc = None;
-													d_params = c.d_params;
-													d_meta = [];
-													d_flags = [];
-													d_data = CTPath {
-														tpackage = pack;
-														tname = snd path;
-														tparams = List.map (fun tp ->
-															TPType (CTPath {
-																tpackage = [];
-																tname = fst tp.tp_name;
-																tparams = [];
-																tsub = None;
-															},null_pos)
-														) c.d_params;
-														tsub = Some(fst c.d_name);
-													},null_pos;
-												} in
-												inner_alias := SS.add alias_name !inner_alias;
-												alias_list := (alias_def, pos) :: !alias_list;
-											end
-										| _ -> ()
-								end
-								| _ -> ()
-							) inner;
-							let inner = List.concat [!alias_list ; inner] in
-							let classes = List.map (fun t -> t,pos) (convert_java_class ctx pos cls) in
-							let imports, defs = List.partition (function | (EImport(_),_) -> true | _ -> false) (classes @ inner) in
-							let ret = Some ( real_path, (pack, imports @ defs) ) in
-							ctx.jtparams <- old_types;
-							ret
-						end
-			end
-		with
-		| JReader.Error_message msg ->
-			prerr_endline ("Class reader failed: " ^ msg);
-			None
-		| e ->
-			if ctx.jcom.verbose then begin
-				(* prerr_endline (Printexc.get_backtrace ()); requires ocaml 3.11 *)
-				prerr_endline (Printexc.to_string e)
-			end;
-			None
+							if is_disallowed_inner then
+								None
+							else begin
+								if ctx.jcom.verbose then print_endline ("Parsed Java class " ^ (s_type_path cls.cpath));
+								let old_types = ctx.jtparams in
+								ctx.jtparams <- cls.ctypes :: ctx.jtparams;
+
+								let pos = { pfile = pos_path; pmin = 0; pmax = 0; } in
+
+								let pack = match fst path with | ["haxe";"root"] -> [] | p -> p in
+
+								let ppath = self#convert_path path in
+								let inner = List.fold_left (fun acc (path,out,_,_) ->
+									let path = jpath_to_hx path in
+									(if out <> Some ppath then
+										acc
+									else match build ctx path p types with
+										| Some(_,(_, classes)) ->
+											let base = snd ppath ^ "$" in
+											(List.map (fun (def,p) ->
+												self#replace_canonical_name p (fst ppath) base (snd ppath ^ ".") def, p) classes) @ acc
+										| _ -> acc);
+								) [] cls.cinner_types in
+
+								(* add _Statics class *)
+								let inner = try
+									if not (List.mem JInterface cls.cflags) then raise Not_found;
+									let smethods = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cmethods in
+									let sfields = List.filter (fun f -> List.mem JStatic f.jf_flags) cls.cfields in
+									if not (smethods <> [] || sfields <> []) then raise Not_found;
+									let obj = TObject( (["java";"lang"],"Object"), []) in
+									let ncls = convert_java_class ctx pos { cls with cmethods = smethods; cfields = sfields; cflags = []; csuper = obj; cinterfaces = []; cinner_types = []; ctypes = [] } in
+									match ncls with
+									| EClass c :: imports ->
+										(EClass { c with d_name = (fst c.d_name ^ "_Statics"),snd c.d_name }, pos) :: inner @ List.map (fun i -> i,pos) imports
+									| _ -> assert false
+								with | Not_found ->
+									inner
+								in
+								let inner_alias = ref SS.empty in
+								List.iter (fun x ->
+									match fst x with
+									| EClass c ->
+										inner_alias := SS.add (fst c.d_name) !inner_alias;
+									| _ -> ()
+								) inner;
+								let alias_list = ref [] in
+								List.iter (fun x ->
+									match x with
+									| (EClass c, pos) -> begin
+										let parts = String.nsplit (fst c.d_name) "_24" in
+										match parts with
+											| _ :: _ ->
+												let alias_name = String.concat "_" parts in
+												if (not (SS.mem alias_name !inner_alias)) && (not (String.exists (snd path) "_24")) then begin
+													let alias_def = ETypedef {
+														d_name = alias_name,null_pos;
+														d_doc = None;
+														d_params = c.d_params;
+														d_meta = [];
+														d_flags = [];
+														d_data = CTPath {
+															tpackage = pack;
+															tname = snd path;
+															tparams = List.map (fun tp ->
+																TPType (CTPath {
+																	tpackage = [];
+																	tname = fst tp.tp_name;
+																	tparams = [];
+																	tsub = None;
+																},null_pos)
+															) c.d_params;
+															tsub = Some(fst c.d_name);
+														},null_pos;
+													} in
+													inner_alias := SS.add alias_name !inner_alias;
+													alias_list := (alias_def, pos) :: !alias_list;
+												end
+											| _ -> ()
+									end
+									| _ -> ()
+								) inner;
+								let inner = List.concat [!alias_list ; inner] in
+								let classes = List.map (fun t -> t,pos) (convert_java_class ctx pos cls) in
+								let imports, defs = List.partition (function | (EImport(_),_) -> true | _ -> false) (classes @ inner) in
+								let ret = Some ( real_path, (pack, imports @ defs) ) in
+								ctx.jtparams <- old_types;
+								ret
+							end
+				end
+			with
+			| JReader.Error_message msg ->
+				prerr_endline ("Class reader failed: " ^ msg);
+				None
+			| e ->
+				if ctx.jcom.verbose then begin
+					(* prerr_endline (Printexc.get_backtrace ()); requires ocaml 3.11 *)
+					prerr_endline (Printexc.to_string e)
+				end;
+				None
 		in
 		build (create_ctx com (self#has_flag FlagIsStd)) path p (ref [["java";"lang"], "String"])
 
@@ -1203,12 +1203,8 @@ let add_java_lib com name std =
 			(new java_library_jar com name file :> java_library)
 	in
 	if std then java_lib#add_flag FlagIsStd;
-	java_lib#load;
-	let build path p = java_lib#build path p in
-	(* TODO: add_dependency m mdep *)
-	com.load_extern_type <- com.load_extern_type @ [build];
 	com.native_libs.java_libs <- (java_lib :> (java_lib_type,unit) native_library) :: com.native_libs.java_libs;
-	com.native_libs.all_libs <- java_lib#get_file_path :: com.native_libs.all_libs
+	CompilationServer.handle_native_lib com java_lib
 
 let before_generate con =
 	let java_ver = try

src/codegen/swfLoader.ml

@@ -625,9 +625,8 @@ end
 let add_swf_lib com file extern =
 	let real_file = (try Common.find_file com file with Not_found -> failwith (" Library not found : " ^ file)) in
 	let swf_lib = new swf_library com file real_file in
-	com.load_extern_type <- com.load_extern_type @ [swf_lib#build];
 	if not extern then com.native_libs.swf_libs <- (swf_lib :> (swf_lib_type,Swf.swf) native_library) :: com.native_libs.swf_libs;
-	com.native_libs.all_libs <- swf_lib#get_file_path :: com.native_libs.all_libs
+	CompilationServer.handle_native_lib com swf_lib
 
 let remove_classes toremove lib l =
 	match !toremove with

src/compiler/displayOutput.ml

@@ -328,6 +328,7 @@ module Memory = struct
 				"haxelibCache",jint (mem_size cs.cache.c_haxelib);
 				"parserCache",jint (mem_size cs.cache.c_files);
 				"moduleCache",jint (mem_size cs.cache.c_modules);
+				"nativeLibCache",jint (mem_size cs.cache.c_native_libs);
 			]
 		]
 

src/compiler/main.ml

@@ -515,7 +515,6 @@ try
 		| [] -> ()
 		| args -> (!process_ref) args
 	in
-	let arg_delays = ref [] in
 	(* category, official names, deprecated names, arg spec, usage hint, doc *)
 	let basic_args_spec = [
 		("Target",["--js"],["-js"],Arg.String (Initialize.set_platform com Js),"<file>","compile code to JavaScript file");
@@ -656,7 +655,7 @@ try
 		("Target-specific",["--flash-strict"],[], define Define.FlashStrict, "","more type strict flash API");
 		("Target-specific",["--java-lib"],["-java-lib"],Arg.String (fun file ->
 			let std = file = "lib/hxjava-std.jar" in
-			arg_delays := (fun () -> Java.add_java_lib com file std) :: !arg_delays;
+			com.callbacks#add_before_typer_create (fun () -> Java.add_java_lib com file std);
 		),"<file>","add an external JAR or class directory library");
 		("Target-specific",["--net-lib"],["-net-lib"],Arg.String (fun file ->
 			let file, is_std = match ExtString.String.nsplit file "@" with
@@ -666,7 +665,7 @@ try
 					file,true
 				| _ -> raise Exit
 			in
-			arg_delays := (fun () -> Dotnet.add_net_lib com file is_std) :: !arg_delays;
+			com.callbacks#add_before_typer_create (fun () -> Dotnet.add_net_lib com file is_std);
 		),"<file>[@std]","add an external .NET DLL file");
 		("Target-specific",["--net-std"],["-net-std"],Arg.String (fun file ->
 			Dotnet.add_net_std com file
@@ -777,7 +776,6 @@ try
 			in
 			let args = loop [] args in
 			Arg.parse_argv ~current (Array.of_list ("" :: args)) all_args_spec args_callback "";
-			List.iter (fun fn -> fn()) !arg_delays
 		with
 		| Arg.Help _ ->
 			raise (HelpMessage (usage_string all_args usage))
@@ -801,7 +799,6 @@ try
 				end;
 			with Not_found ->
 				raise (Arg.Bad new_msg));
-		arg_delays := [];
 		if com.platform = Globals.Cpp && not (Define.defined com.defines DisableUnicodeStrings) && not (Define.defined com.defines HxcppSmartStings) then begin
 			Define.define com.defines HxcppSmartStings;
 		end;

src/context/compilationServer.ml

@@ -16,12 +16,18 @@ type cached_directory = {
 	mutable c_mtime : float;
 }
 
+type cached_native_lib = {
+	c_nl_mtime : float;
+	c_nl_files : (path,(string * Ast.package)) Hashtbl.t;
+}
+
 type cache = {
 	c_haxelib : (string list, string list) Hashtbl.t;
 	c_files : ((string * string), cached_file) Hashtbl.t;
 	c_modules : (path * string, module_def) Hashtbl.t;
 	c_directories : (string, cached_directory list) Hashtbl.t;
 	c_removed_files : (string * string,unit) Hashtbl.t;
+	c_native_libs : (string,cached_native_lib) Hashtbl.t;
 }
 
 type context_sign = {
@@ -48,6 +54,7 @@ let create_cache () = {
 	c_modules = Hashtbl.create 0;
 	c_directories = Hashtbl.create 0;
 	c_removed_files = Hashtbl.create 0;
+	c_native_libs = Hashtbl.create 0;
 }
 
 let create () =
@@ -218,6 +225,68 @@ let add_directory cs key value =
 let clear_directories cs key =
 	Hashtbl.remove cs.cache.c_directories key
 
+(* native lib *)
+
+let add_native_lib cs key files timestamp =
+	Hashtbl.replace cs.cache.c_native_libs key { c_nl_files = files; c_nl_mtime = timestamp }
+
+let get_native_lib cs key =
+	try Some (Hashtbl.find cs.cache.c_native_libs key)
+	with Not_found -> None
+
+let handle_native_lib com lib =
+	let build = lib#build in
+	com.native_libs.all_libs <- lib#get_file_path :: com.native_libs.all_libs;
+	begin match get() with
+	| Some cs when Define.raw_defined com.defines "haxe.cacheNativeLibs" ->
+		let init () =
+			let file = lib#get_file_path in
+			let key = file in
+			let ftime = file_time file in
+			begin match get_native_lib cs key with
+			| Some lib when ftime <= lib.c_nl_mtime ->
+				(* Cached lib is good, set up lookup into cached files. *)
+				lib.c_nl_files;
+			| _ ->
+				(* Cached lib is outdated or doesn't exist yet, read library. *)
+				lib#load;
+				(* Created lookup and eagerly read each known type. *)
+				let h = Hashtbl.create 0 in
+				List.iter (fun path ->
+					if not (Hashtbl.mem h path) then begin
+						let p = { pfile = file ^ " @ " ^ Globals.s_type_path path; pmin = 0; pmax = 0; } in
+						try begin match lib#build path p with
+						| Some r -> Hashtbl.add h path r
+						| None -> ()
+						end with _ ->
+							()
+					end
+				) lib#list_modules;
+				(* Save and set up lookup. *)
+				add_native_lib cs key h ftime;
+				h;
+			end;
+		in
+		(* This is some dicey nonsense: Native library handlers might actually
+			lookup something during the conversion to Haxe AST. For instance, the
+			SWF loader has a `is_valid_path` check in some cases which relies on
+			`load_extern_type`. In order to deal with this, we temporarily register
+			the standard resolver and then remove it again after the handling.
+		*)
+		let old = com.load_extern_type in
+		com.load_extern_type <- com.load_extern_type @ [build];
+		let lut = init() in
+		let build path p =
+			try Some (Hashtbl.find lut path)
+			with Not_found -> None
+		in
+		com.load_extern_type <- old @ [build];
+	| _ ->
+		(* Offline mode, just read library as usual. *)
+		lib#load;
+		com.load_extern_type <- com.load_extern_type @ [build];
+	end
+
 (* context *)
 
 let rec cache_context cs com =

src/context/display/displayToplevel.ml

@@ -196,6 +196,11 @@ let collect ctx tk with_type =
 	in
 
 	let process_decls pack name decls =
+		let added_something = ref false in
+		let add item name =
+			added_something := true;
+			add item name
+		in
 		let run () = List.iter (fun (d,p) ->
 			begin try
 				let tname,is_private,meta = match d with
@@ -218,7 +223,8 @@ let collect ctx tk with_type =
 				()
 			end
 		) decls in
-		if is_pack_visible pack then run()
+		if is_pack_visible pack then run();
+		!added_something
 	in
 
 	(* Collection starts here *)
@@ -383,7 +389,7 @@ let collect ctx tk with_type =
 		explore_class_paths ctx.com ["display";"toplevel"] class_paths true add_package (fun path ->
 			if not (path_exists cctx path) then begin
 				let _,decls = Display.parse_module ctx path Globals.null_pos in
-				process_decls (fst path) (snd path) decls
+				ignore(process_decls (fst path) (snd path) decls)
 			end
 		)
 	| Some cs ->
@@ -396,20 +402,29 @@ let collect ctx tk with_type =
 			(file,cfile),i
 		) files in
 		let files = List.sort (fun (_,i1) (_,i2) -> -compare i1 i2) files in
+		let check_package pack = match List.rev pack with
+			| [] -> ()
+			| s :: sl -> add_package (List.rev sl,s)
+		in
 		List.iter (fun ((file,cfile),_) ->
 			let module_name = CompilationServer.get_module_name_of_cfile file cfile in
 			let dot_path = s_type_path (cfile.c_package,module_name) in
 			if (List.exists (fun e -> ExtString.String.starts_with dot_path (e ^ ".")) !exclude) then
 				()
 			else begin
-				begin match List.rev cfile.c_package with
-					| [] -> ()
-					| s :: sl -> add_package (List.rev sl,s)
-				end;
 				Hashtbl.replace ctx.com.module_to_file (cfile.c_package,module_name) file;
-				process_decls cfile.c_package module_name cfile.c_decls
+				if process_decls cfile.c_package module_name cfile.c_decls then check_package cfile.c_package;
 			end
-		) files
+		) files;
+		List.iter (fun file ->
+			try
+				let lib = Hashtbl.find cs.cache.c_native_libs file in
+				Hashtbl.iter (fun path (_,(pack,decls)) ->
+					if process_decls pack (snd path) decls then check_package pack;
+				) lib.c_nl_files
+			with Not_found ->
+				()
+		) ctx.com.native_libs.all_libs
 	end;
 
 	(* packages *)

std/haxe/display/Server.hx

@@ -116,6 +116,7 @@ typedef HaxeMemoryResult = {
 		final haxelibCache:Int;
 		final parserCache:Int;
 		final moduleCache:Int;
+		final nativeLibCache:Int;
 	}
 }
 

tests/server/src/AsyncMacro.hx

@@ -18,7 +18,7 @@ class AsyncMacro {
 					});
 					switch (f.expr.expr) {
 						case EBlock(el):
-							el.push(macro async.done());
+							el.push(macro @:pos(f.expr.pos) async.done());
 							f.expr = transformHaxeCalls(el);
 						case _:
 							Context.error("Block expression expected", f.expr.pos);

tests/server/src/Main.hx

@@ -4,7 +4,7 @@ import haxe.display.Display;
 import haxe.display.FsPath;
 import haxe.display.Server;
 
-@:timeout(5000)
+@:timeout(10000)
 class ServerTests extends HaxeServerTestCase {
 	function testNoModification() {
 		vfs.putContent("HelloWorld.hx", getTemplate("HelloWorld.hx"));