forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Fix #require for packages sharing a directory (e.g. compiler-libs)
When multiple findlib packages share a single directory (like
compiler-libs.common, .bytecomp, .optcomp, .toplevel), the old
directory-wide preload check would see all CMIs from all packages
and incorrectly report "partially loaded" — then try to reload
archives that were already linked, crashing with "file already exists".
Fix: use ocamlobjinfo at build time to extract per-CMA unit lists,
embed them in dynamic_cmis.json, and check only the relevant archive's
units at runtime before deciding whether to load its .cma.js.
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
+116
-17
+60
-7
js_top_worker/bin/jtw.ml
+60
-7
js_top_worker/bin/jtw.ml
···
1
-
let dynamic_cmis_to_json (dcs : Js_top_worker.Impl.dynamic_cmis) =
2
-
`Assoc [
1
+
let dynamic_cmis_to_json ~cma_units (dcs : Js_top_worker.Impl.dynamic_cmis) =
2
+
let base = [
3
3
("dcs_url", `String dcs.dcs_url);
4
4
("dcs_toplevel_modules", `List (List.map (fun s -> `String s) dcs.dcs_toplevel_modules));
5
5
("dcs_file_prefixes", `List (List.map (fun s -> `String s) dcs.dcs_file_prefixes));
6
6
("dcs_module_crcs", `Assoc (List.map (fun (k, v) -> (k, `String v)) dcs.dcs_module_crcs));
7
-
]
7
+
] in
8
+
let fields = match cma_units with
9
+
| [] -> base
10
+
| units ->
11
+
let cma_units_json = `Assoc (List.map (fun (archive, mods) ->
12
+
(archive, `List (List.map (fun m -> `String m) mods))) units)
13
+
in
14
+
base @ [("cma_units", cma_units_json)]
15
+
in
16
+
`Assoc fields
8
17
9
18
(** Read the self-CRC from a .cmi file. Returns the hex digest of the
10
19
compilation unit's interface, or None if the file can't be read. *)
···
52
61
end else
53
62
rel
54
63
64
+
(** Extract implementation unit names from a .cma archive using ocamlobjinfo. *)
65
+
let cma_unit_names ?switch archive =
66
+
let base_cmd = match switch with
67
+
| None -> Bos.Cmd.(v "ocamlobjinfo")
68
+
| Some s -> Bos.Cmd.(v "opam" % "exec" % "--switch" % s % "--" % "ocamlobjinfo")
69
+
in
70
+
let cmd = Bos.Cmd.(base_cmd % Fpath.to_string archive) in
71
+
let lines = Util.lines_of_process cmd in
72
+
List.filter_map (fun line ->
73
+
match Astring.String.cut ~sep:"Unit name: " line with
74
+
| Some ("", name) -> Some (String.trim name)
75
+
| _ -> None)
76
+
lines
77
+
78
+
(** Per-directory CMA unit names, collected during archive compilation
79
+
and embedded into dynamic_cmis.json. Maps source directory path to
80
+
a list of (archive_basename, unit_names) pairs. *)
81
+
let cma_units_by_dir : (string, (string * string list) list) Hashtbl.t =
82
+
Hashtbl.create 16
83
+
84
+
let record_cma_units dir archive_basename units =
85
+
let key = Fpath.to_string dir in
86
+
let existing = match Hashtbl.find_opt cma_units_by_dir key with
87
+
| Some l -> l
88
+
| None -> []
89
+
in
90
+
Hashtbl.replace cma_units_by_dir key ((archive_basename, units) :: existing)
91
+
55
92
let cmi_files dir =
56
93
Bos.OS.Dir.fold_contents ~traverse:`None ~elements:`Files
57
94
(fun path acc ->
···
89
126
dcs_toplevel_modules = toplevel_modules;
90
127
dcs_file_prefixes = prefixes;
91
128
dcs_module_crcs = read_module_crcs dir toplevel_modules;
129
+
dcs_cma_units = [];
92
130
}
93
131
in
132
+
let cma_units = match Hashtbl.find_opt cma_units_by_dir (Fpath.to_string dir) with
133
+
| Some units -> units
134
+
| None -> []
135
+
in
94
136
( dir,
95
-
Yojson.Safe.to_string (dynamic_cmis_to_json dcs) )
137
+
Yojson.Safe.to_string (dynamic_cmis_to_json ~cma_units dcs) )
96
138
in
97
139
List.map gen_one cmis
98
140
···
302
344
let cmd =
303
345
Bos.Cmd.(cmd % Fpath.to_string archive % "-o" % Fpath.to_string output)
304
346
in
305
-
ignore (Util.lines_of_process cmd)
347
+
ignore (Util.lines_of_process cmd);
348
+
(* Record CMA unit names for embedding in dynamic_cmis.json *)
349
+
let units = cma_unit_names ?switch archive in
350
+
record_cma_units dir (Fpath.filename archive) units
306
351
in
307
352
List.iter compile_archive archives)
308
353
all_libs)
···
410
455
let cmd = Bos.Cmd.(base_cmd % "compile" % "--toplevel" % "--include-runtime" % "--effects=disabled") in
411
456
let cmd = List.fold_left (fun c f -> Bos.Cmd.(c % f)) cmd js_files in
412
457
let cmd = Bos.Cmd.(cmd % Fpath.to_string archive % "-o" % Fpath.to_string output) in
413
-
ignore (Util.lines_of_process cmd))
458
+
ignore (Util.lines_of_process cmd);
459
+
(* Record CMA unit names for embedding in dynamic_cmis.json *)
460
+
let units = cma_unit_names ?switch archive in
461
+
record_cma_units lib_dir (Fpath.filename archive) units)
414
462
archives)
415
463
all_libs;
416
464
···
433
481
dcs_toplevel_modules = toplevel_modules;
434
482
dcs_file_prefixes = prefixes;
435
483
dcs_module_crcs = read_module_crcs dir toplevel_modules;
484
+
dcs_cma_units = [];
436
485
} in
437
-
let dcs_json = Yojson.Safe.to_string (dynamic_cmis_to_json dcs) in
486
+
let cma_units = match Hashtbl.find_opt cma_units_by_dir (Fpath.to_string dir) with
487
+
| Some units -> units
488
+
| None -> []
489
+
in
490
+
let dcs_json = Yojson.Safe.to_string (dynamic_cmis_to_json ~cma_units dcs) in
438
491
let dcs_dir = Fpath.(pkg_output_dir / "lib" // d) in
439
492
let _ = Bos.OS.Dir.create ~path:true dcs_dir in
440
493
let oc = open_out Fpath.(dcs_dir / "dynamic_cmis.json" |> to_string) in
+50
-9
js_top_worker/lib/findlibish.ml
+50
-9
js_top_worker/lib/findlibish.ml
···
92
92
"Package preloaded but CRC mismatch: %s"
93
93
(String.concat ", " ms)))
94
94
95
+
(** Check if the implementation units from a specific CMA archive are already
96
+
loaded in the toplevel. This is more precise than is_package_preloaded
97
+
because it checks only the units in the actual archive, not all CMIs
98
+
in the directory (which may contain units from other findlib packages). *)
99
+
let is_cma_preloaded units =
100
+
match units with
101
+
| [] -> false
102
+
| _ -> List.for_all is_module_available units
103
+
95
104
let rec read_libraries_from_pkg_defs ~library_name ~dir meta_uri pkg_expr =
96
105
try
97
106
Jslib.log "Reading library: %s" library_name;
···
184
193
match v with `String s -> Some (k, s) | _ -> None) pairs
185
194
| _ -> []
186
195
in
196
+
let dcs_cma_units =
197
+
match json |> member "cma_units" with
198
+
| `Assoc pairs ->
199
+
List.filter_map (fun (k, v) ->
200
+
match v with
201
+
| `List units ->
202
+
Some (k, List.filter_map (fun u ->
203
+
match u with `String s -> Some s | _ -> None) units)
204
+
| _ -> None) pairs
205
+
| _ -> []
206
+
in
187
207
Ok { Js_top_worker.Impl.dcs_url; dcs_toplevel_modules; dcs_file_prefixes;
188
-
dcs_module_crcs }
208
+
dcs_module_crcs; dcs_cma_units }
189
209
with e ->
190
210
Error (`Msg (Printf.sprintf "Failed to parse dynamic_cmis JSON: %s" (Printexc.to_string e))))
191
211
···
374
394
Jslib.log "uri: %s" (Uri.to_string uri);
375
395
match fetch_dynamic_cmis sync_get (Uri.to_string uri) with
376
396
| Ok dcs ->
377
-
let should_load =
378
-
(not (is_package_preloaded dcs)) && not cmi_only
379
-
in
397
+
(* Check whether to load the .cma.js archive.
398
+
We use per-archive unit lists (from .units.json) rather than
399
+
the directory-wide dynamic_cmis.json, because multiple findlib
400
+
packages may share a directory (e.g., compiler-libs.common and
401
+
compiler-libs.optcomp both live in compiler-libs/). *)
380
402
Option.iter
381
403
(fun archive ->
382
-
if should_load then begin
383
-
let archive_js =
384
-
Fpath.(dir / (archive ^ ".cma.js") |> to_string)
404
+
if not cmi_only then begin
405
+
let cma_name = archive ^ ".cma" in
406
+
let already_loaded =
407
+
match List.assoc_opt cma_name dcs.dcs_cma_units with
408
+
| Some units ->
409
+
let preloaded = is_cma_preloaded units in
410
+
if preloaded then
411
+
Jslib.log "Archive %s already preloaded (%d units), skipping"
412
+
cma_name (List.length units)
413
+
else
414
+
Jslib.log "Archive %s not preloaded, loading %d units"
415
+
cma_name (List.length units);
416
+
preloaded
417
+
| None ->
418
+
(* No cma_units in dynamic_cmis.json — fall back to directory-wide check *)
419
+
Jslib.log "No cma_units for %s, falling back to directory check" cma_name;
420
+
is_package_preloaded dcs
385
421
in
386
-
import_scripts
387
-
[ Uri.with_path uri archive_js |> Uri.to_string ]
422
+
if not already_loaded then begin
423
+
let archive_js =
424
+
Fpath.(dir / (archive ^ ".cma.js") |> to_string)
425
+
in
426
+
import_scripts
427
+
[ Uri.with_path uri archive_js |> Uri.to_string ]
428
+
end
388
429
end)
389
430
lib.archive_name;
390
431
lib.loaded <- true;
+4
js_top_worker/lib/impl.cppo.ml
+4
js_top_worker/lib/impl.cppo.ml
···
46
46
dcs_toplevel_modules : string list;
47
47
dcs_file_prefixes : string list;
48
48
dcs_module_crcs : (string * string) list;
49
+
dcs_cma_units : (string * string list) list;
50
+
(** Maps CMA archive basename (e.g., "ocamlcommon.cma") to the list of
51
+
implementation unit names in that archive. Used for precise preload
52
+
checking when multiple findlib packages share a directory. *)
49
53
}
50
54
51
55
(** Memoised module CRC cache.
+2
-1
js_top_worker/test/libtest/preloaded_test.ml
+2
-1
js_top_worker/test/libtest/preloaded_test.ml