[hxb] Implement shared string pools

src/compiler/compilationCache.ml

@@ -35,6 +35,7 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 	val files : (Path.UniqueKey.t,cached_file) Hashtbl.t = Hashtbl.create 0
 	val modules : (path,module_def) Hashtbl.t = Hashtbl.create 0
 	val 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
@@ -74,7 +75,7 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 		| MImport ->
 			Hashtbl.add modules m.m_path m
 		| _ ->
-			let writer = HxbWriter.create config warn anon_identification in
+			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 {
@@ -98,6 +99,8 @@ 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
 	method get_hxb_module path = Hashtbl.find binary_cache path
 
 	(* TODO handle hxb cache there too *)

src/compiler/generate.ml

@@ -21,16 +21,26 @@ let check_auxiliary_output com actx =
 			Genjson.generate com.types file
 	end
 
-let export_hxb com config cc platform zip m =
+let create_writer com config string_pool =
+	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
+	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 open HxbData in
 	match m.m_extra.m_kind with
 		| MCode | MMacro | MFake | MExtern -> begin
 			(* Printf.eprintf "Export module %s\n" (s_type_path m.m_path); *)
 			let l = platform :: (fst m.m_path @ [snd m.m_path]) in
 			let path = (String.concat "/" l) ^ ".hxb" in
 
-			try
-				let hxb_cache = cc#get_hxb_module m.m_path in
+			if from_cache then begin
+				let hxb_cache = try cc#get_hxb_module m.m_path with Not_found -> raise Abort in
 				let out = IO.output_string () in
 				write_header out;
 				List.iter (fun (kind,data) ->
@@ -39,56 +49,74 @@ let export_hxb com config cc platform zip m =
 				) hxb_cache.mc_chunks;
 				let data = IO.close_out out in
 				zip#add_entry data path;
-			with Not_found ->
-				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 warn anon_identification in
+			end else begin
+				let writer,close = create_writer com config string_pool in
 				HxbWriter.write_module writer m;
-				let out = IO.output_string () in
-				HxbWriter.export writer out;
-				zip#add_entry (IO.close_out out) path;
+				let bytes = close () in
+				zip#add_entry bytes path;
+			end
 		end
 	| _ ->
 		()
 
 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
-	let try_write () =
+	let try_write from_cache =
 		let path = config.HxbWriterConfig.archive_path in
 		let path = Str.global_replace (Str.regexp "\\$target") (platform_name ctx.com.platform) path in
 		let t = Timer.timer ["generate";"hxb"] in
 		Path.mkdir_from_path path;
 		let zip = new Zip_output.zip_output path 6 in
-		let export com config =
+		let export com config string_pool =
 			let cc = CommonCache.get_cache com in
 			let target = Common.platform_name_macro com in
+
 			List.iter (fun m ->
 				let t = Timer.timer ["generate";"hxb";s_type_path m.m_path] in
 				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
-					Std.finally t (export_hxb com config cc target zip) m
+					Std.finally t (export_hxb from_cache com config string_pool cc target zip) m
 			) com.modules;
 		in
 		Std.finally (fun () ->
 			zip#close;
 			t()
 		) (fun () ->
-			if  config.target_config.generate then
-				export com config.target_config;
-			begin match com.get_macros() with
-				| Some mcom when config.macro_config.generate ->
-					export mcom config.macro_config
-				| _ ->
-					()
+			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;
+			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)
+					| _ ->
+						()
 			end;
+
+			if config.share_string_pool then
+				write_string_pool config.target_config zip "StringPool.hxb" (Option.get string_pool);
 		) ()
 	in
 	try
