Skip to content

Commit

Permalink
[hxb] configurable target vs macro string pool
Browse files Browse the repository at this point in the history
  • Loading branch information
kLabz committed Feb 13, 2024
1 parent 148d64f commit 16a6622
Show file tree
Hide file tree
Showing 5 changed files with 50 additions and 25 deletions.
55 changes: 35 additions & 20 deletions src/compiler/generate.ml
Original file line number Diff line number Diff line change
Expand Up @@ -31,16 +31,16 @@ 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
(* 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) ->
Expand All @@ -49,63 +49,78 @@ 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
| _ ->
()

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

Expand Down
12 changes: 9 additions & 3 deletions src/compiler/hxb/hxbLib.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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


Expand Down
4 changes: 4 additions & 0 deletions src/compiler/hxb/hxbWriterConfig.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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;
}
Expand All @@ -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 ()
}
Expand Down
2 changes: 1 addition & 1 deletion src/context/common.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 = {
Expand Down
2 changes: 1 addition & 1 deletion src/typing/typeloadModule.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down

0 comments on commit 16a6622

Please sign in to comment.