[m-rev.] for review: detect cycles in typeclass hierarchy

[Mark Brown]

This is for review by anyone.

Cheers,
Mark.

Estimated hours taken: 3
Branches: main

Check for cycles in the typeclass hierarchy.  This fixes a long-standing
bug whereby the compiler could go into an infinite loop in the polymorphism
stage if cycles were present.

compiler/check_typeclass.m:
	Add a pass to check through all visible typeclass declarations and
	report when a cycle is found.

	The interface to this module has been made more general, to reflect
	the fact that it checks the superclass relation as well as instance
	declarations.

compiler/mercury_compile.m:
	Use the new interface to the check_typeclass module.

compiler/error_util.m:
	Add a new format_component for sym_name_and_arity.

BUGS:
	Remove the bug report from this file.

tests/invalid/Mmakefile:
test/invalid/cyclic_typeclass.err_exp:
	Enable the cyclic_typeclass test, since we now pass it, and add an
	expected output file.  Also add a couple of new tests.

test/invalid/cyclic_typeclass_2.m:
test/invalid/cyclic_typeclass_2.err_exp:
test/invalid/cyclic_typeclass_3.m:
test/invalid/cyclic_typeclass_3.err_exp:
	New test cases.

Index: BUGS
===================================================================
RCS file: /home/mercury1/repository/mercury/BUGS,v
retrieving revision 1.19
diff -u -r1.19 BUGS
--- BUGS	5 Nov 2003 08:08:24 -0000	1.19
+++ BUGS	18 Jan 2005 18:33:54 -0000
@@ -152,18 +152,3 @@
 	list__map_foldl(MakeIndex, Args0, _, 0, _).
 
 -----------------------------------------------------------------------------
-
-Date: Wed, 1 Dec 1999 22:52:57 +1100
-Subject: compiler infinite loop for cyclic type classes
-
-According to the language reference manual:
-
-|  Typeclass constraints on type class declarations gives rise to a
-|  superclass relation.  This relation must be acyclic.  That is, it is an
-|  error if a type class is its own (direct or indirect) superclass.
-
-But if you try to compile modules containing cyclic typeclasses,
-the compiler goes into an infinite loop and eventually gets a
-stack overflow, rather than reporting a proper error message.
-
------------------------------------------------------------------------------
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.59
diff -u -r1.59 check_typeclass.m
--- compiler/check_typeclass.m	17 Jan 2005 05:01:33 -0000	1.59
+++ compiler/check_typeclass.m	18 Jan 2005 18:33:58 -0000
@@ -37,6 +37,8 @@
 % In addition, this pass checks that all superclass constraints are satisfied
 % by the instance declaration.
 %
+% This pass also checks for cycles in the typeclass hierarchy.
+%
 % This pass fills in the super class proofs and instance method pred/proc ids
 % in the instance table of the HLDS.
 %
@@ -53,7 +55,7 @@
 
 :- import_module bool, io.
 
