[cs] Allow Haxe dll import. Closes #2053

gencommon.ml

@@ -738,10 +738,12 @@ let new_ctx con =
 		gadd_type = (fun md should_filter ->
 			if should_filter then begin
 				con.types <- md :: con.types;
-				con.modules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: con.modules
+				con.modules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: con.modules;
+				Hashtbl.add gen.gtypes (t_path md) md;
 			end else gen.gafter_filters_ended <- (fun () ->
 				con.types <- md :: con.types;
-				con.modules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: con.modules
+				con.modules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake } :: con.modules;
+				Hashtbl.add gen.gtypes (t_path md) md;
 			) :: gen.gafter_filters_ended;
 		);
 		gadd_to_module = (fun md pr -> failwith "module added outside expr filters");
@@ -6873,6 +6875,8 @@ struct
 
 		rcf_hash_fields : (int, string) Hashtbl.t;
 
+		rcf_hash_paths : (path * int, string) Hashtbl.t;
+
 		(*
 			main expr -> field expr -> field string -> possible hash int (if optimize) -> possible set expr -> should_throw_exceptions -> changed expression
 
@@ -6914,6 +6918,7 @@ struct
 			rcf_class_eager_creation = false;
 
 			rcf_hash_fields = Hashtbl.create 100;
+			rcf_hash_paths = Hashtbl.create 100;
 
 			rcf_on_getset_field = dynamic_getset_field;
 			rcf_on_call_field = dynamic_call_field;
@@ -6972,10 +6977,11 @@ struct
 	let hash_field ctx f pos =
 		let h = hash f in
 		(try
-			let f2 = Hashtbl.find ctx.rcf_hash_fields h in
+			let f2 = Hashtbl.find ctx.rcf_hash_paths (ctx.rcf_gen.gcurrent_path, h) in
 			if f <> f2 then ctx.rcf_gen.gcon.error ("Field conflict between " ^ f ^ " and " ^ f2) pos
 		with Not_found ->
-			Hashtbl.add ctx.rcf_hash_fields h f);
+			Hashtbl.add ctx.rcf_hash_paths (ctx.rcf_gen.gcurrent_path, h) f;
+			Hashtbl.replace ctx.rcf_hash_fields h f);
 		h
 
 	(* ( tf_args, switch_var ) *)

gencs.ml

@@ -3202,11 +3202,46 @@ let configure gen =
 		else i
 	in
 
-	let hashes = Hashtbl.fold (fun i s acc -> (normalize_i i,s) :: acc) rcf_ctx.rcf_hash_fields [] in
+	let nhash = ref 0 in
+	let hashes = Hashtbl.fold (fun i s acc -> incr nhash; (normalize_i i,s) :: acc) rcf_ctx.rcf_hash_fields [] in
 	let hashes = List.sort (fun (i,s) (i2,s2) -> compare i i2) hashes in
 
 	let flookup_cl = get_cl (get_type gen (["haxe";"lang"], "FieldLookup")) in
