this repo has no description
Merge branch 'perf-investigation-2'
Odoc performance investigation: 14 commits reducing total allocation
by 40% and wall time by 14% on odoc_driver core (OxCaml switch).
Key optimisations:
- Flatten hidden PPX-monomorphization includes at load time
- Memoize doc comment parsing + semantic analysis
- O(n) shadow detection (was O(n^2))
- Hash-first identifier compare (eliminates most Map lookup compare_val)
- Cache mode printing (avoid Format.asprintf per arg)
- segment_to_string: direct string concat instead of Format.asprintf
- Buffered HTML output (avoid channel mutex per chunk)
- Stream Renderer.page children via Seq.t (bounded peak memory)
Details in commits a1802364..a92f00fb.
+986
-93
+33
doc/perf-investigation-2-log.md
+33
doc/perf-investigation-2-log.md
···
1
+
# odoc Performance Investigation — Round 2
2
+
3
+
Ongoing notebook for the next phase of odoc performance work, continuing from the `perf-bench-base` branch (merged into main as of `9357d7fd`).
4
+
5
+
## Prior art
6
+
7
+
- Original plan: `doc/plans/2026-02-15-performance-investigation.md` on standalone odoc `perf-investigation` branch
8
+
- Round 1 execution: `perf-bench-base` branch, session log `~/.claude/projects/-cache-jons-agent-workspace-odoc-pp/5f6e8907-5c90-46cc-b1c7-06f4de7484da.jsonl` (through 2026-04-13)
9
+
10
+
## Round 1 — landed optimizations
11
+
12
+
- Physical-equality sharing + `is_identity` short-circuits in `src/xref2/subst.ml`
13
+
- Sharing in `reresolve_*` and `prefix_signature` in `src/xref2/tools.ml`
14
+
- `Of_Lang` path-conversion sharing in `src/xref2/component.ml`
15
+
- Per-env `Shape_reduce.Make` cache in `src/xref2/shape_tools.cppo.ml`
16
+
- `open struct` module-alias fix in `src/xref2/find.ml` (resolved 76K unresolved xrefs on `core`)
17
+
- `ODOC_STATMEMPROF` instrumentation in `src/odoc/bin/main.ml`
18
+
19
+
## Round 2 — open threads
20
+
21
+
(Fill in as investigation proceeds.)
22
+
23
+
## Log
24
+
25
+
### YYYY-MM-DD — <topic>
26
+
27
+
Hypothesis:
28
+
29
+
Measurement:
30
+
31
+
Result:
32
+
33
+
Next:
+33
src/document/generator.ml
+33
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))
+8
-4
src/document/renderer.ml
+8
-4
src/document/renderer.ml
···
8
8
filename : Fpath.t;
9
9
path : Url.Path.t;
10
10
content : Format.formatter -> unit;
11
-
children : page list;
11
+
children : page Seq.t;
12
+
(** Subpages are produced one at a time so we can format+discard
13
+
each page before building its siblings. Peak memory during
14
+
html-generate is bounded by the ancestor chain (plus current
15
+
leaf) rather than the entire library tree. *)
12
16
assets : Odoc_extension_registry.asset list;
13
17
(** Binary assets to write alongside this page *)
14
18
}
15
19
16
20
let traverse ~f t =
17
-
let rec aux node =
18
-
f node.filename node.content node.assets;
19
-
List.iter aux node.children
21
+
let rec aux { filename; content; assets; children; _ } =
22
+
f filename content assets;
23
+
Seq.iter aux children
20
24
in
21
25
List.iter aux t
22
26
+3
-1
src/document/url.ml
+3
-1
src/document/url.ml
···
275
275
| { kind = `LeafPage; parent = None; name = "index" } -> true
276
276
| { kind = `LeafPage; parent = Some p; name = "index" } -> is_prefix p url2
277
277
| _ -> (
278
-
if url1 = url2 then true
278
+
(* Physical equality first — same URL is shared within a page, so this
279
+
catches the common case without walking the parent chain. *)
280
+
if url1 == url2 || url1 = url2 then true
279
281
else
280
282
match url2 with
281
283
| { parent = Some parent; _ } -> is_prefix url1 parent
+82
-2
src/driver/bin/odoc_driver.ml
+82
-2
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
src/driver/cmd_outputs.ml
+15
-7
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
src/driver/odoc.ml
+17
-28
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
src/driver/run.ml
+108
-1
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)
+10
-2
src/html/generator.ml
+10
-2
src/html/generator.ml
···
696
696
page ~config ~sidebar content
697
697
698
698
and subpages ~config ~sidebar subpages =
699
-
List.map (include_ ~config ~sidebar) subpages
699
+
(* Produce subpages as a Seq so each child's Html.elt tree is built
700
+
only when the traversal reaches it. Seq.map is lazy: the mapping
701
+
function runs once per child when Seq.iter pulls from it. *)
702
+
Seq.map (include_ ~config ~sidebar) (List.to_seq subpages)
700
703
701
704
and page ~config ~sidebar p : Odoc_document.Renderer.page =
702
705
let { Page.preamble = _; items = i; url; source_anchor; resources; assets } =
703
706
Doctree.Labels.disambiguate_page ~enter_subpages:false p
704
707
in
705
-
let subpages = subpages ~config ~sidebar @@ Doctree.Subpages.compute p in
708
+
(* Build subpages lazily as a Seq — each child's Html.elt tree is
709
+
constructed only when traverse pulls it. Combined with the
710
+
ancestor-only reachability of traverse, peak memory during
711
+
html-generate is bounded by the ancestor chain (O(depth)) rather
712
+
than the whole library (O(pages)). *)
713
+
let subpages = subpages ~config ~sidebar (Doctree.Subpages.compute p) in
706
714
let resolve = Link.Current url in
707
715
let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~sidebar ~url in
708
716
let sidebar_html =
+1
-1
src/html/html_fragment_json.ml
+1
-1
src/html/html_fragment_json.ml
···
110
110
(List.map (Format.asprintf "%a" htmlpp) content)) );
111
111
]))
112
112
in
113
-
{ Odoc_document.Renderer.filename; content; children = []; path = url; assets = [] }
113
+
{ Odoc_document.Renderer.filename; content; children = Seq.empty; path = url; assets = [] }
114
114
115
115
(* Register as the "json" shell *)
116
116
let () =
+1
-1
src/html/html_fragment_json.mli
+1
-1
src/html/html_fragment_json.mli
···
12
12
assets:Odoc_extension_registry.asset list ->
13
13
header:Html_types.flow5_without_header_footer Html.elt list ->
14
14
Html_types.div_content Html.elt list ->
15
-
Odoc_document.Renderer.page list ->
15
+
Odoc_document.Renderer.page Seq.t ->
16
16
Odoc_document.Renderer.page
17
17
18
18
val make_src :
+1
-1
src/html/html_page.ml
+1
-1
src/html/html_page.ml
···
339
339
let content =
340
340
src_page_creator ~breadcrumbs ~config ~url ~header ~sidebar title content
341
341
in
342
-
{ Odoc_document.Renderer.filename; content; children = []; path = url; assets = [] }
342
+
{ Odoc_document.Renderer.filename; content; children = Seq.empty; path = url; assets = [] }
343
343
344
344
(* Register as the default shell *)
345
345
let () =
+1
-1
src/html/html_page.mli
+1
-1
src/html/html_page.mli
···
31
31
resources:Odoc_extension_registry.resource list ->
32
32
assets:Odoc_extension_registry.asset list ->
33
33
Html_types.div_content Html.elt list ->
34
-
Odoc_document.Renderer.page list ->
34
+
Odoc_document.Renderer.page Seq.t ->
35
35
Odoc_document.Renderer.page
36
36
(** [make ?theme_uri (body, children)] calls "the page creator" to turn [body]
37
37
into an [[ `Html ] elt]. If [theme_uri] is provided, it will be used to
+1
-1
src/html/html_shell.ml
+1
-1
src/html/html_shell.ml
+1
-1
src/html/html_shell.mli
+1
-1
src/html/html_shell.mli
···
21
21
source_anchor : string option;
22
22
resources : Odoc_extension_registry.resource list;
23
23
assets : Odoc_extension_registry.asset list;
24
-
children : Odoc_document.Renderer.page list;
24
+
children : Odoc_document.Renderer.page Seq.t;
25
25
}
26
26
27
27
(** Data for assembling a source code page. *)
+10
-2
src/html/link.ml
+10
-2
src/html/link.ml
···
7
7
let for_printing url = List.map snd @@ Url.Path.to_list url
8
8
9
9
let segment_to_string (kind, name) =
10
-
Format.asprintf "%a%s" Url.Path.pp_disambiguating_prefix kind name
10
+
(* Avoid Format.asprintf in the hot path. The disambiguating prefix is
11
+
either empty (for Module/Page/LeafPage/File/SourcePage) or just
12
+
"<kind>-", so build the result directly. *)
13
+
match kind with
14
+
| `Module | `Page | `LeafPage | `File | `SourcePage -> name
15
+
| _ -> Url.Path.string_of_kind kind ^ "-" ^ name
11
16
12
17
let is_leaf_page url = url.Url.Path.kind = `LeafPage
13
18
···
65
70
66
71
let rec drop_shared_prefix l1 l2 =
67
72
match (l1, l2) with
68
-
| l1 :: l1s, l2 :: l2s when l1 = l2 -> drop_shared_prefix l1s l2s
73
+
(* l1 and l2 are string lists. String.equal uses a direct byte compare
74
+
without dispatching through compare_val. *)
75
+
| l1 :: l1s, l2 :: l2s when String.equal l1 l2 ->
76
+
drop_shared_prefix l1s l2s
69
77
| _, _ -> (l1, l2)
70
78
71
79
let href ~config ~resolve t =
+1
-1
src/latex/generator.ml
+1
-1
src/latex/generator.ml
···
522
522
if config.with_children then link_children ppf children else ()
523
523
in
524
524
let content ppf = Fmt.pf ppf "@[<v>%a@,%t@]@." pp content children_input in
525
-
{ Odoc_document.Renderer.filename; content; children; path = url; assets = [] }
525
+
{ Odoc_document.Renderer.filename; content; children = List.to_seq children; path = url; assets = [] }
526
526
end
527
527
528
528
module Page = struct
+14
-1
src/loader/cmi.cppo.ml
+14
-1
src/loader/cmi.cppo.ml
···
495
495
#if defined OXCAML
496
496
(** Extract non-default mode strings from an OxCaml argument mode.
497
497
Replicates the logic from [Printtyp.tree_of_modes]. *)
498
+
(* Cache for mode printing — mode constants are a small finite set so the
499
+
cache stays tiny. Avoids allocating a fresh Format buffer per call. *)
500
+
let mode_print_cache : (Obj.t, string) Hashtbl.t = Hashtbl.create 16
501
+
502
+
let print_mode_cached (print : Format.formatter -> 'a -> unit) (v : 'a) : string =
503
+
let key = Obj.repr v in
504
+
match Hashtbl.find_opt mode_print_cache key with
505
+
| Some s -> s
506
+
| None ->
507
+
let s = Format.asprintf "%a" print v in
508
+
Hashtbl.replace mode_print_cache key s;
509
+
s
510
+
498
511
let extract_arg_modes marg =
499
512
let modes = Mode.Alloc.zap_to_legacy marg in
500
513
let diff = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy in
···
520
533
| _, _ -> diff.portability
521
534
in
522
535
let print_opt print a =
523
-
Option.map (fun v -> Format.asprintf "%a" print v) a
536
+
Option.map (fun v -> print_mode_cached print v) a
524
537
in
525
538
List.filter_map Fun.id
526
539
[ print_opt Mode.Locality.Const.print diff.areality
+123
-4
src/loader/cmt.cppo.ml
+123
-4
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 ~inherit_skip 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
+
Doc_attr.skip_doc_parsing := inherit_skip || !in_stop;
645
+
[Comment doc]
585
646
| Some doc -> [Comment doc]
586
647
587
-
and read_include env parent incl =
648
+
and read_include ?(in_stop = false) env parent incl =
588
649
let open Include in
589
650
let loc = Doc_attr.read_location incl.incl_loc in
590
651
let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
···
607
668
umty_of_mty mty
608
669
in
609
670
let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
671
+
incr flatten_total_includes;
672
+
let all_hidden = all_items_hidden content.Signature.items in
673
+
let should_flatten = in_stop || all_hidden in
674
+
if should_flatten then begin
675
+
incr flatten_would_splice;
676
+
if in_stop then incr flatten_would_splice_instop;
677
+
if all_hidden && not in_stop then incr flatten_would_splice_allhidden;
678
+
flatten_would_splice_items :=
679
+
!flatten_would_splice_items + List.length content.Signature.items;
680
+
let s : Include.shadowed = shadowed in
681
+
if s.s_modules <> [] || s.s_module_types <> []
682
+
|| s.s_values <> [] || s.s_types <> []
683
+
|| s.s_classes <> [] || s.s_class_types <> []
684
+
then incr flatten_would_splice_shadowed
685
+
end;
686
+
let shadowed_empty =
687
+
let s : Include.shadowed = shadowed in
688
+
s.s_modules = [] && s.s_module_types = []
689
+
&& s.s_values = [] && s.s_types = []
690
+
&& s.s_classes = [] && s.s_class_types = []
691
+
in
692
+
if should_flatten && shadowed_empty then
693
+
Signature.Comment `Stop :: content.Signature.items @ [ Signature.Comment `Stop ]
694
+
else
610
695
let expansion = { content; shadowed; } in
611
696
match decl_modty with
612
697
| Some m ->
···
630
715
'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ ->
631
716
_ * 'tags =
632
717
fun internal_tags env parent str ->
718
+
let t_env = Sys.time () in
633
719
let e' = Env.add_structure_tree_items parent str env.ident_env in
720
+
let t_env_done = Sys.time () in
634
721
let env = { env with ident_env=e' } in
635
722
let items, (doc, doc_post), tags =
636
723
let classify item =
···
641
728
in
642
729
Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent str.str_items
643
730
in
731
+
let t_extract_done = Sys.time () in
732
+
(match Sys.getenv_opt "ODOC_GC_STATS" with
733
+
| Some s when s <> "" && s <> "0" && t_env_done -. t_env > 0.05 ->
734
+
Printf.eprintf "ODOC_STRUCT_TIME add_env=%.3f extract_top=%.3f n_items=%d\n%!"
735
+
(t_env_done -. t_env) (t_extract_done -. t_env_done) (List.length str.str_items)
736
+
| _ -> ());
737
+
let in_stop = ref false in
738
+
let inherit_skip = !Doc_attr.skip_doc_parsing in
739
+
let item_times = ref [] in
644
740
let items =
645
741
List.fold_left
646
742
(fun items item ->
647
-
List.rev_append (read_structure_item env parent item) items)
743
+
let t0 = Sys.time () in
744
+
let result = read_structure_item ~in_stop ~inherit_skip env parent item in
745
+
let dt = Sys.time () -. t0 in
746
+
if dt > 0.1 then begin
747
+
let name = match item.str_desc with
748
+
| Tstr_modtype mtd -> Printf.sprintf "module type %s" (Ident.name mtd.mtd_id)
749
+
| Tstr_module mb ->
750
+
(match mb.mb_id with Some id -> Printf.sprintf "module %s" (Ident.name id) | None -> "module _")
751
+
| Tstr_value _ -> "let ..."
752
+
| Tstr_type _ -> "type ..."
753
+
| Tstr_include _ -> "include ..."
754
+
| _ -> "other"
755
+
in
756
+
item_times := (name, dt, List.length result) :: !item_times
757
+
end;
758
+
List.rev_append result items)
648
759
[] items
649
760
|> List.rev
650
761
in
762
+
Doc_attr.skip_doc_parsing := inherit_skip;
763
+
(match Sys.getenv_opt "ODOC_GC_STATS" with
764
+
| Some s when s <> "" && s <> "0" ->
765
+
let sorted = List.sort (fun (_, a, _) (_, b, _) -> compare b a) !item_times in
766
+
List.iter (fun (name, dt, n_items) ->
767
+
Printf.eprintf "ODOC_ITEM_TIME name=%s time=%.3f items=%d\n%!" name dt n_items
768
+
) (List.filteri (fun i _ -> i < 10) sorted)
769
+
| _ -> ());
651
770
match doc_post with
652
771
| { elements = [] ; _} ->
653
772
({ Signature.items; compiled = false; removed = []; doc }, tags)
+189
-6
src/loader/cmti.cppo.ml
+189
-6
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 ~inherit_skip 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 := inherit_skip || !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
-
let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
1031
+
(* Pre-scan the compiler's elaborated signature for __ names. If all items
1032
+
have double-underscore names, we'll flatten this include and the docs
1033
+
will never render — skip parsing them. *)
1034
+
let sig_items = Odoc_model.Compat.signature incl.incl_type in
1035
+
let all_names_hidden =
1036
+
sig_items <> [] &&
1037
+
List.for_all (fun item ->
1038
+
let open Odoc_model.Compat in
1039
+
match item with
1040
+
| Sig_value (id, _, _) -> contains_double_underscore (Ident.name id)
1041
+
| Sig_type (id, _, _, _) -> contains_double_underscore (Ident.name id)
1042
+
| Sig_module (id, _, _, _, _) -> contains_double_underscore (Ident.name id)
1043
+
| Sig_modtype (id, _, _) -> contains_double_underscore (Ident.name id)
1044
+
| Sig_class (id, _, _, _) -> contains_double_underscore (Ident.name id)
1045
+
| Sig_class_type (id, _, _, _) -> contains_double_underscore (Ident.name id)
1046
+
| Sig_typext _ -> false) sig_items
1047
+
in
1048
+
let n_sig_items = List.length sig_items in
1049
+
let prev_skip_include = !Doc_attr.skip_doc_parsing in
1050
+
if in_stop || all_names_hidden then
1051
+
Doc_attr.skip_doc_parsing := true;
1052
+
let t_read = Sys.time () in
1053
+
let content, shadowed = Cmi.read_signature_noenv env parent sig_items in
1054
+
let dt_read = Sys.time () -. t_read in
1055
+
Doc_attr.skip_doc_parsing := prev_skip_include;
1056
+
if dt_read > 0.01 then
1057
+
(match Sys.getenv_opt "ODOC_GC_STATS" with
1058
+
| Some s when s <> "" && s <> "0" ->
1059
+
Printf.eprintf "ODOC_INCLUDE_READ sig_items=%d lang_items=%d time=%.3f file=%s:%d\n%!"
1060
+
n_sig_items (List.length content.Signature.items) dt_read
1061
+
loc.file loc.start.line
1062
+
| _ -> ());
1063
+
incr flatten_total_includes;
1064
+
let all_hidden = all_items_hidden content.Signature.items in
1065
+
let should_flatten = in_stop || all_hidden in
1066
+
classify_mty_desc incl.incl_mod.mty_desc ~flat:should_flatten;
1067
+
if should_flatten then begin
1068
+
incr flatten_would_splice;
1069
+
if in_stop then incr flatten_would_splice_instop;
1070
+
if all_hidden && not in_stop then incr flatten_would_splice_allhidden;
1071
+
flatten_would_splice_items :=
1072
+
!flatten_would_splice_items + List.length content.Signature.items;
1073
+
let s : Include.shadowed = shadowed in
1074
+
if s.s_modules <> [] || s.s_module_types <> []
1075
+
|| s.s_values <> [] || s.s_types <> []
1076
+
|| s.s_classes <> [] || s.s_class_types <> []
1077
+
then incr flatten_would_splice_shadowed
1078
+
end;
1079
+
let shadowed_empty =
1080
+
let s : Include.shadowed = shadowed in
1081
+
s.s_modules = [] && s.s_module_types = []
1082
+
&& s.s_values = [] && s.s_types = []
1083
+
&& s.s_classes = [] && s.s_class_types = []
1084
+
in
1085
+
if should_flatten && shadowed_empty then
1086
+
(* For includes in doc-stop blocks or whose every item is hidden, splice
1087
+
the expansion directly into the enclosing signature. Wrap in Stop
1088
+
markers so the document generator skips them (restoring the (**/**)
1089
+
wrappers that were present in the typedtree but lost when we read the
1090
+
expansion from the elaborated Types.signature). *)
1091
+
Signature.Comment `Stop :: content.Signature.items @ [ Signature.Comment `Stop ]
1092
+
else
913
1093
(* Use a synthetic parent for the include's module type expression to avoid
914
1094
identifier conflicts with items in the enclosing signature. Items inside
915
1095
the include expression (like TypeSubstitutions) will get identifiers under
···
917
1097
let include_parent = Identifier.fresh_include_parent parent in
918
1098
let include_container = (include_parent :> Identifier.LabelParent.t) in
919
1099
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
1100
+
let umty = Odoc_model.Lang.umty_of_mty expr in
921
1101
let expansion = { content; shadowed; } in
922
1102
#if defined OXCAML
923
1103
match umty, incl.incl_kind with
···
958
1138
in
959
1139
Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent sg.sig_items
960
1140
in
1141
+
let in_stop = ref false in
1142
+
let inherit_skip = !Doc_attr.skip_doc_parsing in
961
1143
let items =
962
1144
List.fold_left
963
1145
(fun items item ->
964
-
List.rev_append (read_signature_item env parent item) items)
1146
+
List.rev_append (read_signature_item ~in_stop ~inherit_skip env parent item) items)
965
1147
[] items
966
1148
|> List.rev
967
1149
in
1150
+
Doc_attr.skip_doc_parsing := inherit_skip;
968
1151
match doc_post with
969
1152
| {elements=[]; _} ->
970
1153
({ Signature.items; compiled = false; removed = []; doc }, tags)
+115
-6
src/loader/doc_attr.cppo.ml
+115
-6
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
+
(* Cache for the full semantic analysis result (parse + ast_to_comment).
141
+
Keyed on the raw doc string. Returns the processed Comment elements.
142
+
Correct for docs without section headings (which is ~all PPX-duplicated docs). *)
143
+
let semantic_cache : (string, Odoc_model.Comment.block_element Odoc_model.Location_.with_location list) Hashtbl.t = Hashtbl.create 256
144
+
let semantic_cache_hits = ref 0
145
+
146
+
let () =
147
+
match Sys.getenv_opt "ODOC_GC_STATS" with
148
+
| None | Some "" | Some "0" -> ()
149
+
| Some _ ->
150
+
at_exit (fun () ->
151
+
Printf.eprintf "ODOC_DOC_PARSE time=%.3f count=%d skipped=%d cache_hits=%d cache_size=%d\n%!"
152
+
!doc_parse_time !doc_parse_count !doc_parse_skipped
153
+
!doc_cache_hits (Hashtbl.length doc_cache))
154
+
127
155
let attached ~warnings_tag internal_tags parent attrs =
156
+
if !skip_doc_parsing then begin
157
+
incr doc_parse_skipped;
158
+
let empty_tags : type a. a Odoc_model.Semantics.handle_internal_tags -> a = function
159
+
| Odoc_model.Semantics.Expect_none -> ()
160
+
| Odoc_model.Semantics.Expect_canonical -> None
161
+
| Odoc_model.Semantics.Expect_status -> `Default
162
+
| Odoc_model.Semantics.Expect_page_tags -> Odoc_model.Frontmatter.empty
163
+
in
164
+
({ Comment.elements = []; warnings_tag }, empty_tags internal_tags)
165
+
end else
128
166
let rec loop acc_docs acc_alerts = function
129
167
| attr :: rest -> (
130
168
match parse_attribute attr with
131
169
| 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
170
+
begin
171
+
let n = !doc_parse_count in
172
+
let str =
173
+
if tag_docs then begin
174
+
(match Sys.getenv_opt "ODOC_TAG_MANIFEST" with
175
+
| Some f ->
176
+
let oc = open_out_gen [Open_append; Open_creat] 0o644 f in
177
+
let text_preview =
178
+
let s = String.trim str in
179
+
if String.length s > 60 then String.sub s 0 60 ^ "..."
180
+
else s
181
+
in
182
+
Printf.fprintf oc "%d\t%s:%d\t%s\t%s\n"
183
+
n loc.loc_start.pos_fname loc.loc_start.pos_lnum
184
+
(if !skip_doc_parsing then "SKIP" else "PARSE")
185
+
text_preview;
186
+
close_out oc
187
+
| None -> ());
188
+
Printf.sprintf "{b ODOC_TAG/%s/%d} %s"
189
+
loc.loc_start.pos_fname n str
190
+
end
191
+
else str
192
+
in
193
+
let ast_docs =
194
+
match Hashtbl.find_opt doc_cache str with
195
+
| Some cached ->
196
+
incr doc_cache_hits;
197
+
cached
198
+
| None ->
199
+
let t0 = Sys.time () in
200
+
let parsed =
201
+
Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
202
+
|> Error.raise_parser_warnings
203
+
in
204
+
doc_parse_time := !doc_parse_time +. (Sys.time () -. t0);
205
+
Hashtbl.replace doc_cache str parsed;
206
+
parsed
207
+
in
208
+
incr doc_parse_count;
209
+
loop (List.rev_append ast_docs acc_docs) acc_alerts rest
210
+
end
137
211
| Some (`Alert (name, p, loc)) ->
138
212
let elt = mk_alert_payload ~loc name p in
139
213
loop acc_docs (elt :: acc_alerts) rest
···
141
215
| [] -> (List.rev acc_docs, List.rev acc_alerts)
142
216
in
143
217
let ast_docs, alerts = loop [] [] attrs in
144
-
let elements, warnings = ast_to_comment ~internal_tags parent ast_docs alerts in
218
+
(* Build a cache key from the raw doc text. For docs without section
219
+
headings (which is the vast majority of PPX-duplicated docs), the
220
+
semantic analysis result is independent of parent. *)
221
+
let cache_key =
222
+
(* Use first doc string directly as cache key — avoids O(n*len)
223
+
string concatenation. Works because the vast majority of items
224
+
have exactly one doc attribute. *)
225
+
let rec find_first = function
226
+
| [] -> None
227
+
| attr :: rest ->
228
+
match parse_attribute attr with
229
+
| Some (`Doc (str, _)) -> Some str
230
+
| _ -> find_first rest
231
+
in
232
+
find_first attrs
233
+
in
234
+
let elements, warnings =
235
+
match cache_key with
236
+
| None ->
237
+
ast_to_comment ~internal_tags parent ast_docs alerts
238
+
| Some key ->
239
+
match Hashtbl.find_opt semantic_cache key with
240
+
| Some cached ->
241
+
incr semantic_cache_hits;
242
+
let empty_tags : type a. a Odoc_model.Semantics.handle_internal_tags -> a = function
243
+
| Odoc_model.Semantics.Expect_none -> ()
244
+
| Odoc_model.Semantics.Expect_canonical -> None
245
+
| Odoc_model.Semantics.Expect_status -> `Default
246
+
| Odoc_model.Semantics.Expect_page_tags -> Odoc_model.Frontmatter.empty
247
+
in
248
+
(cached, empty_tags internal_tags)
249
+
| None ->
250
+
let elements, warnings = ast_to_comment ~internal_tags parent ast_docs alerts in
251
+
Hashtbl.replace semantic_cache key elements;
252
+
(elements, warnings)
253
+
in
145
254
{ Comment.elements; warnings_tag }, warnings
146
255
147
256
let attached_no_tag ~warnings_tag parent attrs =
+2
src/loader/doc_attr.mli
+2
src/loader/doc_attr.mli
+59
-14
src/loader/ident_env.cppo.ml
+59
-14
src/loader/ident_env.cppo.ml
···
492
492
| `ClassType _ as x -> [x]
493
493
| `Include xs -> xs) items |> List.flatten
494
494
495
-
let type_name_exists name items =
495
+
(* Shadow detection: pre-count names by kind in one pass, then check
496
+
remaining count during processing. O(n) total instead of O(n²). *)
497
+
type shadow_counts = {
498
+
sc_types : (string, int) Hashtbl.t;
499
+
sc_values : (string, int) Hashtbl.t;
500
+
sc_modules : (string, int) Hashtbl.t;
501
+
sc_module_types : (string, int) Hashtbl.t;
502
+
sc_classes : (string, int) Hashtbl.t;
503
+
sc_class_types : (string, int) Hashtbl.t;
504
+
}
505
+
506
+
let build_shadow_counts items =
507
+
let bump tbl name =
508
+
match Hashtbl.find_opt tbl name with
509
+
| Some n -> Hashtbl.replace tbl name (n + 1)
510
+
| None -> Hashtbl.add tbl name 1
511
+
in
512
+
let counts = {
513
+
sc_types = Hashtbl.create 64;
514
+
sc_values = Hashtbl.create 64;
515
+
sc_modules = Hashtbl.create 64;
516
+
sc_module_types = Hashtbl.create 64;
517
+
sc_classes = Hashtbl.create 64;
518
+
sc_class_types = Hashtbl.create 64;
519
+
} in
520
+
List.iter (fun item ->
521
+
match item with
522
+
| `Type (id, _, _) -> bump counts.sc_types (Ident.name id)
523
+
| `Value (id, _, _) -> bump counts.sc_values (Ident.name id)
524
+
| `Module (id, _, _) -> bump counts.sc_modules (Ident.name id)
525
+
| `ModuleType (id, _, _) -> bump counts.sc_module_types (Ident.name id)
526
+
| `Class (id, _, _, _, _, _) -> bump counts.sc_classes (Ident.name id)
527
+
| `ClassType (id, _, _, _, _) -> bump counts.sc_class_types (Ident.name id)
528
+
| `Constructor _ | `Exception _ | `Extension _ | `Field _ -> ()
529
+
) items;
530
+
counts
531
+
532
+
(* Decrement and return true if remaining count > 0 (i.e., shadowed). *)
533
+
let check_and_decrement tbl name =
534
+
match Hashtbl.find_opt tbl name with
535
+
| Some n when n > 1 -> Hashtbl.replace tbl name (n - 1); true
536
+
| Some _ -> Hashtbl.remove tbl name; false
537
+
| None -> false
538
+
539
+
(* Legacy linear scan functions — kept for reference but no longer used *)
540
+
let _type_name_exists name items =
496
541
List.exists (function | `Type (id', _, _) when Ident.name id' = name -> true | _ -> false) items
497
542
498
-
let value_name_exists name items =
543
+
let _value_name_exists name items =
499
544
List.exists (function | `Value (id', _, _) when Ident.name id' = name -> true | _ -> false) items
500
545
501
-
let module_name_exists name items =
546
+
let _module_name_exists name items =
502
547
List.exists (function | `Module (id', _, _) when Ident.name id' = name -> true | _ -> false) items
503
548
504
-
let module_type_name_exists name items =
549
+
let _module_type_name_exists name items =
505
550
List.exists (function | `ModuleType (id', _, _) when Ident.name id' = name -> true | _ -> false) items
506
551
507
-
let class_name_exists name items =
552
+
let _class_name_exists name items =
508
553
List.exists (function | `Class (id',_,_,_,_,_) when Ident.name id' = name -> true | _ -> false) items
509
554
510
555
let class_type_name_exists name items =
···
512
557
513
558
let add_items : Id.Signature.t -> item list -> t -> t = fun parent items env ->
514
559
let open Odoc_model.Paths.Identifier in
560
+
let counts = build_shadow_counts items in
515
561
let rec inner items env =
516
562
match items with
517
563
| `Type (t, is_hidden_item, loc) :: rest ->
518
564
let name = Ident.name t in
519
-
let is_shadowed = type_name_exists name rest in
565
+
let is_shadowed = check_and_decrement counts.sc_types name in
520
566
let identifier, shadowed =
521
567
if is_shadowed
522
568
then Mk.type_(parent, TypeName.shadowed_of_string name), t :: env.shadowed
···
552
598
553
599
| `Value (t, is_hidden_item, loc) :: rest ->
554
600
let name = Ident.name t in
555
-
let is_shadowed = value_name_exists name rest in
601
+
let is_shadowed = check_and_decrement counts.sc_values name in
556
602
let identifier, shadowed =
557
603
if is_shadowed
558
604
then Mk.value(parent, ValueName.shadowed_of_string name), t :: env.shadowed
···
564
610
565
611
| `ModuleType (t, is_hidden_item, loc) :: rest ->
566
612
let name = Ident.name t in
567
-
let is_shadowed = module_type_name_exists name rest in
613
+
let is_shadowed = check_and_decrement counts.sc_module_types name in
568
614
let identifier, shadowed =
569
615
if is_shadowed
570
616
then Mk.module_type(parent, ModuleTypeName.shadowed_of_string name), t :: env.shadowed
···
576
622
577
623
| `Module (t, is_hidden_item, loc) :: rest ->
578
624
let name = Ident.name t in
579
-
let is_shadowed = module_name_exists name rest in
625
+
let is_shadowed = check_and_decrement counts.sc_modules name in
580
626
let identifier, shadowed =
581
627
if is_shadowed
582
628
then Mk.module_(parent, ModuleName.shadowed_of_string name), t :: env.shadowed
···
590
636
591
637
| `Class (t,t2,t3,t4, is_hidden_item, loc) :: rest ->
592
638
let name = Ident.name t in
593
-
let is_shadowed = class_name_exists name rest in
639
+
let is_shadowed = check_and_decrement counts.sc_classes name in
594
640
let class_types = match t4 with
595
641
| None -> [t;t2;t3]
596
642
| Some t4 -> [t;t2;t3;t4]
···
611
657
612
658
| `ClassType (t,t2,t3, is_hidden_item, loc) :: rest ->
613
659
let name = Ident.name t in
614
-
let is_shadowed = class_type_name_exists name rest in
660
+
let is_shadowed = check_and_decrement counts.sc_class_types name in
615
661
let class_types = match t3 with
616
662
| None -> [t;t2]
617
663
| Some t3 -> [t;t2;t3]
···
716
762
Ident.persistent id
717
763
#endif
718
764
719
-
let is_shadowed
720
-
env id =
721
-
List.mem id env.shadowed
765
+
let is_shadowed env id =
766
+
List.exists (fun id' -> Ident.same id id') env.shadowed
722
767
module Path = struct
723
768
724
769
let read_module_ident env id =
+10
src/loader/odoc_loader.cppo.ml
+10
src/loader/odoc_loader.cppo.ml
···
153
153
| _ -> raise Not_an_interface
154
154
155
155
let read_cmt ~make_root ~parent ~filename ~warnings_tag () =
156
+
let t_unmarshal = Sys.time () in
156
157
match Cmt_format.read_cmt filename with
157
158
| exception Cmi_format.Error (Not_an_interface _) ->
158
159
raise Not_an_implementation
···
214
215
make_compilation_unit ~make_root ~imports ~interface ~sourcefile ~name
215
216
~id content
216
217
| Implementation impl ->
218
+
(match Sys.getenv_opt "ODOC_GC_STATS" with
219
+
| Some s when s <> "" && s <> "0" ->
220
+
Printf.eprintf "ODOC_PHASE_TIME unmarshal=%.3f\n%!" (Sys.time () -. t_unmarshal)
221
+
| _ -> ());
217
222
Cmt.cmt_builddir := cmt_info.cmt_builddir;
218
223
Cmti.cmti_builddir := cmt_info.cmt_builddir;
224
+
let t0 = Sys.time () in
219
225
let id, sg, canonical =
220
226
Cmt.read_implementation parent name ~warnings_tag impl
221
227
in
228
+
(match Sys.getenv_opt "ODOC_GC_STATS" with
229
+
| Some s when s <> "" && s <> "0" ->
230
+
Printf.eprintf "ODOC_PHASE_TIME read_impl=%.3f\n%!" (Sys.time () -. t0)
231
+
| _ -> ());
222
232
compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile
223
233
~name ~id ?canonical sg
224
234
| _ -> raise Not_an_implementation)
+1
-1
src/manpage/generator.ml
+1
-1
src/manpage/generator.ml
···
562
562
and children = List.concat_map subpage (Subpages.compute p) in
563
563
let content ppf = Format.fprintf ppf "%a@." Roff.pp (page p) in
564
564
let filename = Link.as_filename p.url in
565
-
{ Renderer.filename; content; children; path = p.url; assets = [] }
565
+
{ Renderer.filename; content; children = List.to_seq children; path = p.url; assets = [] }
566
566
567
567
let render = function
568
568
| Document.Page page -> [ render_page page ]
+3
-2
src/markdown2/generator.ml
+3
-2
src/markdown2/generator.ml
···
456
456
457
457
let rec include_ ~config { Types.Subpage.content; _ } = page ~config content
458
458
459
-
and subpages ~config subpages = List.map (include_ ~config) subpages
459
+
and subpages ~config subpages =
460
+
Seq.map (include_ ~config) (List.to_seq subpages)
460
461
461
462
and page ~config p =
462
-
let subpages = subpages ~config @@ Doctree.Subpages.compute p in
463
+
let subpages = subpages ~config (Doctree.Subpages.compute p) in
463
464
let resolve = Link.Current p.url in
464
465
let i = Doctree.Shift.compute ~on_sub p.items in
465
466
let header, preamble =
+1
-1
src/markdown2/markdown_page.ml
+1
-1
src/markdown2/markdown_page.ml
+1
-1
src/markdown2/markdown_page.mli
+1
-1
src/markdown2/markdown_page.mli
+6
-1
src/model/paths.ml
+6
-1
src/model/paths.ml
···
180
180
181
181
let hash x = x.ihash
182
182
183
-
let compare x y = compare x.ikey y.ikey
183
+
let compare x y =
184
+
(* Compare hash first to short-circuit in the common case where keys
185
+
differ — avoids string comparison entirely for most Map lookups. *)
186
+
let h = Int.compare x.ihash y.ihash in
187
+
if h <> 0 then h
188
+
else String.compare x.ikey y.ikey
184
189
185
190
type any = t
186
191
+15
src/odoc/bin/main.ml
+15
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
+10
src/odoc/compile.ml
+10
src/odoc/compile.ml
···
142
142
|> Error.raise_errors_and_warnings
143
143
in
144
144
let unit = { unit with hidden = hidden || unit.hidden } in
145
+
let t_load = Sys.time () in
146
+
(match Sys.getenv_opt "ODOC_GC_STATS" with
147
+
| Some s when s <> "" && s <> "0" ->
148
+
Printf.eprintf "ODOC_PHASE_TIME loader=%.3f\n%!" t_load
149
+
| _ -> ());
145
150
if not unit.Lang.Compilation_unit.interface then
146
151
Printf.eprintf "WARNING: not processing the \"interface\" file.%s\n%!"
147
152
(if not (Filename.check_suffix filename "cmt") then "" (* ? *)
···
150
155
(* Resolve imports, used by the [link-deps] command. *)
151
156
let unit = { unit with imports = resolve_imports resolver unit.imports } in
152
157
let env = Resolver.build_compile_env_for_unit resolver unit in
158
+
let t_compile_start = Sys.time () in
153
159
let compiled =
154
160
Odoc_xref2.Compile.compile ~filename env unit |> Error.raise_warnings
155
161
in
162
+
(match Sys.getenv_opt "ODOC_GC_STATS" with
163
+
| Some s when s <> "" && s <> "0" ->
164
+
Printf.eprintf "ODOC_PHASE_TIME compile=%.3f\n%!" (Sys.time () -. t_compile_start)
165
+
| _ -> ());
156
166
(* [expand unit] fetches [unit] from [env] to get the expansion of local, previously
157
167
defined, elements. We'd rather it got back the resolved bit so we rebuild an
158
168
environment with the resolved unit.
+10
-2
src/utils/odoc_utils.ml
+10
-2
src/utils/odoc_utils.ml
···
57
57
let with_open_out_bin fname f =
58
58
_with_resource (open_out_bin fname) ~close:close_out_noerr f
59
59
60
-
(** Like [with_open_out] but operate on a [Format] buffer. *)
60
+
(** Like [with_open_out] but operate on a [Format] buffer.
61
+
Uses a Buffer to accumulate output and writes it to the file in one
62
+
go at the end. This avoids per-chunk channel mutex acquisition in
63
+
the multicore runtime. *)
61
64
let with_formatter_out fname f =
62
-
with_open_out fname (fun oc -> f (Format.formatter_of_out_channel oc))
65
+
let buf = Buffer.create 65536 in
66
+
let fmt = Format.formatter_of_buffer buf in
67
+
let result = f fmt in
68
+
Format.pp_print_flush fmt ();
69
+
with_open_out fname (fun oc -> Buffer.output_buffer oc buf);
70
+
result
63
71
64
72
(** Shortcuts for composing [with_open_*] functions and [Marshal]. *)
65
73
let marshal fname v =
+33
src/xref2/compile.ml
+33
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
src/xref2/link.ml
+68
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