diff --git a/BUGS b/BUGS index 0e1930b3f..7cedd2f28 100644 --- a/BUGS +++ b/BUGS @@ -152,18 +152,3 @@ test(Args0) :- 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. - ------------------------------------------------------------------------------ diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m index fe7f7db9a..66381662a 100644 --- a/compiler/check_typeclass.m +++ b/compiler/check_typeclass.m @@ -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. @@ -77,12 +79,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), @@ -876,3 +890,111 @@ constraint_list_to_string_2(VarSet, [C | Cs], String) :- 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]. + diff --git a/compiler/error_util.m b/compiler/error_util.m index 8ed8a07eb..aeca5edcd 100644 --- a/compiler/error_util.m +++ b/compiler/error_util.m @@ -58,6 +58,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 @@ error_pieces_to_string([Component | Components]) = Str :- ; 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 @@ convert_components_to_word_list([Component | Components], RevWords0, Component = sym_name(SymName), 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), @@ -411,6 +429,11 @@ rev_words_to_rev_strings([Word | Words]) = Strings :- 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) :- @@ -562,6 +585,10 @@ append_punctuation([Piece0], Punc) = [Piece] :- 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, error("append_punctutation: " ++ diff --git a/compiler/mercury_compile.m b/compiler/mercury_compile.m index ce9c92a4d..c16c34275 100644 --- a/compiler/mercury_compile.m +++ b/compiler/mercury_compile.m @@ -1958,8 +1958,8 @@ mercury_compile__frontend_pass_no_type_error(QualInfo0, 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), diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile index 2a685d9f5..49d58857c 100644 --- a/tests/invalid/Mmakefile +++ b/tests/invalid/Mmakefile @@ -56,6 +56,9 @@ SINGLEMODULE= \ 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 @@ TYPE_SPEC_MODULES = \ # 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) diff --git a/tests/invalid/cyclic_typeclass.err_exp b/tests/invalid/cyclic_typeclass.err_exp new file mode 100644 index 000000000..f09ff59b1 --- /dev/null +++ b/tests/invalid/cyclic_typeclass.err_exp @@ -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'. diff --git a/tests/invalid/cyclic_typeclass_2.err_exp b/tests/invalid/cyclic_typeclass_2.err_exp new file mode 100644 index 000000000..aee81478f --- /dev/null +++ b/tests/invalid/cyclic_typeclass_2.err_exp @@ -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'. diff --git a/tests/invalid/cyclic_typeclass_2.m b/tests/invalid/cyclic_typeclass_2.m new file mode 100644 index 000000000..1c197d626 --- /dev/null +++ b/tests/invalid/cyclic_typeclass_2.m @@ -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 +]. + diff --git a/tests/invalid/cyclic_typeclass_3.err_exp b/tests/invalid/cyclic_typeclass_3.err_exp new file mode 100644 index 000000000..144164370 --- /dev/null +++ b/tests/invalid/cyclic_typeclass_3.err_exp @@ -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'. diff --git a/tests/invalid/cyclic_typeclass_3.m b/tests/invalid/cyclic_typeclass_3.m new file mode 100644 index 000000000..234a63dbd --- /dev/null +++ b/tests/invalid/cyclic_typeclass_3.m @@ -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 []. +