Skip to content

Commit bae3714

Browse files
JulowJulow
authored
Merge pull request #1036 from gpetiot/optimize-apply_sig_map
Don't compute the unused list removed_items in Tools.fragmap
2 parents a963381 + da87d84 commit bae3714

File tree

3 files changed

+54
-77
lines changed

3 files changed

+54
-77
lines changed

‎src/xref2/subst.ml

Lines changed: 39 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -1037,60 +1037,47 @@ and apply_sig_map_sg s (sg : Component.Signature.t) =
10371037
let items, removed, dont_recompile = apply_sig_map s sg.items sg.removed in
10381038
{ sg with items; removed; compiled = sg.compiled && dont_recompile }
10391039

1040-
and apply_sig_map s items removed =
1040+
and apply_sig_map_item s item =
10411041
let open Component.Signature in
1042-
let rec inner items acc =
1043-
match items with
1044-
| [] -> List.rev acc
1045-
| Module (id, r, m) :: rest ->
1046-
inner rest
1047-
(Module
1048-
( id,
1049-
r,
1050-
Component.Delayed.put (fun () ->
1051-
module_ s (Component.Delayed.get m)) )
1052-
:: acc)
1053-
| ModuleSubstitution (id, m) :: rest ->
1054-
inner rest (ModuleSubstitution (id, module_substitution s m) :: acc)
1055-
| ModuleType (id, mt) :: rest ->
1056-
inner rest
1057-
(ModuleType
1058-
( id,
1059-
Component.Delayed.put (fun () ->
1060-
module_type s (Component.Delayed.get mt)) )
1061-
:: acc)
1062-
| ModuleTypeSubstitution (id, mt) :: rest ->
1063-
inner rest
1064-
(ModuleTypeSubstitution (id, module_type_substitution s mt) :: acc)
1065-
| Type (id, r, t) :: rest ->
1066-
inner rest
1067-
(Type
1068-
( id,
1069-
r,
1070-
Component.Delayed.put (fun () ->
1071-
type_ s (Component.Delayed.get t)) )
1072-
:: acc)
1073-
| TypeSubstitution (id, t) :: rest ->
1074-
inner rest (TypeSubstitution (id, type_ s t) :: acc)
1075-
| Exception (id, e) :: rest ->
1076-
inner rest (Exception (id, exception_ s e) :: acc)
1077-
| TypExt e :: rest -> inner rest (TypExt (extension s e) :: acc)
1078-
| Value (id, v) :: rest ->
1079-
inner rest
1080-
(Value
1081-
( id,
1082-
Component.Delayed.put (fun () ->
1083-
value s (Component.Delayed.get v)) )
1084-
:: acc)
1085-
| Class (id, r, c) :: rest -> inner rest (Class (id, r, class_ s c) :: acc)
1086-
| ClassType (id, r, c) :: rest ->
1087-
inner rest (ClassType (id, r, class_type s c) :: acc)
1088-
| Include i :: rest -> inner rest (Include (include_ s i) :: acc)
1089-
| Open o :: rest -> inner rest (Open (open_ s o) :: acc)
1090-
| Comment c :: rest -> inner rest (Comment c :: acc)
1091-
in
1042+
match item with
1043+
| Module (id, r, m) ->
1044+
Module
1045+
( id,
1046+
r,
1047+
Component.Delayed.put (fun () -> module_ s (Component.Delayed.get m))
1048+
)
1049+
| ModuleSubstitution (id, m) ->
1050+
ModuleSubstitution (id, module_substitution s m)
1051+
| ModuleType (id, mt) ->
1052+
ModuleType
1053+
( id,
1054+
Component.Delayed.put (fun () ->
1055+
module_type s (Component.Delayed.get mt)) )
1056+
| ModuleTypeSubstitution (id, mt) ->
1057+
ModuleTypeSubstitution (id, module_type_substitution s mt)
1058+
| Type (id, r, t) ->
1059+
Type
1060+
( id,
1061+
r,
1062+
Component.Delayed.put (fun () -> type_ s (Component.Delayed.get t)) )
1063+
| TypeSubstitution (id, t) -> TypeSubstitution (id, type_ s t)
1064+
| Exception (id, e) -> Exception (id, exception_ s e)
1065+
| TypExt e -> TypExt (extension s e)
1066+
| Value (id, v) ->
1067+
Value
1068+
(id, Component.Delayed.put (fun () -> value s (Component.Delayed.get v)))
1069+
| Class (id, r, c) -> Class (id, r, class_ s c)
1070+
| ClassType (id, r, c) -> ClassType (id, r, class_type s c)
1071+
| Include i -> Include (include_ s i)
1072+
| Open o -> Open (open_ s o)
1073+
| Comment c -> Comment c
1074+
1075+
and apply_sig_map_items s items =
1076+
List.rev_map (apply_sig_map_item s) items |> List.rev
1077+
1078+
and apply_sig_map s items removed =
10921079
let dont_recompile =
10931080
List.length s.path_invalidating_modules = 0
10941081
&& List.length s.module_type_of_invalidating_modules = 0
10951082
in
1096-
(inner items [], removed_items s removed, dont_recompile)
1083+
(apply_sig_map_items s items, removed_items s removed, dont_recompile)