+	let haxe_libs = List.filter (function (_,_,_,lookup) -> is_some (lookup (["haxe";"lang"], "DceNo"))) gen.gcon.net_libs in
 	(try
+		(* first let's see if we're adding a -net-lib that has already a haxe.lang.FieldLookup *)
+		let name,_,_,_ = List.find (function (_,_,_,lookup) -> is_some (lookup (["haxe";"lang"], "FieldLookup"))) gen.gcon.net_libs in
+		if not (Common.defined gen.gcon Define.DllImport) then begin
+			gen.gcon.warning ("The -net-lib with path " ^ name ^ " contains a Haxe-generated assembly. Please define `-D dll_import` to handle Haxe-generated dll import correctly") null_pos;
+			raise Not_found
+		end;
+		if not (List.exists (function (n,_,_,_) -> n = name) haxe_libs) then
+			gen.gcon.warning ("The -net-lib with path " ^ name ^ " contains a Haxe-generated assembly, however it wasn't compiled with `-dce no`. Recompilation with `-dce no` is recommended") null_pos;
+		(* it has; in this case, we need to add the used fields on each __init__ *)
+		flookup_cl.cl_extern <- true;
+		let hashs_by_path = Hashtbl.create !nhash in
+		Hashtbl.iter (fun (path,i) s -> Hashtbl.add hashs_by_path path (i,s)) rcf_ctx.rcf_hash_paths;
+		Hashtbl.iter (fun _ md -> match md with
+			| TClassDecl ({ cl_extern = false; cl_interface = false } as c) -> (try
+				let all = Hashtbl.find_all hashs_by_path c.cl_path in
+				let all = List.map (fun (i,s) -> normalize_i i, s) all in
+				let all = List.sort (fun (i,s) (i2,s2) -> compare i i2) all in
+
+				if all <> [] then begin
+					let add = mk_static_field_access_infer flookup_cl "addFields" c.cl_pos [] in
+					let expr = { eexpr = TCall(add, [
+						mk_nativearray_decl gen basic.tint (List.map (fun (i,s) -> { eexpr = TConst(TInt (i)); etype = basic.tint; epos = c.cl_pos }) all) c.cl_pos;
+						mk_nativearray_decl gen basic.tstring (List.map (fun (i,s) -> { eexpr = TConst(TString (s)); etype = basic.tstring; epos = c.cl_pos }) all) c.cl_pos;
+					]); etype = basic.tvoid; epos = c.cl_pos } in
+					match c.cl_init with
+						| None -> c.cl_init <- Some expr
+						| Some e ->
+							c.cl_init <- Some { eexpr = TBlock([expr;e]); etype = basic.tvoid; epos = e.epos }
+				end
+			with | Not_found -> ())
+			| _ -> ()) gen.gtypes;
+
+	with | Not_found -> try
 		let basic = gen.gcon.basic in
 		let cl = flookup_cl in
 		let field_ids = PMap.find "fieldIds" cl.cl_statics in
@@ -3219,6 +3254,15 @@ let configure gen =
 		gen.gcon.error "Fields 'fieldIds' and 'fields' were not found in class haxe.lang.FieldLookup" flookup_cl.cl_pos
 	);
 
+	if Common.defined gen.gcon Define.DllImport then begin
+		Hashtbl.iter (fun _ md -> match md with
+			| TClassDecl ({ cl_extern = false } as c) -> (try
+				ignore (List.find (function (_,_,_,lookup) -> is_some (lookup c.cl_path)) haxe_libs);
+				c.cl_extern <- true;
+			with | Not_found -> ())
+			| _ -> ()) gen.gtypes
+	end;
+
 	TypeParams.RenameTypeParameters.run gen;
 
 	let t = Common.timer "code generation" in
@@ -3246,6 +3290,13 @@ let configure gen =
 
 let generate con =
 	(try
+
+		if Common.defined_value con Define.Dce = "no" then begin
+			let m = { null_module with m_id = alloc_mid(); m_path = ["haxe";"lang"],"DceNo" } in
+			let cl = mk_class m (["haxe";"lang"],"DceNo") null_pos in
+			con.types <- (TClassDecl cl) :: con.types
+		end;
+
 		let gen = new_ctx con in
 		let basic = con.basic in
 

std/cs/internal/FieldLookup.hx

@@ -34,6 +34,71 @@ package cs.internal;
 		length = fieldIds.Length;
 	}
 
