[m-rev.] for review: fix bug reported by Peter Ross

[Mark Brown]

Hi,

I'll commit this on the main branch before review, so that Peter can try it
out and check that it fixes all instances of the problem.  I'll wait for
review before committing it on the release branch.

Cheers,
Mark.

Estimated hours taken: 8
Branches: main, release

Fix a bug reported by Peter Ross.  The problem was that the ancestors of
assumed constraints were not being used to find opportunities for
improvement, which led to some potential improvements being missed.

compiler/hlds_data.m:
	Include assumed constraints (and their ancestors) in the set of
	redundant constraints, as these can also play a part in improvements
	even though they cannot themselves be improved.

compiler/typeclasses.m:
	When applying the class improvement rules, don't try to match on
	assumed constraints.  These are now contained in the redundant
	constraints, which we already process.

tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/fundeps_5.exp:
tests/hard_coded/typeclasses/fundeps_5.m:
	A regression test.

Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.105
diff -u -r1.105 hlds_data.m
--- compiler/hlds_data.m	20 Apr 2006 05:36:52 -0000	1.105
+++ compiler/hlds_data.m	31 May 2006 15:42:28 -0000
@@ -923,10 +923,10 @@
                             % Constraints that are known to be redundant.
                             % This includes constraints that have already been
                             % proved as well as constraints that are ancestors
-                            % of other unproven or redundant constraints.
-                            % Not all such constraints are included, only those
-                            % which may be used for the purposes of
-                            % improvement.
+                            % of other unproven, assumed or redundant
+                            % constraints.  Not all such constraints are
+                            % included, only those which may be used for
+                            % the purposes of improvement.
             ).
 
     % Redundant constraints are partitioned by class, which helps us
@@ -1063,7 +1063,9 @@
 
 make_hlds_constraints(ClassTable, TVarSet, Unproven, Assumed, Constraints) :-
     list.foldl(update_redundant_constraints_2(ClassTable, TVarSet),
-        Unproven, multi_map.init, Redundant),
+        Unproven, multi_map.init, Redundant0),
+    list.foldl(update_redundant_constraints_2(ClassTable, TVarSet),
+        Assumed, Redundant0, Redundant),
     Constraints = constraints(Unproven, Assumed, Redundant).
 
 make_hlds_constraint_list(ProgConstraints, ConstraintType, GoalPath,
Index: compiler/typeclasses.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typeclasses.m,v
retrieving revision 1.10
diff -u -r1.10 typeclasses.m
--- compiler/typeclasses.m	29 Mar 2006 08:07:28 -0000	1.10
+++ compiler/typeclasses.m	30 May 2006 11:15:16 -0000
@@ -280,26 +280,22 @@
 do_class_improvement(ClassTable, HeadTypeParams, Constraints, !Bindings,
         Changed) :-
     Redundant = Constraints ^ redundant,
-    Assumed = Constraints ^ assumed,
     multi_map.keys(Redundant, ClassIds),
     list.foldl2(
-        do_class_improvement_2(ClassTable, HeadTypeParams, Redundant, Assumed),
+        do_class_improvement_2(ClassTable, HeadTypeParams, Redundant),
         ClassIds, !Bindings, no, Changed).
 
 :- pred do_class_improvement_2(class_table::in, head_type_params::in,
-    redundant_constraints::in, list(hlds_constraint)::in, class_id::in,
-    tsubst::in, tsubst::out, bool::in, bool::out) is det.
+    redundant_constraints::in, class_id::in, tsubst::in, tsubst::out,
+    bool::in, bool::out) is det.
 
 do_class_improvement_2(ClassTable, HeadTypeParams, RedundantConstraints,
-        Assumed, ClassId, !Bindings, !Changed) :-
+        ClassId, !Bindings, !Changed) :-
     map.lookup(ClassTable, ClassId, ClassDefn),
     FunDeps = ClassDefn ^ class_fundeps,
     map.lookup(RedundantConstraints, ClassId, Constraints),
     do_class_improvement_by_pairs(Constraints, FunDeps, HeadTypeParams,
-        !Bindings, !Changed),
-    list.filter(has_class_id(ClassId), Assumed, ThisClassAssumed),
-    do_class_improvement_by_assumed(ThisClassAssumed, Constraints, FunDeps,
-        HeadTypeParams, !Bindings, !Changed).
+        !Bindings, !Changed).
 
 :- pred has_class_id(class_id::in, hlds_constraint::in) is semidet.
 