-:- pred check_typeclass__check_instance_decls(qual_info::in, qual_info::out,
+:- pred check_typeclass__check_typeclasses(qual_info::in, qual_info::out,
 	module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
 
 :- implementation.
@@ -76,12 +78,24 @@
 :- import_module parse_tree__prog_util.
 
 :- import_module int, string.
-:- import_module list, assoc_list, map, set, term, varset.
+:- import_module list, assoc_list, map, set, svset, term, varset.
 :- import_module std_util, require.
 
+check_typeclass__check_typeclasses(!QualInfo, !ModuleInfo, FoundError, !IO) :-
+	check_typeclass__check_instance_decls(!QualInfo, !ModuleInfo,
+		FoundInstanceError, !IO),
+	module_info_classes(!.ModuleInfo, ClassTable),
+	check_for_cyclic_classes(ClassTable, FoundCycleError, !IO),
+	FoundError = bool.or(FoundInstanceError, FoundCycleError).
+
+%---------------------------------------------------------------------------%
+
 :- type error_message == pair(prog_context, list(format_component)).
 :- type error_messages == list(error_message).
 
+:- pred check_typeclass__check_instance_decls(qual_info::in, qual_info::out,
+	module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
+
 check_typeclass__check_instance_decls(!QualInfo, !ModuleInfo, FoundError,
 		!IO) :-
 	module_info_classes(!.ModuleInfo, ClassTable),
@@ -875,3 +889,111 @@
 	string__append_list([", `", String0, "'", String1], String).
 
 %---------------------------------------------------------------------------%
+
+:- pred check_for_cyclic_classes(class_table::in, bool::out, io::di, io::uo)
+	is det.
+
+check_for_cyclic_classes(ClassTable, Errors, !IO) :-
+	ClassIds = map__keys(ClassTable),
+	foldl2(find_cycles(ClassTable, []), ClassIds, set.init, _, [], Cycles),
+	(
+		Cycles = [],
+		Errors = no
+	;
+		Cycles = [_ | _],
+		Errors = yes,
+		foldl(report_cyclic_classes(ClassTable), Cycles, !IO)
+	).
+
+:- type class_path == list(class_id).
+
+	% find_cycles(ClassTable, Path, ClassId, !Visited, !Cycles)
+	%
+	% Perform a depth first traversal of the class hierarchy, starting
+	% from ClassId.  Path contains a list of nodes joining the current
+	% node to the root.  When we reach a node that has already been
+	% visited, check whether there is a cycle in the Path.
+	%
+:- pred find_cycles(class_table::in, class_path::in, class_id::in,
+	set(class_id)::in, set(class_id)::out,
+	list(class_path)::in, list(class_path)::out) is det.
+
+find_cycles(ClassTable, Path, ClassId, !Visited, !Cycles) :-
+	(
+		set.member(ClassId, !.Visited)
+	->
+		(
+			find_cycle(ClassId, Path, [ClassId], Cycle)
+		->
+			!:Cycles = [Cycle | !.Cycles]
+		;
+			true
+		)
+	;
+		svset.insert(ClassId, !Visited),
+		ClassIds = get_superclass_ids(ClassTable, ClassId),
+		foldl2(find_cycles(ClassTable, [ClassId | Path]), ClassIds,
+			!Visited, !Cycles)
+	).
+
+	% find_cycle(ClassId, PathRemaining, PathSoFar, Cycle)
+	%
+	% Check if ClassId is present in PathRemaining, and if so then make
+	% a cycle out of the front part of the path up to the point where
+	% the ClassId is found.  The part of the path checked so far is
+	% accumulated in PathSoFar.
+	%
+:- pred find_cycle(class_id::in, class_path::in, class_path::in,
+	class_path::out) is semidet.
+
+find_cycle(ClassId, [Head | Tail], Path0, Cycle) :-
+	Path = [Head | Path0],
+	(
+		ClassId = Head
+	->
+		Cycle = Path
+	;
+		find_cycle(ClassId, Tail, Path, Cycle)
+	).
+
+:- func get_superclass_ids(class_table, class_id) = list(class_id).
+
+get_superclass_ids(ClassTable, ClassId) = SuperclassIds :-
+	ClassDefn = map.lookup(ClassTable, ClassId),
+	SuperclassIds = list.map(get_constraint_id, ClassDefn ^ class_supers).
+
+:- func get_constraint_id(class_constraint) = class_id.
+
+get_constraint_id(constraint(Name, Args)) = class_id(Name, length(Args)).
+
+	% Report an error using the format
+	%
+	%	module.m:NNN: Error: cyclic superclass relation detected:
+	%	module.m:NNN:   `foo/N' <= `bar/N' <= `baz/N' <= `foo/N'
+	%
+:- pred report_cyclic_classes(class_table::in, class_path::in, io::di, io::uo)
+	is det.
+
+report_cyclic_classes(ClassTable, ClassPath, !IO) :-
+	(
+		ClassPath = [],
+		error("report_cyclic_classes: empty cycle found")
+	;
+		ClassPath = [ClassId | Tail],
+		Context = map.lookup(ClassTable, ClassId) ^ class_context,
+		ClassId = class_id(Name, Arity),
+		RevPieces0 = [
+			sym_name_and_arity(Name/Arity),
+			words("Error: cyclic superclass relation detected:")
+		],
+		RevPieces1 = foldl(add_path_element, Tail, RevPieces0),
+		Pieces = list.reverse(RevPieces1),
+		write_error_pieces(Context, 0, Pieces, !IO)
+	).
+
+:- func add_path_element(class_id, list(format_component))
+	= list(format_component).
+
+add_path_element(class_id(Name, Arity), RevPieces0) =
+	[sym_name_and_arity(Name/Arity), words("<=") | RevPieces0].
+
Index: compiler/error_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/error_util.m,v
retrieving revision 1.30
diff -u -r1.30 error_util.m
--- compiler/error_util.m	17 Jan 2005 05:01:33 -0000	1.30
+++ compiler/error_util.m	18 Jan 2005 18:34:01 -0000
@@ -57,6 +57,11 @@
 	;	sym_name(sym_name)
 				% The output should contain the string form of
 				% the sym_name, surrounded by `' quotes.
+	
+	;	sym_name_and_arity(sym_name_and_arity)
+				% The output should contain the string form of
+				% the sym_name, followed by '/' and the arity,
+				% all surrounded by `' quotes.
 
 	;	nl.		% Insert a line break if there has been text
 				% output since the last line break.
@@ -334,6 +339,14 @@
 			Str = Word ++ " " ++ TailStr
 		)
 	;
+		Component = sym_name_and_arity(SymNameAndArity),
+		Word = sym_name_and_arity_to_word(SymNameAndArity),
+		( TailStr = "" ->
+			Str = Word
+		;
+			Str = Word ++ " " ++ TailStr
+		)
+	;
 		Component = nl,
 		Str = "\n" ++ TailStr
 	).
@@ -370,6 +383,11 @@
 		RevWords1 = [word(sym_name_to_word(SymName)) | RevWords0],
 		Paras1 = Paras0
 	;
+		Component = sym_name_and_arity(SymNameAndArity),
+		Word = sym_name_and_arity_to_word(SymNameAndArity),
+		RevWords1 = [word(Word) | RevWords0],
+		Paras1 = Paras0
+	;
 		Component = nl,
 		Strings = rev_words_to_strings(RevWords0),
 		Paras1 = [Strings | Paras0],
@@ -410,6 +428,11 @@
 sym_name_to_word(SymName) = "`" ++ SymStr ++ "'" :-
 	sym_name_to_string(SymName, SymStr).
 
+:- func sym_name_and_arity_to_word(sym_name_and_arity) = string.
+
+sym_name_and_arity_to_word(SymNameAndArity) = "`" ++ SymStr ++ "'" :-
+	sym_name_and_arity_to_string(SymNameAndArity, SymStr).
+
 :- pred break_into_words(string::in, list(word)::in, list(word)::out) is det.
 
 break_into_words(String, Words0, Words) :-
@@ -560,6 +583,10 @@
 	;
 		Piece0 = sym_name(SymName),
 		String = sym_name_to_word(SymName),
+		Piece = fixed(string__append(String, char_to_string(Punc)))
+	;
+		Piece0 = sym_name_and_arity(SymNameAndArity),
+		String = sym_name_and_arity_to_word(SymNameAndArity),
 		Piece = fixed(string__append(String, char_to_string(Punc)))
 	;
 		Piece0 = nl,
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.318
diff -u -r1.318 mercury_compile.m
--- compiler/mercury_compile.m	23 Dec 2004 06:49:16 -0000	1.318
+++ compiler/mercury_compile.m	18 Jan 2005 18:34:11 -0000
@@ -1957,8 +1957,8 @@
 	globals__lookup_bool_option(Globals, verbose, Verbose),
 	globals__lookup_bool_option(Globals, statistics, Stats),
 	maybe_write_string(Verbose,
-		"% Checking typeclass instances...\n", !IO),
-	check_typeclass__check_instance_decls(QualInfo0, QualInfo, !HLDS,
+		"% Checking typeclasses...\n", !IO),
+	check_typeclass__check_typeclasses(QualInfo0, QualInfo, !HLDS,
 		FoundTypeclassError, !IO),
 	mercury_compile__maybe_dump_hlds(!.HLDS, 5, "typeclass", !IO),
 	make_hlds__set_module_recompilation_info(QualInfo, !HLDS),
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.156
diff -u -r1.156 Mmakefile
--- tests/invalid/Mmakefile	6 Jan 2005 04:30:55 -0000	1.156
+++ tests/invalid/Mmakefile	18 Jan 2005 18:34:28 -0000
@@ -56,6 +56,9 @@
 	conflicting_tabling_pragmas \
 	constrained_poly_insts \
 	constructor_warning \
+	cyclic_typeclass \
+	cyclic_typeclass_2 \
+	cyclic_typeclass_3 \
 	det_errors \
 	duplicate_modes \
 	duplicate_module_test \
@@ -188,7 +191,6 @@
 #	typeclass_test_8 (minor formatting error in the output --
 #			the type class name should be in quotes)
 #	typeclass_mode_{2,3,4} (compiler calls error/1)
-#	cyclic_typeclass (compiler goes into an infinite loop)
 #	ho_default_func_4 (due to a bug in the mode-checker ---
 #			see XXX comment in inst_match:inst_matches_final_3)
 #	inst_matches_final_bug (due to same bug as ho_default_func_4)
Index: tests/invalid/cyclic_typeclass.err_exp
===================================================================
RCS file: tests/invalid/cyclic_typeclass.err_exp
diff -N tests/invalid/cyclic_typeclass.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/cyclic_typeclass.err_exp	18 Jan 2005 18:34:28 -0000
@@ -0,0 +1,4 @@
+cyclic_typeclass.m:030: Error: cyclic superclass relation detected:
+cyclic_typeclass.m:030:   `cyclic_typeclass.bar/1' <= `cyclic_typeclass.foo/1'
+cyclic_typeclass.m:030:   <= `cyclic_typeclass.bar/1'
+For more information, try recompiling with `-E'.
Index: tests/invalid/cyclic_typeclass_2.err_exp
===================================================================
RCS file: tests/invalid/cyclic_typeclass_2.err_exp
diff -N tests/invalid/cyclic_typeclass_2.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/cyclic_typeclass_2.err_exp	18 Jan 2005 18:34:28 -0000
@@ -0,0 +1,5 @@
+cyclic_typeclass_2.m:014: Error: cyclic superclass relation detected:
+cyclic_typeclass_2.m:014:   `cyclic_typeclass_2.bar/1' <=
+cyclic_typeclass_2.m:014:   `cyclic_typeclass_2.foo/1' <=
+cyclic_typeclass_2.m:014:   `cyclic_typeclass_2.bar/1'
+For more information, try recompiling with `-E'.
Index: tests/invalid/cyclic_typeclass_2.m
===================================================================
RCS file: tests/invalid/cyclic_typeclass_2.m
diff -N tests/invalid/cyclic_typeclass_2.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/cyclic_typeclass_2.m	18 Jan 2005 18:34:28 -0000
@@ -0,0 +1,17 @@
+:- module cyclic_typeclass_2.
+
+% This test is a cut down version of cyclic_typeclass.  This one doesn't
+% cause the compiler to go into an infinite loop, but it still contains
+% an error that goes unreported, and may cause an infinite loop when
+% compiling other modules that import it.
+
+:- interface.
+
+:- typeclass foo(A) <= bar(A) where [
+	func foo(A) = int
+].
+
+:- typeclass bar(A) <= foo(A) where [
+	func bar(A) = int
+].
+
Index: tests/invalid/cyclic_typeclass_3.err_exp
===================================================================
RCS file: tests/invalid/cyclic_typeclass_3.err_exp
diff -N tests/invalid/cyclic_typeclass_3.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/cyclic_typeclass_3.err_exp	18 Jan 2005 18:34:28 -0000
@@ -0,0 +1,11 @@
+cyclic_typeclass_3.m:014: Error: cyclic superclass relation detected:
+cyclic_typeclass_3.m:014:   `cyclic_typeclass_3.c/1' <=
+cyclic_typeclass_3.m:014:   `cyclic_typeclass_3.e/1' <=
+cyclic_typeclass_3.m:014:   `cyclic_typeclass_3.i/1' <=
+cyclic_typeclass_3.m:014:   `cyclic_typeclass_3.c/1'
+cyclic_typeclass_3.m:012: Error: cyclic superclass relation detected:
+cyclic_typeclass_3.m:012:   `cyclic_typeclass_3.a/1' <=
+cyclic_typeclass_3.m:012:   `cyclic_typeclass_3.b/1' <=
+cyclic_typeclass_3.m:012:   `cyclic_typeclass_3.g/1' <=
+cyclic_typeclass_3.m:012:   `cyclic_typeclass_3.a/1'
+For more information, try recompiling with `-E'.
Index: tests/invalid/cyclic_typeclass_3.m
===================================================================
RCS file: tests/invalid/cyclic_typeclass_3.m
diff -N tests/invalid/cyclic_typeclass_3.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/cyclic_typeclass_3.m	18 Jan 2005 18:34:28 -0000
@@ -0,0 +1,21 @@
+:- module cyclic_typeclass_3.
+:- interface.
+
+% The cycles are:
+%	`a/1' <= `b/1' <= `g/1' <= `a/1'
+%	`a/1' <= `c/1' <= `e/1' <= `g/1' <= `a/1'
+%	`c/1' <= `e/1' <= `i/1' <= `c/1'
+%
+% The second of these is not reported, however, since a cycle for `a/1'
+% will have already been detected and reported.
+
+:- typeclass a(T) <= (b(T), c(T))	where [].
+:- typeclass b(T) <= g(T)		where [].
+:- typeclass c(T) <= (d(T), e(T), f(T))	where [].
+:- typeclass d(T) 			where [].
+:- typeclass e(T) <= (g(T), h(T), i(T))	where [].
+:- typeclass f(T) 			where [].
+:- typeclass g(T) <= a(T)		where [].
+:- typeclass h(T) <= f(T)		where [].
+:- typeclass i(T) <= c(T)		where [].
+
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------