+	private static function addFields(nids:cs.NativeArray<Int>, nfields:cs.NativeArray<String>):Void
+	{
+		// first see if we need to add anything
+		var cids = fieldIds,
+		    cfields = fields;
+		var nlen = nids.Length;
+		var clen = length;
+		if (nfields.Length != nlen) throw 'Different fields length: $nlen and ${nfields.Length}';
+
+		//TODO optimize
+		var needsChange = false;
+		for (i in nids)
+		{
+			if (findHash(i, cids, clen) < 0)
+			{
+				needsChange = true;
+				break;
+			}
+		}
+
+		// if we do, lock and merge
+		if (needsChange)
+		{
+			cs.Lib.lock(FieldLookup, {
+				// trace(cs.Lib.array(nids), cs.Lib.array(cids));
+				var ansIds = new cs.NativeArray(clen + nlen),
+				    ansFields = new cs.NativeArray(clen + nlen);
+				var ci = 0, ni = 0, ansi = 0;
+				while (ci < clen && ni < nlen)
+				{
+					if (cids[ci] < nids[ni])
+					{
+						ansIds[ansi] = cids[ci];
+						ansFields[ansi] = cfields[ci];
+						++ci;
+					} else {
+						ansIds[ansi] = nids[ni];
+						ansFields[ansi] = nfields[ni];
+						++ni;
+					}
+					++ansi;
+				}
+
+				if (ci < clen)
+				{
+					cs.system.Array.Copy(cids, ci, ansIds, ansi, clen - ci);
+					cs.system.Array.Copy(cfields, ci, ansFields, ansi, clen - ci);
+					ansi += clen - ci;
+				}
+
+				if (ni < nlen)
+				{
+					cs.system.Array.Copy(nids, ni, ansIds, ansi, nlen - ni);
+					cs.system.Array.Copy(nfields, ni, ansFields, ansi, nlen - ni);
+					ansi += nlen - ni;
+				}
+
+				// trace(cs.Lib.array(ansIds));
+				fieldIds = ansIds;
+				fields = ansFields;
+				length = ansi;
+			});
+		}
+	}
+
 	//s cannot be null here
 	private static inline function doHash(s:String):Int
 	{

tests/RunCi.hx

@@ -636,6 +636,10 @@ class RunCi {
 					changeDirectory("bin/cs");
 					runExe("bin/Main-Debug.exe", args);
 
+					changeDirectory(miscDir + "csTwoLibs");
+					runCommand("haxe", ["compile.hxml"]);
+					runExe("bin/main/bin/Main.exe");
+
 				case Flash9:
 					setupFlashPlayerDebugger();
 					runCommand("haxe", ["compile-flash9.hxml", "-D", "fdb"]);

tests/misc/csTwoLibs/.gitignore

@@ -0,0 +1 @@
+bin

tests/misc/csTwoLibs/Lib1.hx

@@ -0,0 +1,7 @@
+@:keep class Lib1
+{
+	public static function test()
+	{
+		return { longInexistentName:true, otherName:true, yetAnotherName:true, fdskljdflskjf:true, xxy:true };
+	}
+}

tests/misc/csTwoLibs/Main.hx

@@ -0,0 +1,21 @@
+class Main
+{
+	public static function main()
+	{
+		var asm = cs.system.reflection.Assembly.LoadFile("bin/lib1/bin/lib1.dll");
+		var tp:Dynamic = asm.GetType("Lib1");
+		var obj = tp.test();
+		trace(obj);
+		for (field in Reflect.fields(obj))
+		{
+			var val:Dynamic = Reflect.field(obj,field);
+			if (val != true)
+				throw 'Value $val for field $field';
+		}
+		var names = ["longInexistentName","otherName","yetAnotherName","fdskljdflskjf","xxy"];
+		var n2 = Reflect.fields(obj);
+		names.sort(Reflect.compare);
+		n2.sort(Reflect.compare);
+		if (names.toString() != n2.toString()) throw 'Mismatch: $names and $n2';
+	}
+}

tests/misc/csTwoLibs/compile.hxml

@@ -0,0 +1,13 @@
+cs.Boot
+-dce no
+-cs bin/haxeboot
+--next
+-net-lib bin/haxeboot/bin/haxeboot.dll
+-D dll_import
+Lib1
+-cs bin/lib1
+--next
+-net-lib bin/haxeboot/bin/haxeboot.dll
+-D dll_import
+-main Main
+-cs bin/main