[m-rev.] diff: fix non-terminating structure sharing analysis

[Peter Wang]

Branches: main

The definition of `ctgc.selector.subsumed_by' missed cases such as the
following:

    subsumed_by(ModuleInfo, Sel1, Sel2, Type, Extension)

    Sel1 = [termsel(foo/2, 1)],
    Sel2 = [typesel(bar)]

If the type of the node selected by the term selector in Sel1 is `bar' (the
same as selected by the type selector in Sel2) then it should succeed with
Extension = [].

One symptom was that structure sharing analysis would never reach a fixpoint
analysing some particular SCCs when widening was enabled (which is when type
selectors are introduced).

compiler/ctgc.selector.m:
	Fix `subsumed_by' as above.

tests/valid/Mercury.options:
tests/valid/Mmakefile:
tests/valid/sharing_loop.m:
	Add a test case.

Index: compiler/ctgc.selector.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ctgc.selector.m,v
retrieving revision 1.15
diff -u -p -r1.15 ctgc.selector.m
--- compiler/ctgc.selector.m	28 May 2008 05:26:51 -0000	1.15
+++ compiler/ctgc.selector.m	13 Jun 2008 01:13:02 -0000
@@ -183,15 +183,25 @@ subsumed_by_2(ModuleInfo, A, B, Type, Ex
             AH = termsel(ConsIdA, IndexA),
             BH = typesel(SubTypeB),
             SubTypeA = det_select_subtype(ModuleInfo, Type, ConsIdA, IndexA),
-            type_contains_subtype(ModuleInfo, SubTypeA, SubTypeB),
-            subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
+            ( SubTypeA = SubTypeB ->
+                % Both selectors agree on the subtype to select.
+                subsumed_by_2(ModuleInfo, AT, BT, SubTypeA, Extension)
+            ;
+                type_contains_subtype(ModuleInfo, SubTypeA, SubTypeB),
+                subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
+            )
         ;
             % Symmetric with the previous case.
             AH = typesel(SubTypeA),
             BH = termsel(ConsIdB, IndexB),
             SubTypeB = det_select_subtype(ModuleInfo, Type, ConsIdB, IndexB),
-            type_contains_subtype(ModuleInfo, SubTypeB, SubTypeA),
-            subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension)
+            ( SubTypeA = SubTypeB ->
+                % Both selectors agree on the subtype to select.
+                subsumed_by_2(ModuleInfo, AT, BT, SubTypeB, Extension)
+            ;
+                type_contains_subtype(ModuleInfo, SubTypeB, SubTypeA),
+                subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension)
+            )
         ;
             AH = typesel(SubTypeA),
             BH = typesel(SubTypeB),
Index: tests/valid/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mercury.options,v
retrieving revision 1.50
diff -u -p -r1.50 Mercury.options
--- tests/valid/Mercury.options	6 Jun 2008 07:44:17 -0000	1.50
+++ tests/valid/Mercury.options	13 Jun 2008 01:13:02 -0000
@@ -103,6 +103,7 @@ MCFLAGS-pred_with_no_modes	= --infer-all
 MCFLAGS-quantifier_warning	= --halt-at-warn
 MCFLAGS-reuse_static		= --ctgc --deforestation
 MCFLAGS-sharing_exist		= --ctgc --structure-sharing-widening 1
+MCFLAGS-sharing_loop 		= --ctgc --structure-sharing-widening 8
 MCFLAGS-simplify_bug2		= -O3
 MCFLAGS-simplify_bug		= -O-1
 MCFLAGS-solver_type_bug		= --halt-at-warn
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.213
diff -u -p -r1.213 Mmakefile
--- tests/valid/Mmakefile	3 May 2008 14:54:00 -0000	1.213
+++ tests/valid/Mmakefile	13 Jun 2008 01:13:02 -0000
@@ -272,7 +272,8 @@ PAR_CONJ_PROGS = \
 # grades.
 CTGC_PROGS = \
 	reuse_static \
-	sharing_exist
+	sharing_exist \
+	sharing_loop
 
 # The following programs require that num_tag_bits >= 1
 RESERVE_TAG_PROGS = \
Index: tests/valid/sharing_loop.m
===================================================================
RCS file: tests/valid/sharing_loop.m
diff -N tests/valid/sharing_loop.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/valid/sharing_loop.m	13 Jun 2008 01:13:02 -0000
@@ -0,0 +1,65 @@
+% Regression test.  The structure sharing analysis wasn't able to reach a
+% fixpoint analysing this module with --structure-sharing-widening set to
+% certain values.
+
+:- module sharing_loop.
+:- interface.
+
+:- type elds_expr
+    --->    elds_term(var)
+    ;       elds_fun(var)
+    ;       elds_case_expr(var)
+    ;       elds_try(elds_catch).
+
+:- type elds_catch
+    --->    elds_catch(var, elds_expr). 
+
+:- type var
+    --->    var(int).
+
+:- type renaming
+    --->    no
+    ;       yes(var).
+
+:- pred erl_rename_vars_in_expr(renaming::in,
+    elds_expr::in, elds_expr::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+erl_rename_vars_in_expr(Subn, Expr0, Expr) :-
+    (
+        Expr0 = elds_term(Term0),
+        erl_rename_vars_in_term(Subn, Term0, Term),
+        Expr = elds_term(Term)
+    ;
+        Expr0 = elds_fun(Clause0),
+        erl_rename_vars_in_term(Subn, Clause0, Clause),
+        Expr = elds_fun(Clause)
+    ;
+        Expr0 = elds_case_expr(Cases),
+        Expr = elds_case_expr(Cases)
+    ;
+        Expr0 = elds_try(Catch0),
+        erl_rename_vars_in_catch(Subn, Catch0, Catch),
+        Expr = elds_try(Catch)
+    ).
+
+:- pred erl_rename_vars_in_term(renaming::in,
+    var::in, var::out) is det.
+
+erl_rename_vars_in_term(no, Var, Var).
+erl_rename_vars_in_term(yes(Var), _, Var).
+
+:- pred erl_rename_vars_in_catch(renaming::in,
+    elds_catch::in, elds_catch::out) is det.
+
+erl_rename_vars_in_catch(Subn, Catch0, Catch) :-
+    Catch0 = elds_catch(Pattern, Expr0),
+    erl_rename_vars_in_expr(Subn, Expr0, Expr),
+    Catch = elds_catch(Pattern, Expr).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=8 sts=4 sw=4 et

--------------------------------------------------------------------------
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
--------------------------------------------------------------------------