[m-dev.] diff: fix bug with recursive no_tag types

[Fergus Henderson]

Estimated hours taken: 1

Fix a bug where the compiler would go into an infinite
loop when processing a recursive no_tag type.
(I discovered this bug after the issue was raised by
Chris Okasaki <cdo at cs.columbia.edu> the Haskell mailing list.)

compiler/mode_util.m:
	In mode_to_arg_mode, keep a list of the no_tag
	types that we've already expanded, and stop the
	recursion if the type to be expanded is already
	in that list.

tests/valid/Mmakefile:
tests/valid/recursive_no_tag_type.m:
	A regression test.

Workspace: /home/mercury0/fjh/mercury
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.119
diff -u -d -r1.119 mode_util.m
--- compiler/mode_util.m	2000/02/07 00:31:09	1.119
+++ compiler/mode_util.m	2000/03/17 04:40:27
@@ -297,6 +297,12 @@
 %-----------------------------------------------------------------------------%
 
 mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode) :-
+	mode_to_arg_mode_2(ModuleInfo, Mode, Type, [], ArgMode).
+
+:- pred mode_to_arg_mode_2(module_info, mode, type, list(type_id), arg_mode).
+:- mode mode_to_arg_mode_2(in, in, in, in, out) is det.
+
+mode_to_arg_mode_2(ModuleInfo, Mode, Type, ContainingTypes, ArgMode) :-
 	%
 	% We need to handle no_tag types (types which have
 	% exactly one constructor, and whose one constructor
@@ -308,7 +314,10 @@
 	(
 		% is this a no_tag type?
 		type_constructors(Type, ModuleInfo, Constructors),
-		type_is_no_tag_type(Constructors, FunctorName, ArgType)
+		type_is_no_tag_type(Constructors, FunctorName, ArgType),
+		% avoid infinite recursion
+		type_to_type_id(Type, TypeId, _TypeArgs),
+		\+ list__member(TypeId, ContainingTypes)
 	->
 		% the arg_mode will be determined by the mode and
 		% type of the functor's argument,
@@ -321,14 +330,15 @@
 		get_single_arg_inst(FinalInst, ModuleInfo, ConsId,
 			FinalArgInst),
 		ModeOfArg = (InitialArgInst -> FinalArgInst),
-		mode_to_arg_mode(ModuleInfo, ModeOfArg, ArgType, ArgMode)
+		mode_to_arg_mode_2(ModuleInfo, ModeOfArg, ArgType,
+			[TypeId | ContainingTypes], ArgMode)
 	;
-		mode_to_arg_mode_2(ModuleInfo, Mode, ArgMode)
+		base_mode_to_arg_mode(ModuleInfo, Mode, ArgMode)
 	).
 
-:- pred mode_to_arg_mode_2(module_info, mode, arg_mode).
-:- mode mode_to_arg_mode_2(in, in, out) is det.
-mode_to_arg_mode_2(ModuleInfo, Mode, ArgMode) :-
+:- pred base_mode_to_arg_mode(module_info, mode, arg_mode).
+:- mode base_mode_to_arg_mode(in, in, out) is det.
+base_mode_to_arg_mode(ModuleInfo, Mode, ArgMode) :-
 	mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
 	( inst_is_bound(ModuleInfo, InitialInst) ->
 		ArgMode = top_in
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.57
diff -u -d -r1.57 Mmakefile
--- tests/valid/Mmakefile	2000/02/22 10:56:39	1.57
+++ tests/valid/Mmakefile	2000/03/17 14:05:55
@@ -107,6 +107,7 @@
 	pred_with_no_modes.m \
 	qualified_cons_id.m \
 	quantifier_warning.m \
+	recursive_no_tag_type.m \
 	same_length_2.m \
 	semidet_disj.m \
 	shape_type.m \
cvs diff: tests/valid/recursive_no_tag_type.m is a new entry, no comparison available
===================================
tests/valid/recursive_no_tag_type.m
===================================
:- module recursive_no_tag_type.
:- interface.
:- import_module std_util.

:- type t ---> f(t).

:- type inftype(B) ---> a(pair(B, inftype(B))).

:- type either(A, B) ---> left(A) ; right(B).
:- type alist(A) ---> b(either(unit, pair(A,alist(A)))).

:- pred p(t, t).
:- mode p(in, out) is multi.

:- func infy = inftype(int).
:- func onetwothree = alist(int).

:- implementation.

p(f(X), X).
p(X, f(X)).

infy = a(1 - infy).
onetwothree = b(right(1 - b(right(2 - b(right(3 - b(left(unit)))))))).


-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh>  |  of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3        |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------