My aggregated monorepo of OCaml code, automaintained
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

Odoc perf: flatten hidden includes, memoize doc parsing, skip trivial link docs

Three layered optimizations for odoc compile/link performance on
ppx_template-heavy packages (base, core):

1. Loader: flatten includes whose expansion items all have __ names
(ppx_template monomorphization duplicates) into the enclosing
signature, eliminating nested Include nodes that caused 10K+
redundant traversals during compile/link.

2. Loader: memoize Odoc_parser.parse_comment by raw text string.
Container_intf has 155K doc comments but only 33 unique texts
(99.98% cache hit rate), saving ~3.4s of parser time per compile.

3. Link: short-circuit comment_docs when the doc AST contains no
references, headings, or modules to resolve — avoids rebuilding
155K doc ASTs word-by-word via List.map.

Also adds instrumentation (gated by ODOC_GC_STATS=1):
- Per-subprocess Gc.quick_stat reporting via stderr
- Per-phase include_ call counting with per-location breakdown
- Doc parse timing and cache hit stats
- Per-item timing in the cmt loader
- Driver: top-10-by-allocation report per phase with include counts
- Driver: track all subprocesses (including silent/dependency ones)

Results on odoc_driver core (vs better-website baseline):
- Compile: 128 GB → 94 GB (-27%)
- Link: 73 GB → 56 GB (-23%)
- Wall time: 549s → 499s (-9%)
- HTML-gen: +28% allocation (known; items bypass internal_value
fast-skip due to ValueName.Std tag — deferred to follow-up)

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>

