From 16a6622748727118fc8d61e6cab1bfe93dc0d6ca Mon Sep 17 00:00:00 2001 From: Rudy Ges Date: Tue, 13 Feb 2024 11:54:01 +0100 Subject: [PATCH] [hxb] configurable target vs macro string pool --- src/compiler/generate.ml | 55 ++++++++++++++++++----------- src/compiler/hxb/hxbLib.ml | 12 +++++-- src/compiler/hxb/hxbWriterConfig.ml | 4 +++ src/context/common.ml | 2 +- src/typing/typeloadModule.ml | 2 +- 5 files changed, 50 insertions(+), 25 deletions(-) diff --git a/src/compiler/generate.ml b/src/compiler/generate.ml index 49dd3572aeb..66d6e5d6911 100644 --- a/src/compiler/generate.ml +++ b/src/compiler/generate.ml @@ -31,7 +31,7 @@ let create_writer com config string_pool = IO.close_out out ) -let export_hxb com config string_pool cc platform zip m = +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 @@ -39,8 +39,8 @@ let export_hxb com config string_pool cc platform zip m = 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) -> @@ -49,11 +49,12 @@ let export_hxb com config string_pool cc platform zip m = ) hxb_cache.mc_chunks; let data = IO.close_out out in zip#add_entry data path; - with Not_found -> + end else begin let writer,close = create_writer com config string_pool in HxbWriter.write_module writer m; let bytes = close () in zip#add_entry bytes path; + end end | _ -> () @@ -61,51 +62,65 @@ let export_hxb com config string_pool cc platform zip m = let check_hxb_output ctx config = let open HxbWriterConfig in let com = ctx.com in - let write_string_pool config zip pool = + 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 ("StringPool.hxb"); + 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 string_pool = StringPool.create () 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 (Some string_pool) 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.use_string_pool then Some (StringPool.create ()) else None in + if config.target_config.generate then begin + export com config.target_config string_pool; + + if config.use_string_pool && not config.share_string_pool then + write_string_pool config.target_config zip "StringPool.hxb" (Option.get string_pool) end; - (* Technically this should be a common config, but it won't be used anyway... *) - write_string_pool config.target_config zip string_pool; + + if config.macro_config.generate then begin + match com.get_macros() with + | Some mcom -> + let string_pool = if not config.share_string_pool then Some (StringPool.create ()) else string_pool in + export mcom config.macro_config string_pool; + + if config.use_string_pool && not config.share_string_pool then + write_string_pool config.macro_config zip "StringPool.macro.hxb" (Option.get string_pool) + | _ -> + () + end; + + if config.use_string_pool && config.share_string_pool then + (* Technically this should be a common config, but it won't be used anyway... *) + write_string_pool config.target_config zip "StringPool.hxb" (Option.get string_pool); ) () in try - try_write () + let from_cache = not (config.use_string_pool && config.share_string_pool && config.target_config.generate && config.macro_config.generate) in + try try_write from_cache with Abort -> try_write false with Sys_error s -> CompilationContext.error ctx (Printf.sprintf "Could not write to %s: %s" config.archive_path s) null_pos diff --git a/src/compiler/hxb/hxbLib.ml b/src/compiler/hxb/hxbLib.ml index ce675c9764d..4b52fb28d5b 100644 --- a/src/compiler/hxb/hxbLib.ml +++ b/src/compiler/hxb/hxbLib.ml @@ -11,18 +11,22 @@ class hxb_library file_path = object(self) 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"} as entry) -> + | ({ 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); - string_pool <- reader#get_string_pool + 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 @@ -56,7 +60,9 @@ class hxb_library file_path = object(self) end method get_file_path = file_path - method get_string_pool = string_pool + method get_string_pool target = + if target = "macro" && Option.is_some macro_string_pool then macro_string_pool + else string_pool end diff --git a/src/compiler/hxb/hxbWriterConfig.ml b/src/compiler/hxb/hxbWriterConfig.ml index ee5932d9afc..50a216b5577 100644 --- a/src/compiler/hxb/hxbWriterConfig.ml +++ b/src/compiler/hxb/hxbWriterConfig.ml @@ -11,6 +11,8 @@ type writer_target_config = { type t = { mutable archive_path : string; + mutable use_string_pool : bool; + mutable share_string_pool : bool; (* Note: ignored if use_string_pool = false *) target_config : writer_target_config; macro_config : writer_target_config; } @@ -25,6 +27,8 @@ let create_target_config () = { let create () = { archive_path = ""; + use_string_pool = true; (* Do we want this as default? *) + share_string_pool = false; (* Note: can't reuse hxb cache if true *) target_config = create_target_config (); macro_config = create_target_config () } diff --git a/src/context/common.ml b/src/context/common.ml index 11d7a494851..106554453e7 100644 --- a/src/context/common.ml +++ b/src/context/common.ml @@ -338,7 +338,7 @@ class virtual abstract_hxb_lib = object(self) method virtual get_bytes : string -> path -> bytes option method virtual close : unit method virtual get_file_path : string - method virtual get_string_pool : string array option + method virtual get_string_pool : string -> string array option end type context_main = { diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 41ec809c827..cfa86d6caeb 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -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 + read hxb_lib#get_file_path bytes (hxb_lib#get_string_pool target) | None -> loop l end