@@ -333,33 +329,6 @@
     do_class_improvement_by_pairs_2(Constraint, TailConstraints, FunDeps,
         HeadTypeParams, !Bindings, !Changed).
 
-    % Try to find an opportunity for improvement for each pair of
-    % constraints where one comes from the assumed constraints and the
-    % other comes from the redundant constraints.
-    %
-:- pred do_class_improvement_by_assumed(list(hlds_constraint)::in,
-    list(hlds_constraint)::in, hlds_class_fundeps::in, head_type_params::in,
-    tsubst::in, tsubst::out, bool::in, bool::out) is det.
-
-do_class_improvement_by_assumed(Assumed, Constraints, FunDeps, HeadTypeParams,
-        !Bindings, !Changed) :-
-    list.foldl2(
-        do_class_improvement_by_assumed_2(Constraints, FunDeps,
-            HeadTypeParams),
-        Assumed, !Bindings, !Changed).
-
-:- pred do_class_improvement_by_assumed_2(list(hlds_constraint)::in,
-    hlds_class_fundeps::in, head_type_params::in, hlds_constraint::in,
-    tsubst::in, tsubst::out, bool::in, bool::out) is det.
-
-do_class_improvement_by_assumed_2([], _, _, _, !Bindings, !Changed).
-do_class_improvement_by_assumed_2([Constraint | Constraints], FunDeps,
-        HeadTypeParams, Assumed, !Bindings, !Changed) :-
-    do_class_improvement_pair(Constraint, Assumed, FunDeps, HeadTypeParams,
-        !Bindings, !Changed),
-    do_class_improvement_by_assumed_2(Constraints, FunDeps, HeadTypeParams,
-        Assumed, !Bindings, !Changed).
-
     % Try to find an opportunity for improvement for this pair of
     % constraints, using each fundep in turn.
     %
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.55
diff -u -r1.55 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile	25 Oct 2005 13:08:33 -0000	1.55
+++ tests/hard_coded/typeclasses/Mmakefile	31 May 2006 12:50:50 -0000
@@ -24,6 +24,7 @@
 	fundeps_2 \
 	fundeps_3 \
 	fundeps_4 \
+	fundeps_5 \
 	ground_constraint \
 	ground_constraint_2 \
 	ho_map \
Index: tests/hard_coded/typeclasses/fundeps_5.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_5.exp
diff -N tests/hard_coded/typeclasses/fundeps_5.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_5.exp	31 May 2006 12:50:17 -0000
@@ -0,0 +1,3 @@
+hello test
+hello test
+goodbye test
Index: tests/hard_coded/typeclasses/fundeps_5.m
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_5.m
diff -N tests/hard_coded/typeclasses/fundeps_5.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_5.m	31 May 2006 12:48:47 -0000
@@ -0,0 +1,56 @@
+/*
+Uncomment one line in do_something and this program compiles,
+or remove the typevariable X from the typeclass definitions and
+the program compiles.  Note this comes from a test case where
+there are methods which use X in typeclass definitions.
+*/
+
+:- module fundeps_5.
+:- interface.
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+:- import_module string.
+
+:- typeclass a(A, X) <= ((A->X), (X->A)) where [
+	func hello(A) = string
+].
+
+:- typeclass b(B, X) <= (a(B, X), (B->X), (X->B)) where [
+	func goodbye(B) = string
+].
+
+:- type some_b  ---> some[B, X] some_b(B) => b(B, X).
+
+:- instance a(string, int) where [
+	hello(S) = "hello " ++ S ++ "\n"
+].
+
+:- instance b(string, int) where [
+	goodbye(S) = "goodbye " ++ S ++ "\n"
+].
+
+:- pred do_something(some_b::in, io::di, io::uo) is det.
+
+do_something(SomeB1, !IO) :-
+   SomeB1 = some_b(B1),
+   io.write_string(hello(B1), !IO),
+   % Uncomment the line below and this compiles.
+   % io.write_string(goodbye(B1), !IO),
+   true.
+
+:- pred do_something_else(some_b::in, io::di, io::uo) is det.
+
+do_something_else(SomeB1, !IO) :-
+   SomeB1 = some_b(B1),
+   io.write_string(hello(B1), !IO),
+   % Comment the line below and this doesn't compile.
+   io.write_string(goodbye(B1), !IO),
+   true.
+
+main(!IO)  :-
+   SomeB1 = 'new some_b'("test"),
+   do_something(SomeB1, !IO),
+   do_something_else(SomeB1, !IO).
+
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------