[m-rev.] diff: [CTGC] improve type_contains_subtype

[Peter Wang]

Branches: main

compiler/ctgc.selector.m:
	Change `type_contains_subtype' to perform a breadth-first search
	instead of a depth-first search, keeping better track of the types
	that already seen.  This avoids some really bad performance when
	performing structure sharing analysis on some modules.

	Add an XXX about a potential problem.

diff --git a/compiler/ctgc.selector.m b/compiler/ctgc.selector.m
index 74788af..866db54 100644
--- a/compiler/ctgc.selector.m
+++ b/compiler/ctgc.selector.m
@@ -79,9 +79,14 @@
 :- import_module parse_tree.prog_type.
 
 :- import_module assoc_list.
+:- import_module bool.
 :- import_module map.
 :- import_module pair.
+:- import_module queue.
+:- import_module set.
+:- import_module solutions.
 :- import_module string.
+:- import_module svset.
 
 %-----------------------------------------------------------------------------%
 
@@ -238,24 +243,50 @@ subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
     %
     % Succeed iff starting from FromType we can reach a node ToType.
     %
+    % XXX I didn't think about type variables when writing this.
+    %
 :- pred type_contains_subtype(module_info::in, mer_type::in, mer_type::in)
     is semidet.
 
 type_contains_subtype(ModuleInfo, FromType, ToType) :-
-    type_contains_subtype_2(ModuleInfo, FromType, ToType, []).
+    ( FromType = ToType ->
+        true
+    ;
+        queue.put(queue.init, FromType, Queue0),
+        type_contains_subtype_2(ModuleInfo, ToType, Queue0, _Queue,
+            set.init, _SeenTypes, Contains),
+        Contains = yes
+    ).
 
-:- pred type_contains_subtype_2(module_info::in, mer_type::in, mer_type::in,
-    list(mer_type)::in) is semidet.
+:- pred type_contains_subtype_2(module_info::in, mer_type::in,
+    queue(mer_type)::in, queue(mer_type)::out,
+    set(mer_type)::in, set(mer_type)::out, bool::out) is det.
 
-type_contains_subtype_2(ModuleInfo, FromType, ToType, SeenTypes0) :-
-    (
-        FromType = ToType
+type_contains_subtype_2(ModuleInfo, ToType, !Queue, !SeenTypes, Contains) :-
+    ( queue.get(!.Queue, FromType, !:Queue) ->
+        ( set.contains(!.SeenTypes, FromType) ->
+            type_contains_subtype_2(ModuleInfo, ToType, !Queue, !SeenTypes,
+                Contains)
+        ;
+            svset.insert(FromType, !SeenTypes),
+            solutions(
+                (pred(ConsIdArgTypes::out) is nondet :-
+                    cons_id_arg_types(ModuleInfo, FromType, _ConsId,
+                        ConsIdArgTypes),
+                    ConsIdArgTypes = [_ | _]
+                ),
+                ArgTypesLists),
+            list.condense(ArgTypesLists, ArgTypes),
+            ( list.member(ToType, ArgTypes) ->
+                Contains = yes
+            ;
+                queue.put_list(!.Queue, ArgTypes, !:Queue),
+                type_contains_subtype_2(ModuleInfo, ToType, !Queue, !SeenTypes,
+                    Contains)
+            )
+        )
     ;
-        SeenTypes = [FromType | SeenTypes0],
-        cons_id_arg_types(ModuleInfo, FromType, _ConsId, ArgTypes),
-        list.member(ArgType, ArgTypes),
-        not list.member(ArgType, SeenTypes),
-        type_contains_subtype_2(ModuleInfo, ArgType, ToType, SeenTypes)
+        Contains = no
     ).
 
 type_of_node(ModuleInfo, StartType, Selector, SubType) :-


--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------