diff --git a/CHANGES.md b/CHANGES.md index 5b863b3463..2a932a5abc 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -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 diff --git a/src/driver/compile.ml b/src/driver/compile.ml index dbf020d152..2b5a183134 100644 --- a/src/driver/compile.ml +++ b/src/driver/compile.ml @@ -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 @@ -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 @@ -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 @@ -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 diff --git a/src/driver/landing_pages.ml b/src/driver/landing_pages.ml index f58a5a3fc1..2b0beb062f 100644 --- a/src/driver/landing_pages.ml +++ b/src/driver/landing_pages.ml @@ -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; diff --git a/src/driver/odoc_unit.ml b/src/driver/odoc_unit.ml index 3305285acd..4a9f80f36f 100644 --- a/src/driver/odoc_unit.ml +++ b/src/driver/odoc_unit.ml @@ -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; @@ -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 @@ -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 diff --git a/src/driver/odoc_unit.mli b/src/driver/odoc_unit.mli index fd0bb19876..87f918ae9f 100644 --- a/src/driver/odoc_unit.mli +++ b/src/driver/odoc_unit.mli @@ -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; diff --git a/src/driver/odoc_units_of.ml b/src/driver/odoc_units_of.ml index af44d0bdef..b043e024f9 100644 --- a/src/driver/odoc_units_of.ml +++ b/src/driver/odoc_units_of.ml @@ -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 @@ -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; @@ -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 @@ -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 @@ -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 @@ -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 ] | _ -> @@ -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