Merge pull request #1036 from gpetiot/optimize-apply_sig_map

Don't compute the unused list removed_items in Tools.fragmap

src/xref2/subst.ml

@@ -1037,60 +1037,47 @@ and apply_sig_map_sg s (sg : Component.Signature.t) =
   let items, removed, dont_recompile = apply_sig_map s sg.items sg.removed in
   { sg with items; removed; compiled = sg.compiled && dont_recompile }
 
-and apply_sig_map s items removed =
+and apply_sig_map_item s item =
   let open Component.Signature in
-  let rec inner items acc =
-    match items with
-    | [] -> List.rev acc
-    | Module (id, r, m) :: rest ->
-        inner rest
-          (Module
-             ( id,
-               r,
-               Component.Delayed.put (fun () ->
-                   module_ s (Component.Delayed.get m)) )
-          :: acc)
-    | ModuleSubstitution (id, m) :: rest ->
-        inner rest (ModuleSubstitution (id, module_substitution s m) :: acc)
-    | ModuleType (id, mt) :: rest ->
-        inner rest
-          (ModuleType
-             ( id,
-               Component.Delayed.put (fun () ->
-                   module_type s (Component.Delayed.get mt)) )
-          :: acc)
-    | ModuleTypeSubstitution (id, mt) :: rest ->
-        inner rest
-          (ModuleTypeSubstitution (id, module_type_substitution s mt) :: acc)
-    | Type (id, r, t) :: rest ->
-        inner rest
-          (Type
-             ( id,
-               r,
-               Component.Delayed.put (fun () ->
-                   type_ s (Component.Delayed.get t)) )
-          :: acc)
-    | TypeSubstitution (id, t) :: rest ->
-        inner rest (TypeSubstitution (id, type_ s t) :: acc)
-    | Exception (id, e) :: rest ->
-        inner rest (Exception (id, exception_ s e) :: acc)
-    | TypExt e :: rest -> inner rest (TypExt (extension s e) :: acc)
-    | Value (id, v) :: rest ->
-        inner rest
-          (Value
-             ( id,
-               Component.Delayed.put (fun () ->
-                   value s (Component.Delayed.get v)) )
-          :: acc)
-    | Class (id, r, c) :: rest -> inner rest (Class (id, r, class_ s c) :: acc)
-    | ClassType (id, r, c) :: rest ->
-        inner rest (ClassType (id, r, class_type s c) :: acc)
-    | Include i :: rest -> inner rest (Include (include_ s i) :: acc)
-    | Open o :: rest -> inner rest (Open (open_ s o) :: acc)
-    | Comment c :: rest -> inner rest (Comment c :: acc)
-  in
+  match item with
+  | Module (id, r, m) ->
+      Module
+        ( id,
+          r,
+          Component.Delayed.put (fun () -> module_ s (Component.Delayed.get m))
+        )
+  | ModuleSubstitution (id, m) ->
+      ModuleSubstitution (id, module_substitution s m)
+  | ModuleType (id, mt) ->
+      ModuleType
+        ( id,
+          Component.Delayed.put (fun () ->
+              module_type s (Component.Delayed.get mt)) )
+  | ModuleTypeSubstitution (id, mt) ->
+      ModuleTypeSubstitution (id, module_type_substitution s mt)
+  | Type (id, r, t) ->
+      Type
+        ( id,
+          r,
+          Component.Delayed.put (fun () -> type_ s (Component.Delayed.get t)) )
+  | TypeSubstitution (id, t) -> TypeSubstitution (id, type_ s t)
+  | Exception (id, e) -> Exception (id, exception_ s e)
+  | TypExt e -> TypExt (extension s e)
+  | Value (id, v) ->
+      Value
+        (id, Component.Delayed.put (fun () -> value s (Component.Delayed.get v)))
+  | Class (id, r, c) -> Class (id, r, class_ s c)
+  | ClassType (id, r, c) -> ClassType (id, r, class_type s c)
+  | Include i -> Include (include_ s i)
+  | Open o -> Open (open_ s o)
+  | Comment c -> Comment c
+
+and apply_sig_map_items s items =
+  List.rev_map (apply_sig_map_item s) items |> List.rev
+
+and apply_sig_map s items removed =
   let dont_recompile =
     List.length s.path_invalidating_modules = 0
     && List.length s.module_type_of_invalidating_modules = 0
   in
-  (inner items [], removed_items s removed, dont_recompile)
+  (apply_sig_map_items s items, removed_items s removed, dont_recompile)

src/xref2/subst.mli

@@ -67,10 +67,5 @@ val class_type : t -> Component.ClassType.t -> Component.ClassType.t
 
 val signature : t -> Component.Signature.t -> Component.Signature.t
 
-val apply_sig_map :
-  t ->
-  Signature.item list ->
-  Signature.removed_item list ->
-  Signature.item list * Signature.removed_item list * bool
-(** Apply substitutions. The third value is [false] if the corresponding
-    signature needs to be compiled again and [true] otherwise. *)
+val apply_sig_map_items : t -> Signature.item list -> Signature.item list
+(** Apply substitutions. *)

src/xref2/tools.ml

@@ -2048,27 +2048,22 @@ and fragmap :
 
   let sub = List.fold_right sub_of_removed removed Subst.identity in
 
-  let map_items items =
-    (* Invalidate resolved paths containing substituted idents - See the `With11`
-       test for an example of why this is necessary *)
-    let sub_of_substituted x sub =
-      let x = (x :> Ident.path_module) in
-      (if mark_substituted then Subst.add_module_substitution x sub else sub)
-      |> Subst.path_invalidate_module x
-      |> Subst.mto_invalidate_module x
-    in
+  (* Invalidate resolved paths containing substituted idents - See the `With11`
+     test for an example of why this is necessary *)
+  let sub_of_substituted x sub =
+    let x = (x :> Ident.path_module) in
+    (if mark_substituted then Subst.add_module_substitution x sub else sub)
+    |> Subst.path_invalidate_module x
+    |> Subst.mto_invalidate_module x
+  in
 
-    let substituted_sub =
-      List.fold_right sub_of_substituted subbed_modules Subst.identity
-    in
-    (* Need to call `apply_sig_map` directly as we're substituting for an item
-       that's declared within the signature *)
-    let items, _, _ = Subst.apply_sig_map substituted_sub items [] in
-    (* Finished marking substituted stuff *)
-    items
+  let substituted_sub =
+    List.fold_right sub_of_substituted subbed_modules Subst.identity
   in
 
-  let items = map_items items in
+  (* Need to call `apply_sig_map_items` directly as we're substituting for an item
+     that's declared within the signature *)
+  let items = Subst.apply_sig_map_items substituted_sub items in
 
   let res =
     Subst.signature sub