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

[Simon Taylor]

Estimated hours taken: 1.5
Branches: main and release

compiler/intermod.m:
	Fix a bug which caused a software error when writing
	instance declarations to a `.opt' file when the
	method implementation for a function matched a constructor 
	or a field access function.
	Test case: tests/hard_coded/typeclasses/record_syntax.m.

Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.92
diff -u -u -r1.92 intermod.m
--- compiler/intermod.m	2001/03/05 04:02:35	1.92
+++ compiler/intermod.m	2001/03/07 02:38:09
@@ -873,18 +873,16 @@
 				list__remove_adjacent_dups(ClassPreds0,
 					ClassPreds),
 				assoc_list__from_corresponding_lists(
-					ClassPreds, Methods0, MethodAL0)
+					ClassPreds, Methods0, MethodAL)
 			;
 				error(
 	"intermod__gather_instances_3: method pred_proc_ids not filled in")
 			},
-			{ list__map(
+			{ list__map_foldl(
 				intermod__qualify_instance_method(ModuleInfo),
-				MethodAL0, MethodAL) },
-			{ assoc_list__keys(MethodAL, PredIds) },
-			{ assoc_list__values(MethodAL, Methods) },
-			list__map_foldl(intermod__add_proc,
-				PredIds, DoWriteMethodsList),
+				MethodAL, Methods, [], PredIds) },
+			list__map_foldl(intermod__add_proc, PredIds, 
+				DoWriteMethodsList),
 			{ bool__and_list(DoWriteMethodsList, DoWriteMethods) },
 			(
 				{ DoWriteMethods = yes },
@@ -936,11 +934,12 @@
 	% Resolve overloading of instance methods before writing them
 	% to the `.opt' file.
 :- pred intermod__qualify_instance_method(module_info::in,
-		pair(pred_id, instance_method)::in,
-		pair(pred_id, instance_method)::out) is det.
+		pair(pred_id, instance_method)::in, instance_method::out,
+		list(pred_id)::in, list(pred_id)::out) is det.
 
 intermod__qualify_instance_method(ModuleInfo,
-		MethodCallPredId - InstanceMethod0, PredId - InstanceMethod) :-
+		MethodCallPredId - InstanceMethod0,
+		InstanceMethod, PredIds0, PredIds) :-
 	module_info_pred_info(ModuleInfo, MethodCallPredId,
 		MethodCallPredInfo),
 	pred_info_arg_types(MethodCallPredInfo, MethodCallTVarSet, _,
@@ -950,32 +949,34 @@
 	(
 		InstanceMethodDefn0 = name(InstanceMethodName0),
 		PredOrFunc = function,
-		module_info_get_predicate_table(ModuleInfo, PredicateTable),
 		(
-			predicate_table_search_func_sym_arity(PredicateTable,
-				InstanceMethodName0, MethodArity, PredIds),
-			typecheck__find_matching_pred_id(PredIds, ModuleInfo,
+			find_func_matching_instance_method(ModuleInfo,
+				InstanceMethodName0, MethodArity,
 				MethodCallTVarSet, MethodCallArgTypes,
-				PredId0, InstanceMethodName1)
+				MaybePredId, InstanceMethodName)
 		->
-			PredId = PredId0,
-			InstanceMethodName = InstanceMethodName1
+			( MaybePredId = yes(PredId) ->
+				PredIds = [PredId | PredIds0]
+			;
+				PredIds = PredIds0
+			),
+			InstanceMethodDefn = name(InstanceMethodName)
 		;
-			hlds_out__simple_call_id_to_string(
-				function - InstanceMethodName0/MethodArity,
-				MethodStr),
-			string__append(
-			    "intermod__qualify_instance_method: undefined ",
-			    MethodStr, Msg),
-			error(Msg)
-		),
-		InstanceMethodDefn = name(InstanceMethodName)
+			% This will force intermod__add_proc to
+			% return DoWrite = no
+			invalid_pred_id(PredId),
+			PredIds = [PredId | PredIds0],
+
+			% We can just leave the method definition unchanged
+			InstanceMethodDefn = InstanceMethodDefn0
+		)
 	;
 		InstanceMethodDefn0 = name(InstanceMethodName0),
 		PredOrFunc = predicate,
 		typecheck__resolve_pred_overloading(ModuleInfo,
 			MethodCallArgTypes, MethodCallTVarSet,
 			InstanceMethodName0, InstanceMethodName, PredId),
+		PredIds = [PredId | PredIds0],
 		InstanceMethodDefn = name(InstanceMethodName)
 	;
 		InstanceMethodDefn0 = clauses(_ItemList),
@@ -988,11 +989,78 @@
 		%
 		% This will force intermod__add_proc to return DoWrite = no
 		invalid_pred_id(PredId),
+		PredIds = [PredId | PredIds0],
 		% We can just leave the method definition unchanged
 		InstanceMethodDefn = InstanceMethodDefn0
 	),
 	InstanceMethod = instance_method(PredOrFunc, MethodName,
 			InstanceMethodDefn, MethodArity, MethodContext).
