Skip to content

Commit

Permalink
Further fixes for virtual libraries
Browse files Browse the repository at this point in the history
  • Loading branch information
@jonludlam
jonludlam committed Feb 12, 2025
1 parent d88e04c commit 74df5d4
Show file tree
Hide file tree
Showing 5 changed files with 106 additions and 105 deletions.
160 changes: 66 additions & 94 deletions src/driver/compile.ml
View file
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
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
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
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
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

0 comments on commit 74df5d4

Please sign in to comment.