[m-dev.] for review: fix bug in inter-module optimization

[Simon Taylor]

Estimated hours taken: 1

Fix a bug in inter-module optimization reported by Zoltan.

compiler/intermod.m:
	Make sure that user-defined equality predicates are exported
	if the types are exported.

compiler/hlds_data.m:
	Add predicate hlds_data__set_type_defn_body, to update the
	body of a discriminated union type after module qualifying
	the user-defined equality predicate.

tests/valid/Mmakefile:
tests/valid/intermod_user_equality.m:
tests/valid/intermod_user_equality2.m:
	Test case.



Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.43
diff -u -u -r1.43 hlds_data.m
--- hlds_data.m	2000/01/13 06:15:35	1.43
+++ hlds_data.m	2000/01/27 02:14:59
@@ -236,6 +236,10 @@
 			hlds_type_defn).
 :- mode hlds_data__set_type_defn_status(in, in, out) is det.
 
+:- pred hlds_data__set_type_defn_body(hlds_type_defn, hlds_type_body,
+			hlds_type_defn).
+:- mode hlds_data__set_type_defn_body(in, in, out) is det.
+
 	% An `hlds_type_body' holds the body of a type definition:
 	% du = discriminated union, uu = undiscriminated union,
 	% eqv_type = equivalence type (a type defined to be equivalent
@@ -382,6 +386,8 @@
 hlds_data__get_type_defn_status(hlds_type_defn(_, _, _, Status, _), Status).
 hlds_data__get_type_defn_context(hlds_type_defn(_, _, _, _, Context), Context).
 
+hlds_data__set_type_defn_body(hlds_type_defn(A, B, _, D, E), Body,
+				hlds_type_defn(A, B, Body, D, E)).
 hlds_data__set_type_defn_status(hlds_type_defn(A, B, C, _, E), Status, 
 				hlds_type_defn(A, B, C, Status, E)).
 
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.76
diff -u -u -r1.76 intermod.m
--- intermod.m	1999/12/03 12:55:02	1.76
+++ intermod.m	2000/01/28 00:42:20
@@ -127,6 +127,8 @@
 			HigherOrderSizeLimit, Deforestation,
 			IntermodInfo0, IntermodInfo1) },
 		{ intermod__gather_instances(IntermodInfo1,
+			IntermodInfo2) },
+		{ intermod__gather_types(IntermodInfo2,
 			IntermodInfo) },
 		intermod__write_intermod_info(IntermodInfo),
 		{ intermod_info_get_module_info(ModuleInfo1,
@@ -148,10 +150,12 @@
 			set(module_name),	% modules to import
 			set(pred_id), 		% preds to output clauses for
 			set(pred_id),	 	% preds to output decls for
-			list(pair(class_id, hlds_instance_defn)),
+			assoc_list(class_id, hlds_instance_defn),
 						% instances declarations
 						% to write
-			unit,
+			assoc_list(type_id, hlds_type_defn),
+						% type declarations
+						% to write
 			unit,
 			module_info,
 			bool,			% do the c_header_codes for
@@ -170,7 +174,8 @@
 	map__init(VarTypes),
 	varset__init(TVarSet),
 	Instances = [],
-	IntermodInfo = info(Modules, Procs, ProcDecls, Instances, unit,
+	Types = [],
+	IntermodInfo = info(Modules, Procs, ProcDecls, Instances, Types,
 			unit, ModuleInfo, no, VarTypes, TVarSet).
 			
 %-----------------------------------------------------------------------------%
@@ -926,6 +931,62 @@
 	).
 
 %-----------------------------------------------------------------------------%
+
+:- pred intermod__gather_types(intermod_info::in, intermod_info::out) is det.
+
+intermod__gather_types -->
+	intermod_info_get_module_info(ModuleInfo),
+	{ module_info_types(ModuleInfo, Types) },
+	map__foldl(intermod__gather_types_2, Types).
+
+:- pred intermod__gather_types_2(type_id::in,
+	hlds_type_defn::in, intermod_info::in, intermod_info::out) is det.
+
+intermod__gather_types_2(TypeId, TypeDefn0, Info0, Info) :-
+	intermod_info_get_module_info(ModuleInfo, Info0, Info1),
+	module_info_name(ModuleInfo, ModuleName),
+	(
+	    intermod__should_write_type(ModuleName, TypeId, TypeDefn0)
+	->
+	    (
+		hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
+		TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEq0),
+		MaybeUserEq0 = yes(UserEq0)
+	    ->
+		module_info_get_special_pred_map(ModuleInfo, SpecialPreds),
+		map__lookup(SpecialPreds, unify - TypeId, UnifyPredId),
+		module_info_pred_info(ModuleInfo, UnifyPredId, UnifyPredInfo),
+		pred_info_arg_types(UnifyPredInfo, TVarSet, _, ArgTypes),
+		typecheck__resolve_pred_overloading(ModuleInfo, ArgTypes,
+			TVarSet, UserEq0, UserEq, UserEqPredId),
+		TypeBody = du_type(Ctors, Tags, Enum, yes(UserEq)),
+		hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn),
+
+		% XXX this won't work if the predicate is
+		% exported to sub-modules.
+		intermod__add_proc(UserEqPredId, _, Info1, Info2)
+	    ;	
+		Info2 = Info1,
+		TypeDefn = TypeDefn0
+	    ),
+	    intermod_info_get_types(Types0, Info2, Info3),
+	    intermod_info_set_types([TypeId - TypeDefn | Types0], Info3, Info)
+	;
+	    Info = Info1
+	).
+
+:- pred intermod__should_write_type(module_name::in,
+		type_id::in, hlds_type_defn::in) is semidet.
+
+intermod__should_write_type(ModuleName, TypeId, TypeDefn) :-
+	hlds_data__get_type_defn_status(TypeDefn, ImportStatus),
+	TypeId = Name - _Arity,
+	Name = qualified(ModuleName, _),
+	( ImportStatus = local
+	; ImportStatus = abstract_exported
+	).
+
+%-----------------------------------------------------------------------------%
 	% Output module imports, types, modes, insts and predicates
 
 :- pred intermod__write_intermod_info(intermod_info::in,
@@ -968,7 +1029,7 @@
 		io__state::uo) is det.
 
 intermod__write_intermod_info_2(IntermodInfo) -->
-	{ IntermodInfo = info(_, Preds0, PredDecls0, Instances, _, _,
+	{ IntermodInfo = info(_, Preds0, PredDecls0, Instances, Types, _,
 				ModuleInfo, WriteHeader, _, _) },
 	{ set__to_sorted_list(Preds0, Preds) }, 
 	{ set__to_sorted_list(PredDecls0, PredDecls) },
@@ -985,7 +1046,7 @@
 		[]
 	),
 
-	intermod__write_types(ModuleInfo),
+	intermod__write_types(Types),
 	intermod__write_insts(ModuleInfo),
 	intermod__write_modes(ModuleInfo),
 	intermod__write_classes(ModuleInfo),
@@ -1027,50 +1088,38 @@
         intermod__write_c_header(Headers),
         mercury_output_pragma_c_header(Header).
 
-:- pred intermod__write_types(module_info::in,
+:- pred intermod__write_types(assoc_list(type_id, hlds_type_defn)::in,
 		io__state::di, io__state::uo) is det.
 
-intermod__write_types(ModuleInfo) -->
-	{ module_info_name(ModuleInfo, ModuleName) },
-	{ module_info_types(ModuleInfo, Types) },
-	map__foldl(intermod__write_type(ModuleName), Types).
+intermod__write_types(Types) -->
+	list__foldl(intermod__write_type, Types).
 
-:- pred intermod__write_type(module_name::in, type_id::in,
-		hlds_type_defn::in, io__state::di, io__state::uo) is det.
+:- pred intermod__write_type(pair(type_id, hlds_type_defn)::in,
+		io__state::di, io__state::uo) is det.
 
-intermod__write_type(ModuleName, TypeId, TypeDefn) -->
-	{ hlds_data__get_type_defn_status(TypeDefn, ImportStatus) },
+intermod__write_type(TypeId - TypeDefn) -->
+	{ hlds_data__get_type_defn_tvarset(TypeDefn, VarSet) },
+	{ hlds_data__get_type_defn_tparams(TypeDefn, Args) },
+	{ hlds_data__get_type_defn_body(TypeDefn, Body) },
+	{ hlds_data__get_type_defn_context(TypeDefn, Context) },
 	{ TypeId = Name - _Arity },
 	(
-		{ Name = qualified(ModuleName, _) },
-		{ ImportStatus = local
-		; ImportStatus = abstract_exported
-		}
-	->
-		{ hlds_data__get_type_defn_tvarset(TypeDefn, VarSet) },
-		{ hlds_data__get_type_defn_tparams(TypeDefn, Args) },
-		{ hlds_data__get_type_defn_body(TypeDefn, Body) },
-		{ hlds_data__get_type_defn_context(TypeDefn, Context) },
-		(
-			{ Body = du_type(Ctors, _, _, MaybeEqualityPred) },
-			mercury_output_type_defn(VarSet,
-				du_type(Name, Args, Ctors,
-					MaybeEqualityPred),
-				Context)
-		;
-			{ Body = uu_type(_) },
-			{ error("uu types not implemented") }
-		;
-			{ Body = eqv_type(EqvType) },
-			mercury_output_type_defn(VarSet,
-				eqv_type(Name, Args, EqvType), Context)
-		;
-			{ Body = abstract_type },
-			mercury_output_type_defn(VarSet,
-				abstract_type(Name, Args), Context)
-		)
-	;
-		[]
+		{ Body = du_type(Ctors, _, _, MaybeEqualityPred) },
+		mercury_output_type_defn(VarSet,
+			du_type(Name, Args, Ctors,
+				MaybeEqualityPred),
+			Context)
+	;
+		{ Body = uu_type(_) },
+		{ error("uu types not implemented") }
+	;
+		{ Body = eqv_type(EqvType) },
+		mercury_output_type_defn(VarSet,
+			eqv_type(Name, Args, EqvType), Context)
+	;
+		{ Body = abstract_type },
+		mercury_output_type_defn(VarSet,
+			abstract_type(Name, Args), Context)
 	).
 
 :- pred intermod__write_modes(module_info::in,
@@ -1590,8 +1639,8 @@
 :- pred intermod_info_get_instances(
 			assoc_list(class_id, hlds_instance_defn)::out, 
 			intermod_info::in, intermod_info::out) is det.
-%:- pred intermod_info_get_modes(set(mode_id)::out, 
-%			intermod_info::in, intermod_info::out) is det.
+:- pred intermod_info_get_types(assoc_list(type_id, hlds_type_defn)::out, 
+			intermod_info::in, intermod_info::out) is det.
 %:- pred intermod_info_get_insts(set(inst_id)::out, 
 %			intermod_info::in, intermod_info::out) is det.
 :- pred intermod_info_get_module_info(module_info::out,
@@ -1609,6 +1658,7 @@
 					=(info(_,_,ProcDecls,_,_,_,_,_,_,_)).
 intermod_info_get_instances(Instances) -->
 		=(info(_,_,_,Instances,_,_,_,_,_,_)).
+intermod_info_get_types(Types)		--> =(info(_,_,_,_,Types,_,_,_,_,_)).
 %intermod_info_get_modes(Modes)		--> =(info(_,_,_,_,Modes,_,_,_,_,_)).
 %intermod_info_get_insts(Insts)		--> =(info(_,_,_,_,_,Insts,_,_,_,_)).
 intermod_info_get_module_info(Module)	--> =(info(_,_,_,_,_,_,Module,_,_,_)).
@@ -1625,8 +1675,8 @@
 :- pred intermod_info_set_instances(
 			assoc_list(class_id, hlds_instance_defn)::in, 
 			intermod_info::in, intermod_info::out) is det.
-%:- pred intermod_info_set_modes(set(mode_id)::in, 
-%			intermod_info::in, intermod_info::out) is det.
+:- pred intermod_info_set_types(assoc_list(type_id, hlds_type_defn)::in, 
+			intermod_info::in, intermod_info::out) is det.
 %:- pred intermod_info_set_insts(set(inst_id)::in, 
 %			intermod_info::in, intermod_info::out) is det.
 :- pred intermod_info_set_module_info(module_info::in,
@@ -1649,10 +1699,10 @@
 
 intermod_info_set_instances(Instances, info(A,B,C,_,E,F,G,H,I,J),
 				info(A,B,C, Instances, E,F,G,H,I,J)).
+
+intermod_info_set_types(Types, info(A,B,C,D, _, F,G,H,I,J),
+				info(A,B,C,D, Types, F,G,H,I,J)).
 
-%intermod_info_set_modes(Modes, info(A,B,C,D,_,F,G,H,I,J),
-%				info(A,B,C,D, Modes, F,G,H,I,J)).
-%
 %intermod_info_set_insts(Insts, info(A,B,C,D,E,_,G,H,I,J),
 %				info(A,B,C,D,E, Insts, G,H,I,J)).
 
@@ -1688,7 +1738,8 @@
 	globals__lookup_int_option(Globals, higher_order_size_limit,
 		HigherOrderSizeLimit),
 	intermod__gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
-		Deforestation, Info0, Info),
+		Deforestation, Info0, Info1),
+	intermod__gather_types(Info1, Info),
 	do_adjust_pred_import_status(Info, Module0, Module),
 	maybe_write_string(VVerbose, " done\n", IO2, IO).
 
@@ -1719,14 +1770,8 @@
 
 adjust_type_status_2(TypeId - TypeDefn0, TypeId - TypeDefn,
 		ModuleInfo0, ModuleInfo) :-
-	hlds_data__get_type_defn_status(TypeDefn0, Status),
-	(
-		module_info_name(ModuleInfo0, ModuleName),
-		TypeId = qualified(ModuleName, _) - _,
-		( Status = local
-		; Status = abstract_exported
-		)
-	->
+	module_info_name(ModuleInfo0, ModuleName),
+	( intermod__should_write_type(ModuleName, TypeId, TypeDefn0) ->
 		hlds_data__set_type_defn_status(TypeDefn0, exported, TypeDefn),
 		fixup_special_preds(TypeId, ModuleInfo0, ModuleInfo)
 	;
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.50
diff -u -u -r1.50 Mmakefile
--- Mmakefile	1999/12/03 12:55:21	1.50
+++ Mmakefile	2000/01/28 00:30:19
@@ -67,6 +67,7 @@
 	intermod_quote.m \
 	intermod_test.m \
 	intermod_typeclass.m \
+	intermod_user_equality.m \
 	ite_to_disj.m \
 	lambda_inference.m\
 	lambda_instmap_bug.m \
@@ -197,6 +198,8 @@
 MCFLAGS-intermod_test2		= --intermodule-optimization
 MCFLAGS-intermod_typeclass	= --intermodule-optimization
 MCFLAGS-intermod_typeclass2	= --intermodule-optimization
+MCFLAGS-intermod_user_equality	= --intermodule-optimization
+MCFLAGS-intermod_user_equality2	= --intermodule-optimization
 MCFLAGS-ite_to_disj		= --aditi
 MCFLAGS-livevals_seq		= -O5 --opt-space
 MCFLAGS-middle_rec_labels	= --middle-rec --no-follow-vars 
Index: tests/valid/intermod_user_equality.m
===================================================================
RCS file: intermod_user_equality.m
diff -N intermod_user_equality.m
--- /dev/null	Fri Jan 28 11:36:10 2000
+++ intermod_user_equality.m	Fri Jan 28 11:31:27 2000
@@ -0,0 +1,11 @@
+:- module intermod_user_equality.
+
+:- interface.
+
+:- import_module intermod_user_equality2.
+:- pred check_foo(foo::in) is semidet.
+
+:- implementation.
+
+check_foo(Foo) :- Foo = Foo.
+
Index: tests/valid/intermod_user_equality2.m
===================================================================
RCS file: intermod_user_equality2.m
diff -N intermod_user_equality2.m
--- /dev/null	Fri Jan 28 11:36:10 2000
+++ intermod_user_equality2.m	Fri Jan 28 11:31:46 2000
@@ -0,0 +1,19 @@
+:- module intermod_user_equality2.
+
+:- interface.
+
+:- type foo.
+
+:- pred foo_field1(foo::in, int::out) is cc_nondet.
+
+:- implementation.
+
+:- type foo
+	--->	ctor1(int, int)
+	;	ctor2(int, int)
+	where equality is foo_unify.
+
+:- pred foo_unify(foo::in, foo::in) is semidet.
+foo_unify(X, X).
+
+foo_field1(ctor1(X, _), X).
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------