-		try_write ()
+		(* This Abort case shouldn't happen, unless some modules are not stored in hxb cache (which should not be the case currently) *)
+		if ctx.comm.is_server then try try_write true with Abort -> try_write false
+		else try_write false
 	with Sys_error s ->
 		CompilationContext.error ctx (Printf.sprintf "Could not write to %s: %s" config.archive_path s) null_pos
 

src/compiler/hxb/hxbLib.ml

@@ -10,12 +10,23 @@ class hxb_library file_path = object(self)
 	val modules = Hashtbl.create 0
 	val mutable closed = false
 	val mutable loaded = false
+	val mutable string_pool : string array option = None
+	val mutable macro_string_pool : string array option = None
 
 	method load =
 		if not loaded then begin
 			loaded <- true;
 			let close = Timer.timer ["hxblib";"read"] in
 			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 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
@@ -49,6 +60,9 @@ class hxb_library file_path = object(self)
 		end
 
 	method get_file_path = file_path
+	method get_string_pool target =
+		if target = "macro" && Option.is_some macro_string_pool then macro_string_pool
+		else string_pool
 end
 
 

src/compiler/hxb/hxbReader.ml

@@ -148,12 +148,14 @@ let dump_stats name stats =
 class hxb_reader
 	(mpath : path)
 	(stats : hxb_reader_stats)
+	(string_pool : string array option)
 = object(self)
 	val mutable api = Obj.magic ""
 	val mutable current_module = null_module
 
 	val mutable ch = BytesWithPosition.create (Bytes.create 0)
-	val mutable string_pool = Array.make 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 doc_pool = Array.make 0 ""
 
 	val mutable classes = Array.make 0 null_class
@@ -180,6 +182,12 @@ 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
+
 	(* Primitives *)
 
 	method read_i32 =
@@ -1924,9 +1932,11 @@ 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;
 		| MTF ->
 			current_module.m_types <- self#read_mtf;

src/compiler/hxb/hxbReaderApi.ml

@@ -10,3 +10,15 @@ class virtual hxb_reader_api = object(self)
 	method virtual get_var_id : int -> int
 	method virtual read_expression_eagerly : tclass_field -> bool
 end
+
+class hxb_reader_api_null = object(self)
+	inherit hxb_reader_api
+
+	method make_module _ = assert false
+	method add_module _ = assert false
+	method resolve_type _ _ _ = assert false
+	method resolve_module _ = assert false
+	method basic_types = assert false
+	method get_var_id _ = assert false
+	method read_expression_eagerly _ = assert false
+end

src/compiler/hxb/hxbWriter.ml

@@ -56,41 +56,6 @@ module StringHashtbl = Hashtbl.Make(struct
 		Hashtbl.hash s
 end)
 
-module StringPool = struct
-	type t = {
-		lut : int StringHashtbl.t;
-		items : string DynArray.t;
-		mutable closed : bool;
-	}
-
-	let create () = {
-		lut = StringHashtbl.create 16;
-		items = DynArray.create ();
-		closed = false;
-	}
-
-	let add sp s =
-		assert (not sp.closed);
-		let index = DynArray.length sp.items in
-		StringHashtbl.add sp.lut s index;
-		DynArray.add sp.items s;
-		index
-
-	let get sp s =
-		StringHashtbl.find sp.lut s
-
-	let get_or_add sp s =
-		try
-			get sp s
-		with Not_found ->
-			add sp s
-
-	let finalize sp =
-		assert (not sp.closed);
-		sp.closed <- true;
-		DynArray.to_list sp.items,DynArray.length sp.items
-end
-
 module Pool = struct
 	type ('key,'value) t = {
 		lut : ('key,int) Hashtbl.t;
@@ -445,6 +410,7 @@ type hxb_writer = {
 	anon_id : Type.t Tanon_identification.tanon_identification;
 	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;
@@ -1780,11 +1746,11 @@ module HxbWriter = struct
 					write_type_parameters writer ltp
 				end;
 				Chunk.write_option writer.chunk fctx.texpr_this (fun e -> write_type_instance writer e.etype);
-				let items,length = StringPool.finalize fctx.t_pool in
-				Chunk.write_uleb128 writer.chunk length;
-				List.iter (fun bytes ->
+				let a = StringPool.finalize fctx.t_pool in
+				Chunk.write_uleb128 writer.chunk a.length;
+				StringDynArray.iter a (fun bytes ->
 					Chunk.write_bytes writer.chunk (Bytes.unsafe_of_string bytes)
-				) items;
+				);
 				Chunk.write_uleb128 writer.chunk (DynArray.length fctx.vars);
 				DynArray.iter (fun (v,v_id) ->
 					v.v_id <- v_id;
@@ -2050,6 +2016,14 @@ module HxbWriter = struct
 		| TTypeDecl t ->
 			()
 
+	let write_string_pool writer kind a =
+		start_chunk writer kind;
+		Chunk.write_uleb128 writer.chunk a.StringDynArray.length;
+		StringDynArray.iter a (fun s ->
+			let b = Bytes.unsafe_of_string s in
+			Chunk.write_bytes_length_prefixed writer.chunk b;
+		)
+
 	let write_module writer (m : module_def) =
 		writer.current_module <- m;
 
@@ -2270,22 +2244,14 @@ module HxbWriter = struct
 		start_chunk writer EOF;
 		start_chunk writer EOM;
 
-		let finalize_string_pool kind items length =
-			start_chunk writer kind;
-			Chunk.write_uleb128 writer.chunk length;
-			List.iter (fun s ->
-				let b = Bytes.unsafe_of_string s in
-				Chunk.write_bytes_length_prefixed writer.chunk b;
-			) items
-		in
-		begin
-			let items,length = StringPool.finalize writer.cp in
-			finalize_string_pool STR items length
+		if writer.has_own_string_pool then begin
+			let a = StringPool.finalize writer.cp in
+			write_string_pool writer STR a
 		end;
 		begin
-			let items,length = StringPool.finalize writer.docs in
-			if length > 0 then
-				finalize_string_pool DOC items length
+			let a = StringPool.finalize writer.docs in
+			if a.length > 0 then
+				write_string_pool writer DOC a
 		end
 
 	let get_sorted_chunks writer =
@@ -2296,15 +2262,21 @@ module HxbWriter = struct
 		l
 end
 
-let create config warn anon_id =
-	let cp = StringPool.create () in
+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
 	{
 		config;
 		warn;
 		anon_id;
 		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,6 +11,7 @@ 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;
 }
@@ -25,6 +26,7 @@ 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 ()
 }
@@ -115,4 +117,4 @@ let process_argument file =
 		| _ ->
 			config.archive_path <- file;
 	end;
-	Some config
+	Some config