make hxb-writer thread-safe (#12099)

src/compiler/compilationCache.ml

@@ -36,7 +36,6 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 	val modules : (path,module_def) Hashtbl.t = Hashtbl.create 0
 	val binary_cache : (path,HxbData.module_cache) Hashtbl.t = Hashtbl.create 0
 	val tmp_binary_cache : (path,HxbData.module_cache) Hashtbl.t = Hashtbl.create 0
-	val string_pool  = StringPool.create ()
 	val removed_files = Hashtbl.create 0
 	val mutable json = JNull
 	val mutable initialized = false
@@ -81,20 +80,25 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 		try (Hashtbl.find modules path).m_extra
 		with Not_found -> (self#get_hxb_module path).mc_extra
 
-	method cache_hxb_module config warn anon_identification path m =
+	method add_binary_cache m chunks =
+		Hashtbl.replace binary_cache m.m_path {
+			mc_path = m.m_path;
+			mc_id = m.m_id;
+			mc_chunks = chunks;
+			mc_extra = { m.m_extra with m_cache_state = MSGood; m_display_deps = None }
+		}
+
+	method cache_hxb_module config warn anon_identification m =
 		match m.m_extra.m_kind with
 		| MImport ->
-			Hashtbl.add modules m.m_path m
+			Hashtbl.add modules m.m_path m;
+			None
 		| _ ->
-			let writer = HxbWriter.create config (Some string_pool) warn anon_identification in
-			HxbWriter.write_module writer m;
-			let chunks = HxbWriter.get_chunks writer in
-			Hashtbl.replace binary_cache path {
-				mc_path = path;
-				mc_id = m.m_id;
-				mc_chunks = chunks;
-				mc_extra = { m.m_extra with m_cache_state = MSGood; m_display_deps = None }
-			}
+			Some (fun () ->
+				let writer = HxbWriter.create config warn anon_identification in
+				HxbWriter.write_module writer m;
+				HxbWriter.get_chunks writer
+			)
 
 	method cache_module_in_memory path m =
 		Hashtbl.replace modules path m
@@ -117,8 +121,6 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 	method get_modules = modules
 
 	method get_hxb = binary_cache
-	method get_string_pool = string_pool
-	method get_string_pool_arr = string_pool.items.arr
 
 	(* TODO handle hxb cache there too *)
 	method get_removed_files = removed_files

src/compiler/generate.ml

@@ -21,17 +21,17 @@ let check_auxiliary_output com actx =
 			Genjson.generate com.timer_ctx com.types file
 	end
 
-let create_writer com config string_pool =
+let create_writer com config =
 	let anon_identification = new tanon_identification in
 	let warn w s p = com.Common.warning w com.warning_options s p in
-	let writer = HxbWriter.create config string_pool warn anon_identification in
+	let writer = HxbWriter.create config warn anon_identification in
 	writer,(fun () ->
 		let out = IO.output_string () in
 		HxbWriter.export writer out;
 		IO.close_out out
 	)
 
-let export_hxb from_cache com config string_pool cc platform zip m =
+let export_hxb from_cache com config cc platform m =
 	let open HxbData in
 	match m.m_extra.m_kind with
 		| MCode | MMacro | MFake | MExtern -> begin
@@ -48,27 +48,20 @@ let export_hxb from_cache com config string_pool cc platform zip m =
 					IO.nwrite out data
 				) hxb_cache.mc_chunks;
 				let data = IO.close_out out in
-				zip#add_entry data path;
+				Some (path,data)
 			end else begin
-				let writer,close = create_writer com config string_pool in
+				let writer,close = create_writer com config in
 				HxbWriter.write_module writer m;
 				let bytes = close () in
-				zip#add_entry bytes path;
+				Some (path,bytes)
 			end
 		end
 	| _ ->
-		()
+		None
 
 let check_hxb_output ctx config =
 	let open HxbWriterConfig in
 	let com = ctx.com in
-	let write_string_pool config zip name pool =
-		let writer,close = create_writer com config (Some pool) in
-		let a = StringPool.finalize writer.cp in
-		HxbWriter.HxbWriter.write_string_pool writer STR a;
-		let bytes = close () in
-		zip#add_entry bytes name;
-	in
 	let match_path_list l sl_path =
 		List.exists (fun sl -> Ast.match_path true sl_path sl) l
 	in
@@ -78,38 +71,42 @@ let check_hxb_output ctx config =
 		let t = Timer.start_timer ctx.timer_ctx ["generate";"hxb"] in
 		Path.mkdir_from_path path;
 		let zip = new Zip_output.zip_output path 6 in
-		let export com config string_pool =
+		let export com config =
 			let cc = CommonCache.get_cache com in
 			let target = Common.platform_name_macro com in
-
-			List.iter (fun m ->
+			let f m =
 				let sl_path = fst m.m_path @ [snd m.m_path] in
 				if not (match_path_list config.exclude sl_path) || match_path_list config.include' sl_path then
-					Timer.time ctx.timer_ctx ["generate";"hxb";s_type_path m.m_path] (export_hxb from_cache com config string_pool cc target zip) m
-			) com.modules;
+					Timer.time ctx.timer_ctx ["generate";"hxb";s_type_path m.m_path] (export_hxb from_cache com config cc target) m
+				else
+					None
+			in
+			let a_in = Array.of_list com.modules in
+			let a_out = Parallel.run_in_new_pool com.timer_ctx (fun pool ->
+				Parallel.ParallelArray.map pool f a_in None
+			) in
+			Array.iter (function
+				| None ->
+					()
+				| Some(path,bytes) ->
+					zip#add_entry bytes path
+			) a_out
 		in
 		Std.finally (fun () ->
 			zip#close;
 			t()
 		) (fun () ->
-			let string_pool = if config.share_string_pool then Some (StringPool.create ()) else None in
 			if config.target_config.generate then begin
-				export com config.target_config string_pool;
+				export com config.target_config
 			end;
 
 			if config.macro_config.generate then begin
 				match com.get_macros() with
 					| Some mcom ->
-						let use_separate_pool = config.share_string_pool && from_cache in
-						let string_pool = if use_separate_pool then Some (StringPool.create ()) else string_pool in
-						export mcom config.macro_config string_pool;
-						if use_separate_pool then write_string_pool config.macro_config zip "StringPool.macro.hxb" (Option.get string_pool)
+						export mcom config.macro_config;
 					| _ ->
 						()
 			end;
-
-			if config.share_string_pool then
-				write_string_pool config.target_config zip "StringPool.hxb" (Option.get string_pool);
 		) ()
 	in
 	try

src/compiler/hxb/hxbLib.ml

@@ -15,15 +15,6 @@ class hxb_library timer_ctx file_path hxb_times = object(self)
 
 	method private do_load =
 		List.iter (function
-		| ({ Zip.filename = "StringPool.hxb" | "StringPool.macro.hxb" as filename} as entry) ->
-			let reader = new HxbReader.hxb_reader (["hxb";"internal"],"StringPool") (HxbReader.create_hxb_reader_stats()) None hxb_times in
-			let zip = Lazy.force zip in
-			let data = Bytes.unsafe_of_string (Zip.read_entry zip entry) in
-			ignore(reader#read (new HxbReaderApi.hxb_reader_api_null) data STR);
-			if filename = "StringPool.hxb" then
-				string_pool <- reader#get_string_pool
-			else
-				macro_string_pool <- reader#get_string_pool
 		| ({ Zip.is_directory = false; Zip.filename = filename } as entry) when String.ends_with filename ".hxb" ->
 			let pack = String.nsplit filename "/" in
 			begin match List.rev pack with

src/compiler/hxb/hxbReader.ml

@@ -148,7 +148,6 @@ let dump_stats name stats =
 class hxb_reader
 	(mpath : path)
 	(stats : hxb_reader_stats)
-	(string_pool : string array option)
 	(timer_ctx : Timer.timer_context option)
 = object(self)
 	val mutable api = Obj.magic ""
@@ -156,8 +155,7 @@ class hxb_reader
 	val mutable current_module = null_module
 
 	val mutable ch = BytesWithPosition.create (Bytes.create 0)
-	val mutable has_string_pool = (string_pool <> None)
-	val mutable string_pool = (match string_pool with None -> Array.make 0 "" | Some pool -> pool)
+	val mutable string_pool = Array.make 0 ""
 	val mutable doc_pool = Array.make 0 ""
 
 	val mutable classes = Array.make 0 (Lazy.from_val null_class)
@@ -190,12 +188,6 @@ class hxb_reader
 			dump_backtrace();
 			error (Printf.sprintf "[HXB] [%s] Cannot resolve type %s" (s_type_path current_module.m_path) (s_type_path ((pack @ [mname]),tname)))
 
-	method get_string_pool =
-		if has_string_pool then
-			Some (string_pool)
-		else
-			None
-
 	method make_lazy_type_dynamic f : Type.t =
 		api#make_lazy_type t_dynamic f
 
@@ -2015,11 +2007,9 @@ class hxb_reader
 		match kind with
 		| STR ->
 			string_pool <- self#read_string_pool;
-			has_string_pool <- true;
 		| DOC ->
 			doc_pool <- self#read_string_pool;
 		| MDF ->
-			assert(has_string_pool);
 			current_module <- self#read_mdf;
 			incr stats.modules_partially_restored;
 			if not full_restore then current_module.m_extra.m_display_deps <- Some PMap.empty

src/compiler/hxb/hxbWriter.ml

@@ -397,9 +397,9 @@ type hxb_writer = {
 	config : HxbWriterConfig.writer_target_config;
 	warn : Warning.warning -> string -> Globals.pos -> unit;
 	anon_id : Type.t Tanon_identification.tanon_identification;
+	identified_anons : (tanon,int) IdentityPool.t;
 	mutable current_module : module_def;
 	chunks : Chunk.t DynArray.t;
-	has_own_string_pool : bool;
 	cp : StringPool.t;
 	docs : StringPool.t;
 	mutable chunk : Chunk.t;
@@ -1006,26 +1006,33 @@ module HxbWriter = struct
 		end
 
 	and write_anon_ref writer (an : tanon) =
-		let pfm = writer.anon_id#identify_anon ~strict:true an in
 		try
-			let index = Pool.get writer.anons pfm.pfm_path in
+			let index = IdentityPool.get writer.identified_anons an in
 			Chunk.write_u8 writer.chunk 0;
 			Chunk.write_uleb128 writer.chunk index
 		with Not_found ->
-			let restore = start_temporary_chunk writer 256 in
-			writer.needs_local_context <- false;
-			write_anon writer an;
-			let bytes = restore (fun new_chunk -> Chunk.get_bytes new_chunk) in
-			if writer.needs_local_context then begin
-				let index = Pool.add writer.anons pfm.pfm_path None in
-				Chunk.write_u8 writer.chunk 1;
-				Chunk.write_uleb128 writer.chunk index;
-				Chunk.write_bytes writer.chunk bytes
-			end else begin
-				let index = Pool.add writer.anons pfm.pfm_path (Some bytes) in
+			let pfm = writer.anon_id#identify_anon ~strict:true an in
+			try
+				let index = Pool.get writer.anons pfm.pfm_path in
 				Chunk.write_u8 writer.chunk 0;
-				Chunk.write_uleb128 writer.chunk index;
-			end
+				Chunk.write_uleb128 writer.chunk index
+			with Not_found ->
+				let restore = start_temporary_chunk writer 256 in
+				writer.needs_local_context <- false;
+				write_anon writer an;
+				let bytes = restore (fun new_chunk -> Chunk.get_bytes new_chunk) in
+				if writer.needs_local_context then begin
+					let index = Pool.add writer.anons pfm.pfm_path None in
+					ignore(IdentityPool.add writer.identified_anons an index);
+					Chunk.write_u8 writer.chunk 1;
+					Chunk.write_uleb128 writer.chunk index;
+					Chunk.write_bytes writer.chunk bytes
+				end else begin
+					let index = Pool.add writer.anons pfm.pfm_path (Some bytes) in
+					ignore(IdentityPool.add writer.identified_anons an index);
+					Chunk.write_u8 writer.chunk 0;
+					Chunk.write_uleb128 writer.chunk index;
+				end
 
 	and write_anon_field_ref writer cf =
 		try
@@ -2246,10 +2253,8 @@ module HxbWriter = struct
 		start_chunk writer EOF;
 		start_chunk writer EOM;
 
-		if writer.has_own_string_pool then begin
-			let a = StringPool.finalize writer.cp in
-			write_string_pool writer STR a
-		end;
+		let a = StringPool.finalize writer.cp in
+		write_string_pool writer STR a;
 		begin
 			let a = StringPool.finalize writer.docs in
 			if a.length > 0 then
@@ -2264,21 +2269,16 @@ module HxbWriter = struct
 		l
 end
 
-let create config string_pool warn anon_id =
-	let cp,has_own_string_pool = match string_pool with
-		| None ->
-			StringPool.create(),true
-		| Some pool ->
-			pool,false
-	in
+let create config warn anon_id =
+	let cp = StringPool.create() in
 	{
 		config;
 		warn;
 		anon_id;
+		identified_anons = IdentityPool.create();
 		current_module = null_module;
 		chunks = DynArray.create ();
 		cp = cp;
-		has_own_string_pool;
 		docs = StringPool.create ();
 		chunk = Obj.magic ();
 		classes = Pool.create ();

src/compiler/hxb/hxbWriterConfig.ml

@@ -11,7 +11,6 @@ type writer_target_config = {
 
 type t = {
 	mutable archive_path : string;
-	mutable share_string_pool : bool;
 	target_config : writer_target_config;
 	macro_config : writer_target_config;
 }
@@ -26,7 +25,6 @@ let create_target_config () = {
 
 let create () = {
 	archive_path = "";
-	share_string_pool = true; (* Do we want this as default? *)
 	target_config = create_target_config ();
 	macro_config = create_target_config ()
 }

src/compiler/server.ml

@@ -435,7 +435,7 @@ class hxb_reader_api_server
 		| GoodModule m ->
 			m
 		| BinaryModule mc ->
-			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats (Some cc#get_string_pool_arr) (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
+			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
 			let full_restore = full_typing com mc.mc_extra in
 			let f_next chunks until =
 				let macro = if com.is_macro_context then " (macro)" else "" in
@@ -572,7 +572,7 @@ and type_module sctx com delay mpath p =
 			   checking dependencies. This means that the actual decoding never has any reason to fail. *)
 			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) (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
+					let reader = new HxbReader.hxb_reader mpath com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
 					let full_restore = full_typing com mc.mc_extra in
 					let api = match com.hxb_reader_api with
 						| Some api ->

src/context/commonCache.ml

@@ -85,14 +85,12 @@ let rec cache_context cs com =
 	let cc = get_cache com in
 	let sign = Define.get_signature com.defines in
 
-	let cache_module =
+	let parallels = DynArray.create () in
+	let cache_module m =
 		if Define.defined com.defines DisableHxbCache then
-			let cache_module m =
-				(* If we have a signature mismatch, look-up cache for module. Physical equality check is fine as a heuristic. *)
-				let cc = if m.m_extra.m_sign = sign then cc else cs#get_context m.m_extra.m_sign in
-				cc#cache_module_in_memory m.m_path m;
-			in
-			cache_module
+			(* If we have a signature mismatch, look-up cache for module. Physical equality check is fine as a heuristic. *)
+			let cc = if m.m_extra.m_sign = sign then cc else cs#get_context m.m_extra.m_sign in
+			cc#cache_module_in_memory m.m_path m;
 		else
 			let anon_identification = new Tanon_identification.tanon_identification in
 			let warn w s p = com.warning w com.warning_options s p in
@@ -102,15 +100,24 @@ let rec cache_context cs com =
 				| Some config ->
 					if com.is_macro_context then config.macro_config else config.target_config
 			in
-			let cache_module m =
-				(* If we have a signature mismatch, look-up cache for module. Physical equality check is fine as a heuristic. *)
-				let cc = if m.m_extra.m_sign = sign then cc else cs#get_context m.m_extra.m_sign in
-				cc#cache_hxb_module config warn anon_identification m.m_path m;
-			in
-			cache_module
+			(* If we have a signature mismatch, look-up cache for module. Physical equality check is fine as a heuristic. *)
+			let cc = if m.m_extra.m_sign = sign then cc else cs#get_context m.m_extra.m_sign in
+			match cc#cache_hxb_module config warn anon_identification m with
+			| None ->
+				()
+			| Some f ->
+				DynArray.add parallels (cc,m,f)
 	in
-
 	List.iter cache_module com.modules;
+	let a = Parallel.run_in_new_pool com.timer_ctx (fun pool ->
+		Parallel.ParallelArray.map pool (fun (cc,m,f) ->
+			let chunks = f() in
+			(cc,m,chunks)
+		) (DynArray.to_array parallels) (cc,null_module,[])
+	) in
+	Array.iter (fun (cc,m,chunks) ->
+		cc#add_binary_cache m chunks
+	) a;
 	begin match com.get_macros() with
 		| None -> ()
 		| Some com -> cache_context cs com

src/context/display/displayJson.ml

@@ -139,7 +139,7 @@ class hxb_reader_api_com
 			cc#find_module m_path
 		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) (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
+			let reader = new HxbReader.hxb_reader mc.mc_path com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
 			fst (reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) mc.mc_chunks (if full_restore then EOM else MTF) full_restore)
 
 	method basic_types =

src/context/display/displayTexpr.ml

@@ -178,7 +178,7 @@ let check_display_file ctx cs =
 				| NoModule | BadModule _ -> raise Not_found
 				| BinaryModule mc ->
 					let api = (new TypeloadModule.hxb_reader_api_typeload ctx.com ctx.g TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in
-					let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats (Some cc#get_string_pool_arr) (if Common.defined ctx.com Define.HxbTimes then Some ctx.com.timer_ctx else None) in
+					let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats (if Common.defined ctx.com Define.HxbTimes then Some ctx.com.timer_ctx else None) in
 					let m = reader#read_chunks api mc.mc_chunks in
 					m
 				| GoodModule m ->

src/context/parallel.ml

@@ -7,6 +7,15 @@ module ParallelArray = struct
 	let iter pool f a =
 		let f' idx = f a.(idx) in
 		Domainslib.Task.run pool (fun _ -> Domainslib.Task.parallel_for pool ~start:0 ~finish:(Array.length a - 1) ~body:f')
+
+	let map pool f a x =
+		let length = Array.length a in
+		let a_out = Array.make length x in
+		let f' idx =
+			Array.unsafe_set a_out idx (f (Array.unsafe_get a idx))
+		in
+		Domainslib.Task.run pool (fun _ -> Domainslib.Task.parallel_for pool ~start:0 ~finish:(length - 1) ~body:f');
+		a_out
 end
 
 module ParallelSeq = struct

src/typing/typeloadModule.ml

@@ -774,10 +774,10 @@ class hxb_reader_api_typeload
 end
 
 let rec load_hxb_module com g path p =
-	let read file bytes string_pool =
+	let read file bytes =
 		try
 			let api = (new hxb_reader_api_typeload com g load_module' p :> HxbReaderApi.hxb_reader_api) in
-			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats string_pool (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
+			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
 			let read = reader#read api bytes in
 			let m = read EOT in
 			delay g PConnectField (fun () ->
@@ -795,7 +795,7 @@ let rec load_hxb_module com g path p =
 		| hxb_lib :: l ->
 			begin match hxb_lib#get_bytes target path with
 				| Some bytes ->
-					read hxb_lib#get_file_path bytes (hxb_lib#get_string_pool target)
+					read hxb_lib#get_file_path bytes
 				| None ->
 					loop l
 			end