‎src/xref2/subst.mli

Lines changed: 2 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -67,10 +67,5 @@ val class_type : t -> Component.ClassType.t -> Component.ClassType.t
6767

6868
val signature : t -> Component.Signature.t -> Component.Signature.t
6969

70-
val apply_sig_map :
71-
t ->
72-
Signature.item list ->
73-
Signature.removed_item list ->
74-
Signature.item list * Signature.removed_item list * bool
75-
(** Apply substitutions. The third value is [false] if the corresponding
76-
signature needs to be compiled again and [true] otherwise. *)
70+
val apply_sig_map_items : t -> Signature.item list -> Signature.item list
71+
(** Apply substitutions. *)

‎src/xref2/tools.ml

Lines changed: 13 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -2048,27 +2048,22 @@ and fragmap :
20482048

20492049
let sub = List.fold_right sub_of_removed removed Subst.identity in
20502050

2051-
let map_items items =
2052-
(* Invalidate resolved paths containing substituted idents - See the `With11`
2053-
test for an example of why this is necessary *)
2054-
let sub_of_substituted x sub =
2055-
let x = (x :> Ident.path_module) in
2056-
(if mark_substituted then Subst.add_module_substitution x sub else sub)
2057-
|> Subst.path_invalidate_module x
2058-
|> Subst.mto_invalidate_module x
2059-
in
2051+
(* Invalidate resolved paths containing substituted idents - See the `With11`
2052+
test for an example of why this is necessary *)
2053+
let sub_of_substituted x sub =
2054+
let x = (x :> Ident.path_module) in
2055+
(if mark_substituted then Subst.add_module_substitution x sub else sub)
2056+
|> Subst.path_invalidate_module x
2057+
|> Subst.mto_invalidate_module x
2058+
in
20602059

2061-
let substituted_sub =
2062-
List.fold_right sub_of_substituted subbed_modules Subst.identity
2063-
in
2064-
(* Need to call `apply_sig_map` directly as we're substituting for an item
2065-
that's declared within the signature *)
2066-
let items, _, _ = Subst.apply_sig_map substituted_sub items [] in
2067-
(* Finished marking substituted stuff *)
2068-
items
2060+
let substituted_sub =
2061+
List.fold_right sub_of_substituted subbed_modules Subst.identity
20692062
in
20702063

2071-
let items = map_items items in
2064+
(* Need to call `apply_sig_map_items` directly as we're substituting for an item
2065+
that's declared within the signature *)
2066+
let items = Subst.apply_sig_map_items substituted_sub items in
20722067

20732068
let res =
20742069
Subst.signature sub

0 commit comments

Comments
 (0)