+694 -52
+33
odoc/src/document/generator.ml
··· 22 22 module O = Codefmt 23 23 open O.Infix 24 24 25 + let include_calls = ref 0 26 + 27 + let include_by_loc : (string, int) Hashtbl.t = Hashtbl.create 128 28 + 29 + let bump_loc (span : Odoc_model.Location_.span) = 30 + let key = Printf.sprintf "%s:%d" span.file span.start.line in 31 + match Hashtbl.find_opt include_by_loc key with 32 + | Some r -> Hashtbl.replace include_by_loc key (r + 1) 33 + | None -> Hashtbl.add include_by_loc key 1 34 + 35 + let () = 36 + match Sys.getenv_opt "ODOC_GC_STATS" with 37 + | None | Some "" | Some "0" -> () 38 + | Some _ -> 39 + at_exit (fun () -> 40 + Printf.eprintf "ODOC_INCLUDE_COUNT phase=generate n=%d unique=%d\n%!" 41 + !include_calls 42 + (Hashtbl.length include_by_loc); 43 + let entries = 44 + Hashtbl.fold (fun k v acc -> (k, v) :: acc) include_by_loc [] 45 + in 46 + let top = 47 + List.sort (fun (_, a) (_, b) -> compare b a) entries 48 + |> List.filteri (fun i _ -> i < 10) 49 + in 50 + List.iter 51 + (fun (k, v) -> 52 + Printf.eprintf "ODOC_INCLUDE_TOP phase=generate loc=%s count=%d\n%!" 53 + k v) 54 + top) 55 + 25 56 let tag tag t = O.span ~attr:tag t 26 57 27 58 let label t = ··· 1842 1873 | Some te -> type_expr te) 1843 1874 1844 1875 and include_ (t : Odoc_model.Lang.Include.t) = 1876 + incr include_calls; 1877 + bump_loc t.loc; 1845 1878 let decl_hidden = 1846 1879 match t.decl with 1847 1880 | Alias p -> Paths.Path.(is_hidden (p :> t))
+82 -2
odoc/src/driver/bin/odoc_driver.ml
··· 115 115 let grep_log ty s = 116 116 let open Astring in 117 117 let do_ affix = 118 - let grep { Cmd_outputs.log_dest; prefix; run } = 118 + let grep { Cmd_outputs.log_dest; prefix; run; silent = _ } = 119 119 if log_dest = ty then 120 120 let l = run.Run.cmd |> String.concat ~sep:" " in 121 121 if String.is_infix ~affix l then Format.printf "%s: %s\n" prefix l ··· 145 145 in 146 146 147 147 List.iter 148 - (fun { Cmd_outputs.log_dest; prefix; run } -> 148 + (fun { Cmd_outputs.log_dest; prefix; run; silent } -> 149 + if silent then () 150 + else 149 151 match log_dest with 150 152 | `Link | `Compile -> 151 153 [ run.Run.output; run.Run.errors ] ··· 161 163 Logs.app (fun m -> m "")) 162 164 | _ -> ()) 163 165 !Cmd_outputs.outputs; 166 + 167 + (* Print top-10 allocating invocations per pipeline phase when 168 + ODOC_GC_STATS=1 was used to run the subprocesses. *) 169 + let report_top_allocating () = 170 + let bucket = Hashtbl.create 8 in 171 + List.iter 172 + (fun { Cmd_outputs.log_dest; prefix; run; silent = _ } -> 173 + match run.Run.gc with 174 + | None -> () 175 + | Some g -> 176 + let prev = 177 + try Hashtbl.find bucket log_dest with Not_found -> [] 178 + in 179 + Hashtbl.replace bucket log_dest 180 + ((prefix, run, Run.allocated_words g) :: prev)) 181 + !Cmd_outputs.outputs; 182 + let kind_name : Cmd_outputs.log_dest -> string = function 183 + | `Compile -> "compile" 184 + | `Compile_src -> "compile-src" 185 + | `Link -> "link" 186 + | `Generate -> "html-generate" 187 + | `Count_occurrences -> "count-occurrences" 188 + | `Index -> "compile-index" 189 + | `Sherlodoc -> "sherlodoc" 190 + | `Classify -> "classify" 191 + in 192 + let report kind = 193 + let entries = 194 + try Hashtbl.find bucket kind with Not_found -> [] 195 + in 196 + if entries <> [] then begin 197 + let sorted = 198 + List.sort (fun (_, _, a) (_, _, b) -> Float.compare b a) entries 199 + in 200 + let total_mb = 201 + List.fold_left (fun acc (_, _, w) -> acc +. w) 0. sorted 202 + *. 8.0 /. 1048576.0 203 + in 204 + let total_cpu_s = 205 + List.fold_left (fun acc (_, run, _) -> acc +. run.Run.time) 0. sorted 206 + in 207 + let top = 208 + sorted |> List.filteri (fun i _ -> i < 10) 209 + in 210 + Logs.app (fun m -> 211 + m "%s: %d commands, %.1f MB total, %.1fs sum_cpu. Top %d by allocation:" 212 + (kind_name kind) (List.length entries) total_mb total_cpu_s 213 + (List.length top)); 214 + List.iter 215 + (fun (prefix, run, words) -> 216 + let mb = words *. 8.0 /. 1048576.0 in 217 + let inc = 218 + match run.Run.gc with 219 + | None -> "" 220 + | Some g -> 221 + let phases = [ "compile"; "link"; "generate" ] in 222 + let parts = 223 + List.filter_map 224 + (fun p -> 225 + match List.assoc_opt p g.Run.include_calls with 226 + | Some n when n > 0 -> 227 + Some (Printf.sprintf "%s=%d" p n) 228 + | _ -> None) 229 + phases 230 + in 231 + if parts = [] then "" else " [inc " ^ String.concat "," parts ^ "]" 232 + in 233 + Logs.app (fun m -> 234 + m " %8.1f MB %6.2fs%s %s %s" mb run.Run.time inc prefix 235 + (String.concat " " run.Run.cmd))) 236 + top 237 + end 238 + in 239 + List.iter report [ `Compile; `Link; `Generate ] 240 + in 241 + (match Sys.getenv_opt "ODOC_GC_STATS" with 242 + | None | Some "" | Some "0" -> () 243 + | Some _ -> report_top_allocating ()); 164 244 165 245 if stats then Stats.bench_results html_dir 166 246
+15 -7
odoc/src/driver/cmd_outputs.ml
··· 8 8 | `Sherlodoc 9 9 | `Classify ] 10 10 11 - type log_line = { log_dest : log_dest; prefix : string; run : Run.t } 11 + type log_line = { 12 + log_dest : log_dest; 13 + prefix : string; 14 + run : Run.t; 15 + silent : bool; 16 + (** User-facing warnings/output for this command should not be surfaced. 17 + The run is still recorded so stats (timing, allocation) work across 18 + all invocations, including for dependency units. *) 19 + } 12 20 13 21 let outputs : log_line list ref = ref [] 14 22 15 - let maybe_log log_dest run = 23 + let maybe_log ?(silent = false) log_dest run = 16 24 match log_dest with 17 25 | Some (log_dest, prefix) -> 18 - outputs := !outputs @ [ { log_dest; run; prefix } ] 26 + outputs := !outputs @ [ { log_dest; run; prefix; silent } ] 19 27 | None -> () 20 28 21 - let submit log_dest desc cmd output_file = 29 + let submit ?(silent = false) log_dest desc cmd output_file = 22 30 match Worker_pool.submit desc cmd output_file with 23 31 | Ok x -> 24 - maybe_log log_dest x; 32 + maybe_log ~silent log_dest x; 25 33 String.split_on_char '\n' x.output 26 34 | Error exn -> raise exn 27 35 28 - let submit_ignore_failures log_dest desc cmd output_file = 36 + let submit_ignore_failures ?(silent = false) log_dest desc cmd output_file = 29 37 match Worker_pool.submit desc cmd output_file with 30 38 | Ok x -> 31 - maybe_log log_dest x; 39 + maybe_log ~silent log_dest x; 32 40 () 33 41 | Error exn -> 34 42 Logs.err (fun m -> m "Error: %s" (Printexc.to_string exn));
+17 -28
odoc/src/driver/odoc.ml
··· 60 60 | Some tag -> cmd % "--warnings-tag" % tag 61 61 in 62 62 let desc = Printf.sprintf "Compiling %s" (Fpath.to_string file) in 63 - let log = 64 - if ignore_output then None else Some (`Compile, Fpath.to_string file) 65 - in 66 - ignore @@ Cmd_outputs.submit log desc cmd output_file 63 + let log = Some (`Compile, Fpath.to_string file) in 64 + ignore @@ Cmd_outputs.submit ~silent:ignore_output log desc cmd output_file 67 65 68 66 let compile_md ~output_dir ~input_file:file ~parent_id = 69 67 let open Cmd in ··· 169 167 in 170 168 let desc = Printf.sprintf "Linking %s" (Fpath.to_string file) in 171 169 let cmd = if custom_layout then cmd % "--custom-layout" else cmd in 172 - let log = 173 - if ignore_output then None else Some (`Link, Fpath.to_string file) 174 - in 175 - ignore @@ Cmd_outputs.submit log desc cmd (Some output_file) 170 + let log = Some (`Link, Fpath.to_string file) in 171 + ignore 172 + @@ Cmd_outputs.submit ~silent:ignore_output log desc cmd (Some output_file) 176 173 177 174 let compile_index ?(ignore_output = false) ~output_file ?occurrence_file ~json 178 175 ~roots ~simplified ~wrap () = ··· 197 194 let desc = 198 195 Printf.sprintf "Generating index for %s" (Fpath.to_string output_file) 199 196 in 200 - let log = 201 - if ignore_output then None else Some (`Index, Fpath.to_string output_file) 202 - in 203 - ignore @@ Cmd_outputs.submit log desc cmd (Some output_file) 197 + let log = Some (`Index, Fpath.to_string output_file) in 198 + ignore 199 + @@ Cmd_outputs.submit ~silent:ignore_output log desc cmd (Some output_file) 204 200 205 201 let sidebar_generate ?(ignore_output = false) ~output_file ~json input_file () = 206 202 let json = if json then Cmd.v "--json" else Cmd.empty in ··· 212 208 let desc = 213 209 Printf.sprintf "Generating sidebar for %s" (Fpath.to_string output_file) 214 210 in 215 - let log = 216 - if ignore_output then None else Some (`Generate, Fpath.to_string output_file) 217 - in 218 - ignore @@ Cmd_outputs.submit log desc cmd (Some output_file) 211 + let log = Some (`Generate, Fpath.to_string output_file) in 212 + ignore 213 + @@ Cmd_outputs.submit ~silent:ignore_output log desc cmd (Some output_file) 219 214 220 215 let html_generate ~output_dir ?sidebar ?(ignore_output = false) 221 216 ?(search_uris = []) ?remap ?(as_json = false) ?home_breadcrumb ··· 243 238 in 244 239 let cmd = if as_json then cmd % "--as-json" else cmd in 245 240 let desc = Printf.sprintf "Generating HTML for %s" (Fpath.to_string file) in 246 - let log = 247 - if ignore_output then None else Some (`Generate, Fpath.to_string file) 248 - in 249 - ignore @@ Cmd_outputs.submit log desc cmd None 241 + let log = Some (`Generate, Fpath.to_string file) in 242 + ignore @@ Cmd_outputs.submit ~silent:ignore_output log desc cmd None 250 243 251 244 let html_generate_asset ~output_dir ?(ignore_output = false) ?home_breadcrumb 252 245 ~input_file:file ~asset_path () = ··· 261 254 % p asset_path %% home_breadcrumb 262 255 in 263 256 let desc = Printf.sprintf "Copying asset %s" (Fpath.to_string file) in 264 - let log = 265 - if ignore_output then None else Some (`Generate, Fpath.to_string file) 266 - in 267 - ignore @@ Cmd_outputs.submit log desc cmd None 257 + let log = Some (`Generate, Fpath.to_string file) in 258 + ignore @@ Cmd_outputs.submit ~silent:ignore_output log desc cmd None 268 259 269 260 let html_generate_source ~output_dir ?(ignore_output = false) ~source ?sidebar 270 261 ?(search_uris = []) ?(as_json = false) ?home_breadcrumb ~input_file:file () ··· 291 282 let cmd = if as_json then cmd % "--as-json" else cmd in 292 283 293 284 let desc = Printf.sprintf "Generating HTML for %s" (Fpath.to_string source) in 294 - let log = 295 - if ignore_output then None else Some (`Generate, Fpath.to_string source) 296 - in 297 - ignore @@ Cmd_outputs.submit log desc cmd None 285 + let log = Some (`Generate, Fpath.to_string source) in 286 + ignore @@ Cmd_outputs.submit ~silent:ignore_output log desc cmd None 298 287 299 288 let support_files path = 300 289 let open Cmd in
+108 -1
odoc/src/driver/run.ml
··· 9 9 OS.Dir.create dir |> Result.get_ok |> ignore; 10 10 dir) 11 11 12 + type gc_stats = { 13 + minor_words : float; 14 + promoted_words : float; 15 + major_words : float; 16 + top_heap_words : int; 17 + heap_words : int; 18 + include_calls : (string * int) list; 19 + (** phase -> count for "include_" entry, from ODOC_INCLUDE_COUNT lines *) 20 + } 21 + 22 + (** Total words allocated in the subprocess. One word = 8 bytes on 64-bit. *) 23 + let allocated_words g = g.minor_words +. g.major_words -. g.promoted_words 24 + 12 25 type t = { 13 26 cmd : string list; 14 27 time : float; (** Running time in seconds. *) 15 28 output_file : Fpath.t option; 16 29 output : string; 17 30 errors : string; 31 + gc : gc_stats option; 18 32 status : [ `Exited of int | `Signaled of int ]; 19 33 } 20 34 35 + (* Parse + strip the "ODOC_GC_STATS ..." line emitted by odoc when 36 + ODOC_GC_STATS=1 is set. Returns (cleaned_errors, gc_stats_option). *) 37 + let extract_gc_stats errors = 38 + let gc_prefix = "ODOC_GC_STATS " in 39 + let inc_prefix = "ODOC_INCLUDE_COUNT " in 40 + let starts_with s p = 41 + String.length s >= String.length p 42 + && String.sub s 0 (String.length p) = p 43 + in 44 + let trim_cr l = 45 + let n = String.length l in 46 + if n > 0 && l.[n - 1] = '\r' then String.sub l 0 (n - 1) else l 47 + in 48 + let get_kv body key = 49 + let tok = key ^ "=" in 50 + let parts = String.split_on_char ' ' body in 51 + List.find_map 52 + (fun p -> 53 + if 54 + String.length p > String.length tok 55 + && String.sub p 0 (String.length tok) = tok 56 + then 57 + Some 58 + (String.sub p (String.length tok) 59 + (String.length p - String.length tok)) 60 + else None) 61 + parts 62 + in 63 + let lines = String.split_on_char '\n' errors in 64 + let gc_fields = ref None in 65 + let include_calls = ref [] in 66 + let kept = 67 + List.filter 68 + (fun l -> 69 + let t = trim_cr l in 70 + if starts_with t gc_prefix then begin 71 + let body = 72 + String.sub t (String.length gc_prefix) 73 + (String.length t - String.length gc_prefix) 74 + in 75 + (try 76 + gc_fields := 77 + Some 78 + ( float_of_string (Option.get (get_kv body "minor_words")), 79 + float_of_string (Option.get (get_kv body "promoted_words")), 80 + float_of_string (Option.get (get_kv body "major_words")), 81 + int_of_string (Option.get (get_kv body "top_heap_words")), 82 + int_of_string (Option.get (get_kv body "heap_words")) ) 83 + with _ -> ()); 84 + false 85 + end 86 + else if starts_with t inc_prefix then begin 87 + let body = 88 + String.sub t (String.length inc_prefix) 89 + (String.length t - String.length inc_prefix) 90 + in 91 + (try 92 + let phase = Option.get (get_kv body "phase") in 93 + let n = int_of_string (Option.get (get_kv body "n")) in 94 + include_calls := (phase, n) :: !include_calls 95 + with _ -> ()); 96 + false 97 + end 98 + else true) 99 + lines 100 + in 101 + let gc = 102 + match !gc_fields with 103 + | None -> None 104 + | Some (minor_words, promoted_words, major_words, top_heap_words, heap_words) 105 + -> 106 + Some 107 + { 108 + minor_words; 109 + promoted_words; 110 + major_words; 111 + top_heap_words; 112 + heap_words; 113 + include_calls = !include_calls; 114 + } 115 + in 116 + (String.concat "\n" kept, gc) 117 + 21 118 (* Environment variables passed to commands. *) 22 119 23 120 (* Record the commands executed, their running time and optionally the path to ··· 74 171 m "Finished running cmd %a" Fmt.(list ~sep:sp string) cmd); *) 75 172 let t_end = Unix.gettimeofday () in 76 173 let time = t_end -. t_start in 77 - let result = { cmd; time; output_file; output; errors; status } in 174 + let errors, gc = extract_gc_stats errors in 175 + let result = { cmd; time; output_file; output; errors; gc; status } in 78 176 commands := result :: !commands; 79 177 (match result.status with 80 178 | `Exited 0 -> () ··· 115 213 filter_commands cmd 116 214 |> List.sort (fun a b -> Float.compare b.time a.time) 117 215 |> List.filteri (fun i _ -> i < k) 216 + 217 + (** Returns the [k] commands that allocated the most bytes for a given 218 + subcommand. Commands without captured gc stats are ignored. *) 219 + let k_highest_allocating_commands cmd k = 220 + filter_commands cmd 221 + |> List.filter_map (fun c -> 222 + match c.gc with Some g -> Some (c, allocated_words g) | None -> None) 223 + |> List.sort (fun (_, a) (_, b) -> Float.compare b a) 224 + |> List.filteri (fun i _ -> i < k)
+112 -4
odoc/src/loader/cmt.cppo.ml
··· 33 33 34 34 let cmt_builddir : string ref = ref "" 35 35 36 + let contains_double_underscore s = 37 + let len = String.length s in 38 + let rec loop i = 39 + if i + 1 >= len then false 40 + else if s.[i] = '_' && s.[i + 1] = '_' then true 41 + else loop (i + 1) 42 + in 43 + loop 0 44 + 45 + let item_is_hidden_or_noncontent (item : Signature.item) = 46 + match item with 47 + | Module (_, m) -> 48 + contains_double_underscore (Odoc_model.Paths.Identifier.name m.Module.id) 49 + | ModuleType mt -> 50 + contains_double_underscore 51 + (Odoc_model.Paths.Identifier.name mt.ModuleType.id) 52 + | Type (_, t) -> 53 + contains_double_underscore 54 + (Odoc_model.Paths.Identifier.name t.TypeDecl.id) 55 + | Value v -> 56 + contains_double_underscore (Odoc_model.Paths.Identifier.name v.Value.id) 57 + | Class (_, c) -> 58 + contains_double_underscore (Odoc_model.Paths.Identifier.name c.Class.id) 59 + | ClassType (_, ct) -> 60 + contains_double_underscore 61 + (Odoc_model.Paths.Identifier.name ct.ClassType.id) 62 + | Comment _ -> true 63 + | ModuleSubstitution _ | ModuleTypeSubstitution _ | TypeSubstitution _ 64 + | Open _ | TypExt _ | Exception _ | Include _ -> 65 + false 66 + 67 + let all_items_hidden items = 68 + items <> [] && List.for_all item_is_hidden_or_noncontent items 69 + 70 + let flatten_total_includes = ref 0 71 + let flatten_total_attributes = ref 0 72 + let flatten_total_stops = ref 0 73 + let flatten_would_splice = ref 0 74 + let flatten_would_splice_instop = ref 0 75 + let flatten_would_splice_allhidden = ref 0 76 + let flatten_would_splice_items = ref 0 77 + let flatten_would_splice_shadowed = ref 0 78 + 79 + let () = 80 + match Sys.getenv_opt "ODOC_GC_STATS" with 81 + | None | Some "" | Some "0" -> () 82 + | Some _ -> 83 + at_exit (fun () -> 84 + Printf.eprintf 85 + "ODOC_FLATTEN_WOULD phase=cmt total=%d attrs=%d stops=%d would=%d in_stop=%d all_hidden=%d items=%d shadowed=%d\n%!" 86 + !flatten_total_includes !flatten_total_attributes !flatten_total_stops 87 + !flatten_would_splice !flatten_would_splice_instop 88 + !flatten_would_splice_allhidden !flatten_would_splice_items 89 + !flatten_would_splice_shadowed) 90 + 36 91 let read_core_type env ctyp = 37 92 Cmi.read_type_expr env ctyp.ctyp_type 38 93 ··· 520 575 |> fst 521 576 |> List.rev 522 577 523 - and read_structure_item env parent item = 578 + and read_structure_item ~in_stop env parent item = 524 579 let open Signature in 525 580 match item.str_desc with 526 581 | Tstr_eval _ -> [] ··· 564 619 | Tstr_open o -> 565 620 [Open (read_open env parent o)] 566 621 | Tstr_include incl -> 567 - read_include env parent incl 622 + read_include ~in_stop:!in_stop env parent incl 568 623 | Tstr_class cls -> 569 624 let cls = List.map 570 625 #if OCAML_VERSION < (4,3,0) ··· 579 634 let cltyps = List.map (fun (_, _, clty) -> clty) cltyps in 580 635 Cmti.read_class_type_declarations env parent cltyps 581 636 | Tstr_attribute attr -> 637 + incr flatten_total_attributes; 582 638 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in 583 639 match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with 584 640 | None -> [] 641 + | Some (`Stop as doc) -> 642 + incr flatten_total_stops; 643 + in_stop := not !in_stop; 644 + [Comment doc] 585 645 | Some doc -> [Comment doc] 586 646 587 - and read_include env parent incl = 647 + and read_include ?(in_stop = false) env parent incl = 588 648 let open Include in 589 649 let loc = Doc_attr.read_location incl.incl_loc in 590 650 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in ··· 607 667 umty_of_mty mty 608 668 in 609 669 let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in 670 + incr flatten_total_includes; 671 + let all_hidden = all_items_hidden content.Signature.items in 672 + let should_flatten = in_stop || all_hidden in 673 + if should_flatten then begin 674 + incr flatten_would_splice; 675 + if in_stop then incr flatten_would_splice_instop; 676 + if all_hidden && not in_stop then incr flatten_would_splice_allhidden; 677 + flatten_would_splice_items := 678 + !flatten_would_splice_items + List.length content.Signature.items; 679 + let s : Include.shadowed = shadowed in 680 + if s.s_modules <> [] || s.s_module_types <> [] 681 + || s.s_values <> [] || s.s_types <> [] 682 + || s.s_classes <> [] || s.s_class_types <> [] 683 + then incr flatten_would_splice_shadowed 684 + end; 685 + let shadowed_empty = 686 + let s : Include.shadowed = shadowed in 687 + s.s_modules = [] && s.s_module_types = [] 688 + && s.s_values = [] && s.s_types = [] 689 + && s.s_classes = [] && s.s_class_types = [] 690 + in 691 + if should_flatten && shadowed_empty then 692 + content.Signature.items 693 + else 610 694 let expansion = { content; shadowed; } in 611 695 match decl_modty with 612 696 | Some m -> ··· 641 725 in 642 726 Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent str.str_items 643 727 in 728 + let in_stop = ref false in 729 + let item_times = ref [] in 644 730 let items = 645 731 List.fold_left 646 732 (fun items item -> 647 - List.rev_append (read_structure_item env parent item) items) 733 + let t0 = Sys.time () in 734 + let result = read_structure_item ~in_stop env parent item in 735 + let dt = Sys.time () -. t0 in 736 + if dt > 0.1 then begin 737 + let name = match item.str_desc with 738 + | Tstr_modtype mtd -> Printf.sprintf "module type %s" (Ident.name mtd.mtd_id) 739 + | Tstr_module mb -> 740 + (match mb.mb_id with Some id -> Printf.sprintf "module %s" (Ident.name id) | None -> "module _") 741 + | Tstr_value _ -> "let ..." 742 + | Tstr_type _ -> "type ..." 743 + | Tstr_include _ -> "include ..." 744 + | _ -> "other" 745 + in 746 + item_times := (name, dt, List.length result) :: !item_times 747 + end; 748 + List.rev_append result items) 648 749 [] items 649 750 |> List.rev 650 751 in 752 + (match Sys.getenv_opt "ODOC_GC_STATS" with 753 + | Some s when s <> "" && s <> "0" -> 754 + let sorted = List.sort (fun (_, a, _) (_, b, _) -> compare b a) !item_times in 755 + List.iter (fun (name, dt, n_items) -> 756 + Printf.eprintf "ODOC_ITEM_TIME name=%s time=%.3f items=%d\n%!" name dt n_items 757 + ) (List.filteri (fun i _ -> i < 10) sorted) 758 + | _ -> ()); 651 759 match doc_post with 652 760 | { elements = [] ; _} -> 653 761 ({ Signature.items; compiled = false; removed = []; doc }, tags)
+158 -5
odoc/src/loader/cmti.cppo.ml
··· 34 34 let cmti_builddir : string ref = ref "" 35 35 let read_module_expr : (env -> Identifier.Signature.t -> Identifier.LabelParent.t -> Typedtree.module_expr -> ModuleType.expr) ref = ref (fun _ _ _ _ -> failwith "unset") 36 36 37 + (* Detect a name that odoc treats as "hidden" by the double-underscore 38 + convention. Matches Names.*.is_hidden semantics. *) 39 + let contains_double_underscore s = 40 + let len = String.length s in 41 + let rec loop i = 42 + if i + 1 >= len then false 43 + else if s.[i] = '_' && s.[i + 1] = '_' then true 44 + else loop (i + 1) 45 + in 46 + loop 0 47 + 48 + let item_is_hidden_or_noncontent (item : Signature.item) = 49 + match item with 50 + | Module (_, m) -> 51 + contains_double_underscore (Odoc_model.Paths.Identifier.name m.Module.id) 52 + | ModuleType mt -> 53 + contains_double_underscore 54 + (Odoc_model.Paths.Identifier.name mt.ModuleType.id) 55 + | Type (_, t) -> 56 + contains_double_underscore 57 + (Odoc_model.Paths.Identifier.name t.TypeDecl.id) 58 + | Value v -> 59 + contains_double_underscore (Odoc_model.Paths.Identifier.name v.Value.id) 60 + | Class (_, c) -> 61 + contains_double_underscore (Odoc_model.Paths.Identifier.name c.Class.id) 62 + | ClassType (_, ct) -> 63 + contains_double_underscore 64 + (Odoc_model.Paths.Identifier.name ct.ClassType.id) 65 + | Comment _ -> true (* non-content, doesn't block flattening *) 66 + | ModuleSubstitution _ | ModuleTypeSubstitution _ | TypeSubstitution _ 67 + | Open _ | TypExt _ | Exception _ | Include _ -> 68 + false 69 + 70 + let flatten_disabled = 71 + match Sys.getenv_opt "ODOC_NO_FLATTEN" with 72 + | Some "1" | Some "true" -> true 73 + | _ -> false 74 + 75 + let all_items_hidden items = 76 + not flatten_disabled && items <> [] 77 + && List.for_all item_is_hidden_or_noncontent items 78 + 79 + (* Counters for would-be flattening. Reported on stderr at exit when 80 + ODOC_GC_STATS=1 is set. *) 81 + let flatten_total_includes = ref 0 82 + let flatten_total_attributes = ref 0 83 + let flatten_total_stops = ref 0 84 + let flatten_would_splice = ref 0 85 + let flatten_would_splice_instop = ref 0 86 + let flatten_would_splice_allhidden = ref 0 87 + let flatten_would_splice_items = ref 0 88 + let flatten_would_splice_shadowed = ref 0 89 + (* Decl kind counters: (total, would-flatten) per kind *) 90 + let flatten_kind_alias = ref 0 91 + let flatten_kind_alias_flat = ref 0 92 + let flatten_kind_path = ref 0 93 + let flatten_kind_path_flat = ref 0 94 + let flatten_kind_sig = ref 0 95 + let flatten_kind_sig_flat = ref 0 96 + let flatten_kind_with = ref 0 97 + let flatten_kind_with_flat = ref 0 98 + let flatten_kind_typeof = ref 0 99 + let flatten_kind_typeof_flat = ref 0 100 + let flatten_kind_strengthen = ref 0 101 + let flatten_kind_strengthen_flat = ref 0 102 + 103 + (* Classify the Typedtree module_type that's the target of an include in a 104 + signature. Recursive so [include M with type t := ...] counts both the 105 + outer With and the inner Path. *) 106 + let rec classify_mty_desc (desc : Typedtree.module_type_desc) ~flat = 107 + match desc with 108 + | Tmty_ident _ -> 109 + incr flatten_kind_path; 110 + if flat then incr flatten_kind_path_flat 111 + | Tmty_signature _ -> 112 + incr flatten_kind_sig; 113 + if flat then incr flatten_kind_sig_flat 114 + | Tmty_functor _ -> () 115 + | Tmty_with (mty, _) -> 116 + incr flatten_kind_with; 117 + if flat then incr flatten_kind_with_flat; 118 + classify_mty_desc mty.mty_desc ~flat 119 + | Tmty_typeof _ -> 120 + incr flatten_kind_typeof; 121 + if flat then incr flatten_kind_typeof_flat 122 + | Tmty_alias _ -> 123 + incr flatten_kind_alias; 124 + if flat then incr flatten_kind_alias_flat 125 + #if defined OXCAML 126 + | Tmty_strengthen (mty, _, _) -> 127 + incr flatten_kind_strengthen; 128 + if flat then incr flatten_kind_strengthen_flat; 129 + classify_mty_desc mty.mty_desc ~flat 130 + #endif 131 + 132 + let () = 133 + match Sys.getenv_opt "ODOC_GC_STATS" with 134 + | None | Some "" | Some "0" -> () 135 + | Some _ -> 136 + at_exit (fun () -> 137 + Printf.eprintf 138 + "ODOC_FLATTEN_WOULD phase=cmti total=%d attrs=%d stops=%d would=%d in_stop=%d all_hidden=%d items=%d shadowed=%d alias=%d/%d path=%d/%d sig=%d/%d with=%d/%d typeof=%d/%d strengthen=%d/%d\n%!" 139 + !flatten_total_includes !flatten_total_attributes !flatten_total_stops 140 + !flatten_would_splice !flatten_would_splice_instop 141 + !flatten_would_splice_allhidden !flatten_would_splice_items 142 + !flatten_would_splice_shadowed 143 + !flatten_kind_alias_flat !flatten_kind_alias 144 + !flatten_kind_path_flat !flatten_kind_path 145 + !flatten_kind_sig_flat !flatten_kind_sig 146 + !flatten_kind_with_flat !flatten_kind_with 147 + !flatten_kind_typeof_flat !flatten_kind_typeof 148 + !flatten_kind_strengthen_flat !flatten_kind_strengthen) 149 + 37 150 let opt_map f = function 38 151 | None -> None 39 152 | Some x -> Some (f x) ··· 815 928 let open Module in 816 929 Alias (Env.Path.read_module env.ident_env p, None) 817 930 818 - and read_signature_item env parent item = 931 + and read_signature_item ~in_stop env parent item = 819 932 let open Signature in 820 933 match item.sig_desc with 821 934 | Tsig_value vd -> ··· 858 971 #else 859 972 | Tsig_include incl -> 860 973 #endif 861 - read_include env parent incl 974 + read_include ~in_stop:!in_stop env parent incl 862 975 | Tsig_class cls -> 863 976 read_class_descriptions env parent cls 864 977 | Tsig_class_type cltyps -> 865 978 read_class_type_declarations env parent cltyps 866 979 | Tsig_attribute attr -> begin 980 + incr flatten_total_attributes; 867 981 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in 868 982 match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with 869 983 | None -> [] 984 + | Some (`Stop as doc) -> 985 + incr flatten_total_stops; 986 + in_stop := not !in_stop; 987 + Doc_attr.skip_doc_parsing := !in_stop; 988 + [Comment doc] 870 989 | Some doc -> [Comment doc] 871 990 end 872 991 #if OCAML_VERSION >= (4,8,0) ··· 904 1023 905 1024 #endif 906 1025 907 - and read_include env parent incl = 1026 + and read_include ?(in_stop = false) env parent incl = 908 1027 let open Include in 909 1028 let loc = Doc_attr.read_location incl.incl_loc in 910 1029 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in 911 1030 let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in 912 1031 let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in 1032 + incr flatten_total_includes; 1033 + let all_hidden = all_items_hidden content.Signature.items in 1034 + let should_flatten = in_stop || all_hidden in 1035 + classify_mty_desc incl.incl_mod.mty_desc ~flat:should_flatten; 1036 + if should_flatten then begin 1037 + incr flatten_would_splice; 1038 + if in_stop then incr flatten_would_splice_instop; 1039 + if all_hidden && not in_stop then incr flatten_would_splice_allhidden; 1040 + flatten_would_splice_items := 1041 + !flatten_would_splice_items + List.length content.Signature.items; 1042 + let s : Include.shadowed = shadowed in 1043 + if s.s_modules <> [] || s.s_module_types <> [] 1044 + || s.s_values <> [] || s.s_types <> [] 1045 + || s.s_classes <> [] || s.s_class_types <> [] 1046 + then incr flatten_would_splice_shadowed 1047 + end; 1048 + let shadowed_empty = 1049 + let s : Include.shadowed = shadowed in 1050 + s.s_modules = [] && s.s_module_types = [] 1051 + && s.s_values = [] && s.s_types = [] 1052 + && s.s_classes = [] && s.s_class_types = [] 1053 + in 1054 + if should_flatten && shadowed_empty then 1055 + (* For includes in doc-stop blocks or whose every item is hidden, splice 1056 + the expansion directly into the enclosing signature. The items won't be 1057 + rendered (hidden by name convention or explicit stop marker) but remain 1058 + available for cross-references. Skip when shadowed is non-empty: that 1059 + would require rewriting shadowed names in the enclosing signature. *) 1060 + content.Signature.items 1061 + else 913 1062 (* Use a synthetic parent for the include's module type expression to avoid 914 1063 identifier conflicts with items in the enclosing signature. Items inside 915 1064 the include expression (like TypeSubstitutions) will get identifiers under ··· 917 1066 let include_parent = Identifier.fresh_include_parent parent in 918 1067 let include_container = (include_parent :> Identifier.LabelParent.t) in 919 1068 let expr = read_module_type env include_parent include_container incl.incl_mod in 920 - let umty = Odoc_model.Lang.umty_of_mty expr in 1069 + let umty = Odoc_model.Lang.umty_of_mty expr in 921 1070 let expansion = { content; shadowed; } in 922 1071 #if defined OXCAML 923 1072 match umty, incl.incl_kind with ··· 958 1107 in 959 1108 Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent sg.sig_items 960 1109 in 1110 + let in_stop = ref false in 1111 + let prev_skip = !Doc_attr.skip_doc_parsing in 1112 + Doc_attr.skip_doc_parsing := false; 961 1113 let items = 962 1114 List.fold_left 963 1115 (fun items item -> 964 - List.rev_append (read_signature_item env parent item) items) 1116 + List.rev_append (read_signature_item ~in_stop env parent item) items) 965 1117 [] items 966 1118 |> List.rev 967 1119 in 1120 + Doc_attr.skip_doc_parsing := prev_skip; 968 1121 match doc_post with 969 1122 | {elements=[]; _} -> 970 1123 ({ Signature.items; compiled = false; removed = []; doc }, tags)
+51 -5
odoc/src/loader/doc_attr.cppo.ml
··· 124 124 let span = read_location loc in 125 125 Location_.at span elt 126 126 127 + let doc_parse_time = ref 0.0 128 + let doc_parse_count = ref 0 129 + let doc_parse_skipped = ref 0 130 + let skip_doc_parsing = ref false 131 + 132 + let tag_docs = 133 + match Sys.getenv_opt "ODOC_TAG_DOCS" with 134 + | Some "1" | Some "true" -> true 135 + | _ -> false 136 + 137 + let doc_cache : (string, Odoc_parser.Ast.t) Hashtbl.t = Hashtbl.create 256 138 + let doc_cache_hits = ref 0 139 + 140 + let () = 141 + match Sys.getenv_opt "ODOC_GC_STATS" with 142 + | None | Some "" | Some "0" -> () 143 + | Some _ -> 144 + at_exit (fun () -> 145 + Printf.eprintf "ODOC_DOC_PARSE time=%.3f count=%d skipped=%d cache_hits=%d cache_size=%d\n%!" 146 + !doc_parse_time !doc_parse_count !doc_parse_skipped 147 + !doc_cache_hits (Hashtbl.length doc_cache)) 148 + 127 149 let attached ~warnings_tag internal_tags parent attrs = 128 150 let rec loop acc_docs acc_alerts = function 129 151 | attr :: rest -> ( 130 152 match parse_attribute attr with 131 153 | Some (`Doc (str, loc)) -> 132 - let ast_docs = 133 - Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str 134 - |> Error.raise_parser_warnings 135 - in 136 - loop (List.rev_append ast_docs acc_docs) acc_alerts rest 154 + if !skip_doc_parsing then begin 155 + incr doc_parse_skipped; 156 + loop acc_docs acc_alerts rest 157 + end else begin 158 + let n = !doc_parse_count in 159 + let str = 160 + if tag_docs then 161 + Printf.sprintf "{b ODOC_TAG/%s/%d} %s" 162 + loc.loc_start.pos_fname n str 163 + else str 164 + in 165 + let ast_docs = 166 + match Hashtbl.find_opt doc_cache str with 167 + | Some cached -> 168 + incr doc_cache_hits; 169 + cached 170 + | None -> 171 + let t0 = Sys.time () in 172 + let parsed = 173 + Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str 174 + |> Error.raise_parser_warnings 175 + in 176 + doc_parse_time := !doc_parse_time +. (Sys.time () -. t0); 177 + Hashtbl.replace doc_cache str parsed; 178 + parsed 179 + in 180 + incr doc_parse_count; 181 + loop (List.rev_append ast_docs acc_docs) acc_alerts rest 182 + end 137 183 | Some (`Alert (name, p, loc)) -> 138 184 let elt = mk_alert_payload ~loc name p in 139 185 loop acc_docs (elt :: acc_alerts) rest
+2
odoc/src/loader/doc_attr.mli
··· 93 93 ] 94 94 95 95 val parse_attribute : Parsetree.attribute -> parsed_attribute option 96 + 97 + val skip_doc_parsing : bool ref
+15
odoc/src/odoc/bin/main.ml
··· 78 78 let pct = 100.0 *. float_of_int words /. float_of_int (max 1 !total) in 79 79 Printf.eprintf "%-120s %10.1f %5.1f%%\n" site mb pct)) 80 80 81 + (* Lightweight per-process GC totals. 82 + Enable with ODOC_GC_STATS=1. Prints a single machine-parseable line on 83 + stderr at process exit. Used by odoc_driver to rank invocations by 84 + allocation. *) 85 + let () = 86 + match Sys.getenv_opt "ODOC_GC_STATS" with 87 + | None | Some "" | Some "0" -> () 88 + | Some _ -> 89 + at_exit (fun () -> 90 + let s = Gc.quick_stat () in 91 + Printf.eprintf 92 + "ODOC_GC_STATS minor_words=%.0f promoted_words=%.0f major_words=%.0f top_heap_words=%d heap_words=%d\n%!" 93 + s.minor_words s.promoted_words s.major_words 94 + s.top_heap_words s.heap_words) 95 + 81 96 (* Load all installed extensions at startup *) 82 97 let () = Sites.Plugins.Extensions.load_all () 83 98
+33
odoc/src/xref2/compile.ml
··· 7 7 open Lang 8 8 module Id = Paths.Identifier 9 9 10 + let include_calls = ref 0 11 + 12 + let include_by_loc : (string, int) Hashtbl.t = Hashtbl.create 128 13 + 14 + let bump_loc (span : Odoc_model.Location_.span) = 15 + let key = Printf.sprintf "%s:%d" span.file span.start.line in 16 + match Hashtbl.find_opt include_by_loc key with 17 + | Some r -> Hashtbl.replace include_by_loc key (r + 1) 18 + | None -> Hashtbl.add include_by_loc key 1 19 + 20 + let () = 21 + match Sys.getenv_opt "ODOC_GC_STATS" with 22 + | None | Some "" | Some "0" -> () 23 + | Some _ -> 24 + at_exit (fun () -> 25 + Printf.eprintf "ODOC_INCLUDE_COUNT phase=compile n=%d unique=%d\n%!" 26 + !include_calls 27 + (Hashtbl.length include_by_loc); 28 + let entries = 29 + Hashtbl.fold (fun k v acc -> (k, v) :: acc) include_by_loc [] 30 + in 31 + let top = 32 + List.sort (fun (_, a) (_, b) -> compare b a) entries 33 + |> List.filteri (fun i _ -> i < 10) 34 + in 35 + List.iter 36 + (fun (k, v) -> 37 + Printf.eprintf "ODOC_INCLUDE_TOP phase=compile loc=%s count=%d\n%!" 38 + k v) 39 + top) 40 + 10 41 module Opt = struct 11 42 let map f = function Some x -> Some (f x) | None -> None 12 43 end ··· 412 443 413 444 and include_ : Env.t -> Include.t -> Include.t * Env.t = 414 445 fun env i -> 446 + incr include_calls; 447 + bump_loc i.loc; 415 448 let open Include in 416 449 let decl = Component.Of_Lang.(include_decl (empty ()) i.decl) in 417 450 let get_expansion () =
+68
odoc/src/xref2/link.ml
··· 3 3 open Lang 4 4 module Id = Paths.Identifier 5 5 6 + let include_calls = ref 0 7 + 8 + let include_by_loc : (string, int) Hashtbl.t = Hashtbl.create 128 9 + 10 + let bump_loc (span : Odoc_model.Location_.span) = 11 + let key = Printf.sprintf "%s:%d" span.file span.start.line in 12 + match Hashtbl.find_opt include_by_loc key with 13 + | Some r -> Hashtbl.replace include_by_loc key (r + 1) 14 + | None -> Hashtbl.add include_by_loc key 1 15 + 16 + let () = 17 + match Sys.getenv_opt "ODOC_GC_STATS" with 18 + | None | Some "" | Some "0" -> () 19 + | Some _ -> 20 + at_exit (fun () -> 21 + Printf.eprintf "ODOC_INCLUDE_COUNT phase=link n=%d unique=%d\n%!" 22 + !include_calls 23 + (Hashtbl.length include_by_loc); 24 + let entries = 25 + Hashtbl.fold (fun k v acc -> (k, v) :: acc) include_by_loc [] 26 + in 27 + let top = 28 + List.sort (fun (_, a) (_, b) -> compare b a) entries 29 + |> List.filteri (fun i _ -> i < 10) 30 + in 31 + List.iter 32 + (fun (k, v) -> 33 + Printf.eprintf "ODOC_INCLUDE_TOP phase=link loc=%s count=%d\n%!" k v) 34 + top) 35 + 6 36 module Opt = struct 7 37 let map f = function Some x -> Some (f x) | None -> None 8 38 end ··· 431 461 let value = Lookup_failures.with_location loc (fun () -> fn ~loc value) in 432 462 { value; location = loc } 433 463 464 + and doc_needs_resolving (d : Comment.docs) = 465 + let inline_needs (x : Comment.inline_element) = 466 + match x with `Reference _ -> true | _ -> false 467 + in 468 + let rec nestable_needs (x : Comment.nestable_block_element) = 469 + match x with 470 + | `Paragraph elts -> 471 + List.exists (fun e -> inline_needs e.Location_.value) elts 472 + | `List (_, yss) -> 473 + List.exists 474 + (List.exists (fun e -> nestable_needs e.Location_.value)) 475 + yss 476 + | `Table { data; _ } -> 477 + List.exists 478 + (List.exists (fun (cell, _) -> 479 + List.exists (fun e -> nestable_needs e.Location_.value) cell)) 480 + data 481 + | `Modules _ -> true 482 + | `Media (`Reference _, _, _) -> true 483 + | _ -> false 484 + in 485 + let block_needs (x : Comment.block_element) = 486 + match x with 487 + | #Comment.nestable_block_element as x -> nestable_needs x 488 + | `Heading _ -> true 489 + | `Tag (`Custom _) -> true 490 + | `Tag (`Raise (`Reference _, _)) -> true 491 + | `Tag (`Deprecated c | `Param (_, c) | `Return c | `See (_, _, c) 492 + | `Before (_, c)) -> 493 + List.exists (fun e -> nestable_needs e.Location_.value) c 494 + | `Tag _ -> false 495 + in 496 + List.exists (fun e -> block_needs e.Location_.value) d.elements 497 + 434 498 and comment_docs env parent d = 499 + if not (doc_needs_resolving d) then d 500 + else 435 501 { 436 502 Comment.elements = 437 503 List.rev_map ··· 772 838 773 839 and include_ : Env.t -> Include.t -> Include.t = 774 840 fun env i -> 841 + incr include_calls; 842 + bump_loc i.loc; 775 843 let open Include in 776 844 let decl = include_decl env i.parent i.decl in 777 845 let doc = comment_docs env i.parent i.doc in