+			
+	%
+	% A `func(x/n) is y' method implementation can match an ordinary
+	% function, a field access function or a constructor.
+	% For now, if there are multiple possible matches, we don't write
+	% the instance method.
+	%
+:- pred find_func_matching_instance_method(module_info::in, sym_name::in, 
+		arity::in, tvarset::in, list(type)::in,
+		maybe(pred_id)::out, sym_name::out) is semidet.
+
+find_func_matching_instance_method(ModuleInfo, InstanceMethodName0,
+		MethodArity, MethodCallTVarSet, MethodCallArgTypes,
+		MaybePredId, InstanceMethodName) :-
+
+	module_info_ctor_field_table(ModuleInfo, CtorFieldTable),
+	(
+		is_field_access_function_name(ModuleInfo, InstanceMethodName0,
+			MethodArity, _, FieldName),
+		map__search(CtorFieldTable, FieldName, FieldDefns)
+	->
+		TypeIds0 = list__map(
+			(func(FieldDefn) = TypeId :-
+				FieldDefn = hlds_ctor_field_defn(_, _,
+						TypeId, _, _)
+			), FieldDefns)
+	;
+		TypeIds0 = []
+	),
+	module_info_ctors(ModuleInfo, Ctors),
+	(
+		map__search(Ctors, cons(InstanceMethodName0, MethodArity),
+			MatchingConstructors)
+	->
+		TypeIds1 = list__map(
+			(func(ConsDefn) = TypeId :-
+				ConsDefn = hlds_cons_defn(_, _, _, TypeId, _)
+			), MatchingConstructors)
+	;
+		TypeIds1 = []
+	),
+	TypeIds = list__append(TypeIds0, TypeIds1),
+
+	module_info_get_predicate_table(ModuleInfo, PredicateTable),
+	(
+		predicate_table_search_func_sym_arity(PredicateTable,
+			InstanceMethodName0, MethodArity, PredIds),
+		typecheck__find_matching_pred_id(PredIds, ModuleInfo,
+			MethodCallTVarSet, MethodCallArgTypes,
+			PredId, InstanceMethodFuncName)
+	->
+		TypeIds = [],	
+		MaybePredId = yes(PredId),
+		InstanceMethodName = InstanceMethodFuncName
+	;
+		TypeIds = [TheTypeId],
+		MaybePredId = no,
+		( TheTypeId = qualified(TypeModule, _) - _ ->
+			unqualify_name(InstanceMethodName0, UnqualMethodName),
+			InstanceMethodName =
+				qualified(TypeModule, UnqualMethodName)
+		;	
+			error(
+	"unqualified type_id in hlds_cons_defn or hlds_ctor_field_defn")
+		)
+	).
 
 %-----------------------------------------------------------------------------%
 
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------