Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Further fixes for virtual libraries #1309

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Further fixes for virtual libraries #1309

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
74df5d4
Further fixes for virtual libraries
jonludlam Feb 10, 2025
19fd555
CHANGES
jonludlam Feb 12, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions CHANGES.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@
### Fixed

- Fix bug causing stack overflow in odoc_driver_monorepo (@jonludlam, #1304)
- Fix bug in odoc_driver_voodoo related to virtual libraries (@jonludlam, #1309)

# 3.0.0~beta1

Expand Down
160 changes: 66 additions & 94 deletions src/driver/compile.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -55,9 +55,7 @@ let init_stats (units : Odoc_unit.any list) =

open Eio.Std

type partial =
((string * string) * Odoc_unit.intf Odoc_unit.t list) list
* Odoc_unit.intf Odoc_unit.t list Util.StringMap.t
type partial = Odoc_unit.intf Odoc_unit.t list Util.StringMap.t

let unmarshal filename : partial =
let ic = open_in_bin (Fpath.to_string filename) in
Expand All @@ -81,11 +79,16 @@ let find_partials odoc_dir :
let index_m = Fpath.( / ) p odoc_partial_filename in
match OS.File.exists index_m with
| Ok true ->
let tbl', hashes' = unmarshal index_m in
List.iter
(fun (k, v) ->
Hashtbl.replace tbl k (Promise.create_resolved (Ok v)))
tbl';
let hashes' = unmarshal index_m in
Util.StringMap.iter
(fun h units ->
List.iter
(fun u ->
Hashtbl.replace tbl
(h, Odoc.Id.to_string u.Odoc_unit.parent_id)
(Promise.create_resolved ()))
units)
hashes';
Util.StringMap.union (fun _x o1 _o2 -> Some o1) hashes hashes'
| _ -> hashes)
Util.StringMap.empty odoc_dir
Expand All @@ -111,76 +114,62 @@ let compile ?partial ~partial_dir (all : Odoc_unit.any list) =
let all_hashes =
Util.StringMap.union (fun _x o1 o2 -> Some (o1 @ o2)) hashes other_hashes
in
let compile_one compile_other hash =
match Util.StringMap.find_opt hash all_hashes with
| None ->
Logs.debug (fun m -> m "Error locating hash: %s" hash);
Error Not_found
| Some units ->
Ok
(List.map
(fun (unit : Odoc_unit.intf Odoc_unit.t) ->
let deps = match unit.kind with `Intf { deps; _ } -> deps in
let _fibers =
Fiber.List.map
(fun (other_unit_name, other_unit_hash) ->
match compile_other other_unit_hash with
| Ok r -> Some r
| Error _exn ->
Logs.debug (fun m ->
m
"Error during compilation of module %s (hash \
%s, required by %s)"
other_unit_name other_unit_hash
(Fpath.filename unit.input_file));
None)
deps
in
let includes =
List.fold_left
(fun acc (_lib, path) -> Fpath.Set.add path acc)
Fpath.Set.empty
(Odoc_unit.Pkg_args.compiled_libs unit.pkg_args)
in
Odoc.compile ~output_dir:unit.output_dir
~input_file:unit.input_file ~includes
~suppress_warnings:(not unit.enable_warnings)
~parent_id:unit.parent_id;
Atomic.incr Stats.stats.compiled_units;

unit)
units)
in
let rec compile_mod :
string -> (Odoc_unit.intf Odoc_unit.t list, exn) Result.t =
fun hash ->
let units = try Util.StringMap.find hash hashes with _ -> [] in
let r =
let compile_one compile_other (unit : Odoc_unit.intf Odoc_unit.t) =
let (`Intf { Odoc_unit.deps; _ }) = unit.kind in
let _fibers =
Fiber.List.map
(fun unit ->
match
Hashtbl.find_opt tbl
(hash, Odoc.Id.to_string unit.Odoc_unit.parent_id)
with
| Some p -> Promise.await p
| None ->
let p, r = Promise.create () in
Hashtbl.add tbl (hash, Odoc.Id.to_string unit.parent_id) p;
let result = compile_one compile_mod hash in
Promise.resolve r result;
result)
units
(fun (other_unit_name, other_unit_hash) ->
match compile_other other_unit_hash with
| Ok r -> Some r
| Error _exn ->
Logs.debug (fun m ->
m
"Error during compilation of module %s (hash %s, \
required by %s)"
other_unit_name other_unit_hash
(Fpath.filename unit.input_file));
None)
deps
in
let r =
let includes =
List.fold_left
(fun acc x ->
match (acc, x) with
| Error _, _ -> acc
| Ok acc, Ok x -> Ok (x @ acc)
| Ok _, Error x -> Error x)
(Ok []) r
(fun acc (_lib, path) -> Fpath.Set.add path acc)
Fpath.Set.empty
(Odoc_unit.Pkg_args.compiled_libs unit.pkg_args)
in
r
Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
~includes ~suppress_warnings:(not unit.enable_warnings)
~parent_id:unit.parent_id;
(match unit.input_copy with
| None -> ()
| Some p -> Util.cp (Fpath.to_string unit.input_file) (Fpath.to_string p));
Atomic.incr Stats.stats.compiled_units
in
let rec compile_mod : string -> ('a list, [> `Msg of string ]) Result.t =
fun hash ->
try
let units = Util.StringMap.find hash all_hashes in
let r =
Fiber.List.map
(fun unit ->
match
Hashtbl.find_opt tbl
(hash, Odoc.Id.to_string unit.Odoc_unit.parent_id)
with
| Some p ->
Promise.await p;
None
| None ->
let p, r = Promise.create () in
Hashtbl.add tbl (hash, Odoc.Id.to_string unit.parent_id) p;
let _result = compile_one compile_mod unit in
Promise.resolve r ();
Some unit)
units
in
Ok (List.filter_map Fun.id r)
with Not_found ->
Error (`Msg ("Module with hash " ^ hash ^ " not found"))
in
compile_mod
in
Expand Down Expand Up @@ -218,28 +207,11 @@ let compile ?partial ~partial_dir (all : Odoc_unit.any list) =
Atomic.incr Stats.stats.compiled_mlds;
Ok [ unit ]
in
let res = Fiber.List.map compile all in
(* For voodoo mode, we need to keep which modules successfully compiled *)
let zipped =
List.filter_map
(function
| Ok (Odoc_unit.{ kind = `Intf { hash; _ }; parent_id; _ } :: _ as b) ->
let l =
List.filter_map
(function
| Odoc_unit.{ kind = `Intf { hash = hash'; _ }; _ } as x
when hash' = hash ->
Some x
| _ -> None)
b
in
Some ((hash, Odoc.Id.to_string parent_id), l)
| _ -> None)
res
in
let _ = Fiber.List.map compile all in
(match partial with
| Some l -> marshal (zipped, hashes) Fpath.(l / odoc_partial_filename)
| Some l -> marshal hashes Fpath.(l / odoc_partial_filename)
| None -> ());

all

type linked = Odoc_unit.any
Expand Down
1 change: 1 addition & 0 deletions src/driver/landing_pages.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,6 +28,7 @@ let make_index ~dirs ~rel_dir ~libs ~pkgs ~index ~enable_warnings ~content :
pkg_args;
parent_id;
input_file;
input_copy = None;
odoc_file;
odocl_file;
enable_warnings;
Expand Down
32 changes: 24 additions & 8 deletions src/driver/odoc_unit.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -74,6 +74,8 @@ let pp_index fmt x =
type 'a t = {
parent_id : Odoc.Id.t;
input_file : Fpath.t;
input_copy : Fpath.t option;
(* Used to stash cmtis from virtual libraries into the odoc dir for voodoo mode *)
output_dir : Fpath.t;
odoc_file : Fpath.t;
odocl_file : Fpath.t;
Expand Down Expand Up @@ -184,12 +186,6 @@ let fix_virtual ~(precompiled_units : intf t list Util.StringMap.t)
match Util.StringMap.find uhash all with
| [ _ ] -> unit
| xs -> (
Logs.debug (fun m ->
m
"Virtual library check: Selecting cmti for hash %s from \
%d possibilities: %a"
uhash (List.length xs) (Fmt.Dump.list pp)
(xs :> any list));
let unit_name =
Fpath.rem_ext unit.input_file |> Fpath.basename
in
Expand All @@ -203,12 +199,32 @@ let fix_virtual ~(precompiled_units : intf t list Util.StringMap.t)
xs
with
| [ x ] -> { unit with input_file = x.input_file }
| xs ->
| xs -> (
Logs.debug (fun m ->
m
"Duplicate hash found, but multiple (%d) matching \
cmti found for %a"
(List.length xs) Fpath.pp unit.input_file);
unit))
let possibles =
List.filter_map
(fun x ->
match x.input_copy with
| Some x ->
if
x |> Bos.OS.File.exists
|> Result.value ~default:false
then Some x
else None
| None -> None)
xs
in
match possibles with
| [] ->
Logs.debug (fun m -> m "Not replacing input file");
unit
| x :: _ ->
Logs.debug (fun m ->
m "Replacing input_file of unit with %a" Fpath.pp x);
{ unit with input_file = x })))
units)
units
2 changes: 2 additions & 0 deletions src/driver/odoc_unit.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,8 @@ type index = {
type 'a t = {
parent_id : Odoc.Id.t;
input_file : Fpath.t;
input_copy : Fpath.t option;
(* Used to stash cmtis from virtual libraries into the odoc dir for voodoo mode *)
output_dir : Fpath.t;
odoc_file : Fpath.t;
odocl_file : Fpath.t;
Expand Down
16 changes: 13 additions & 3 deletions src/driver/odoc_units_of.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -102,7 +102,7 @@ let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
in

let make_unit ~name ~kind ~rel_dir ~input_file ~pkg ~lib_deps ~enable_warnings
~to_output : _ t =
~to_output ~stash_input : _ t =
let to_output = to_output || not remap in
(* If we haven't got active remapping, we output everything *)
let ( // ) = Fpath.( // ) in
Expand All @@ -116,12 +116,18 @@ let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
let odocl_file =
odocl_dir // rel_dir / (String.uncapitalize_ascii name ^ ".odocl")
in
let input_copy =
if stash_input then
Some (odoc_dir // rel_dir / (String.uncapitalize_ascii name ^ ".cmti"))
else None
in
{
output_dir = odoc_dir;
pkgname = Some pkg.Packages.name;
pkg_args;
parent_id;
input_file;
input_copy;
odoc_file;
odocl_file;
kind;
Expand All @@ -140,8 +146,9 @@ let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
kind
in
let name = intf.mif_path |> Fpath.rem_ext |> Fpath.basename in
let stash_input = lib.archive_name = None in
make_unit ~name ~kind ~rel_dir ~input_file:intf.mif_path ~pkg ~lib_deps
~enable_warnings:pkg.selected ~to_output:pkg.selected
~enable_warnings:pkg.selected ~to_output:pkg.selected ~stash_input
in
let of_impl pkg lib lib_deps (impl : Packages.impl) : impl t option =
match impl.mip_src_info with
Expand All @@ -162,6 +169,7 @@ let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
let unit =
make_unit ~name ~kind ~rel_dir ~input_file:impl.mip_path ~pkg
~lib_deps ~enable_warnings:pkg.selected ~to_output:pkg.selected
~stash_input:false
in
Some unit
in
Expand Down Expand Up @@ -196,7 +204,7 @@ let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
in
let unit =
make_unit ~name ~kind ~rel_dir ~input_file:mld_path ~pkg ~lib_deps
~enable_warnings:pkg.selected ~to_output:pkg.selected
~enable_warnings:pkg.selected ~to_output:pkg.selected ~stash_input:false
in
[ unit ]
in
Expand All @@ -217,6 +225,7 @@ let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
let unit =
make_unit ~name ~kind ~rel_dir ~input_file:md_path ~pkg ~lib_deps
~enable_warnings:pkg.selected ~to_output:pkg.selected
~stash_input:false
in
[ unit ]
| _ ->
Expand All @@ -235,6 +244,7 @@ let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
let name = asset_path |> Fpath.basename |> ( ^ ) "asset-" in
make_unit ~name ~kind ~rel_dir ~input_file:asset_path ~pkg
~lib_deps:Util.StringSet.empty ~enable_warnings:false ~to_output:true
~stash_input:false
in
[ unit ]
in
Expand Down