[m-rev.] for review: fix expand equivalence type for special preds bug

[Peter Ross]

Hi,

===================================================================


Estimated hours taken: 6
Branches: main

Fix a bug highlighted by the .NET backend where the comparison,
unification and index predicates for types defined as equivalence
types were being generated refering to the original types instead of
the expanded out equivalent type.

compiler/ml_code_util.m:
	Expand out the equivalence types in any special preds before
	generating the func_params type.

compiler/rtti.m:
	Record the the actual argument types for a special predicate
	in the rtti_proc_label type.

compiler/special_pred.m:
	Add a new predicate, is_special_pred, which tests if a
	pred_info represents a special pred and return the list of
	arguments with all the equivalence types expanded out.

compiler/type_util.m:
	Add a utility predicate to expand out equivalence types.

compiler/typecheck.m:
	Ensure that the type_table map lookup can't fail by only
	searching for user_types in the type table.

compiler/code_util.m:
compiler/layout_out.m:
	Handle the rtti_proc_label structure correctly.


Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.139
diff -u -r1.139 code_util.m
--- compiler/code_util.m	1 Nov 2002 09:56:53 -0000	1.139
+++ compiler/code_util.m	7 Nov 2002 11:34:15 -0000
@@ -298,7 +298,7 @@
 		IsImported, _IsPseudoImported, _IsExported,
 		IsSpecialPredInstance),
 	(
-		IsSpecialPredInstance = yes
+		IsSpecialPredInstance = yes(_ActualArgTypes)
 	->
 		(
 			special_pred_get_type(PredName, ArgTypes, Type),
Index: compiler/layout_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/layout_out.m,v
retrieving revision 1.16
diff -u -r1.16 layout_out.m
--- compiler/layout_out.m	29 Sep 2002 10:30:41 -0000	1.16
+++ compiler/layout_out.m	7 Nov 2002 11:34:16 -0000
@@ -348,7 +348,7 @@
 		{ BeingDefined = yes }
 	),
 	(
-		{ RttiProcLabel ^ is_special_pred_instance = yes },
+		{ RttiProcLabel ^ is_special_pred_instance = yes(_) },
 		io__write_string("MR_Compiler_ProcStatic ")
 	;
 		{ RttiProcLabel ^ is_special_pred_instance = no },
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.65
diff -u -r1.65 ml_code_util.m
--- compiler/ml_code_util.m	1 Nov 2002 09:56:54 -0000	1.65
+++ compiler/ml_code_util.m	7 Nov 2002 11:34:17 -0000
@@ -803,6 +803,7 @@
 
 :- import_module parse_tree__prog_data, parse_tree__prog_io.
 :- import_module hlds__hlds_goal, (parse_tree__inst), hlds__instmap.
+:- import_module hlds__special_pred.
 :- import_module check_hlds__polymorphism.
 :- import_module backend_libs__foreign.
 :- import_module parse_tree__prog_util, check_hlds__type_util.
@@ -1103,7 +1104,7 @@
 	proc_info_varset(ProcInfo, VarSet),
 	proc_info_headvars(ProcInfo, HeadVars),
 	pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
-	pred_info_arg_types(PredInfo, HeadTypes),
+	HeadTypes = get_actual_arg_types(ModuleInfo, PredInfo),
 	proc_info_argmodes(ProcInfo, HeadModes),
 	proc_info_interface_code_model(ProcInfo, CodeModel),
 	HeadVarNames = ml_gen_var_names(VarSet, HeadVars),
@@ -1117,7 +1118,7 @@
 	proc_info_varset(ProcInfo, VarSet),
 	proc_info_headvars(ProcInfo, HeadVars),
 	pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
-	pred_info_arg_types(PredInfo, HeadTypes),
+	HeadTypes = get_actual_arg_types(ModuleInfo, PredInfo),
 	proc_info_argmodes(ProcInfo, HeadModes),
 	proc_info_interface_code_model(ProcInfo, CodeModel),
 	HeadVarNames = ml_gen_var_names(VarSet, HeadVars),
@@ -1140,11 +1141,15 @@
 	% from the module_info, pred_id, and proc_id.
 	%
 ml_gen_proc_params_from_rtti(ModuleInfo, RttiProcId) = FuncParams :-
-	HeadVars = RttiProcId^proc_headvars,
-	ArgTypes = RttiProcId^arg_types,
-	ArgModes = RttiProcId^proc_arg_modes,
-	PredOrFunc = RttiProcId^pred_or_func,
-	CodeModel = RttiProcId^proc_interface_code_model,
+	HeadVars = RttiProcId ^ proc_headvars,
+	( RttiProcId ^ is_special_pred_instance = yes(ArgTypes0) ->
+		ArgTypes = ArgTypes0
+	;
+		ArgTypes = RttiProcId ^ arg_types
+	),
+	ArgModes = RttiProcId ^ proc_arg_modes,
+	PredOrFunc = RttiProcId ^ pred_or_func,
+	CodeModel = RttiProcId ^ proc_interface_code_model,
 	HeadVarNames = list__map((func(Var - Name) = Result :-
 			term__var_to_int(Var, N),
 			Result = mlds__var_name(Name, yes(N))
@@ -1174,6 +1179,18 @@
 		error("ml_gen_params: missing ml_gen_info")
 	).
 
+	% If the predicate is a special pred which operates on a type defined
+	% as an equivalence type then the actual arg types of the special
+	% pred are those with all the equivalence types expanded.
+:- func get_actual_arg_types(module_info, pred_info) = list(prog_data__type).
+
+get_actual_arg_types(ModuleInfo, PredInfo) = ArgTypes :-
+	( is_special_pred(ModuleInfo, PredInfo, ArgTypes0) ->
+		ArgTypes = ArgTypes0
+	;
+		pred_info_arg_types(PredInfo, ArgTypes)
+	).
+
 :- pred ml_gen_params_base(module_info, list(mlds__var_name), list(prog_type),
 		list(arg_mode), pred_or_func, code_model, mlds__func_params,
 		maybe(ml_gen_info), maybe(ml_gen_info)).
@@ -1440,7 +1457,7 @@
 		IsImported, _IsPseudoImported, _IsExported,
 		IsSpecialPredInstance),
 	(
-		IsSpecialPredInstance = yes
+		IsSpecialPredInstance = yes(_)
 	->
 		(
 			special_pred_get_type(PredName, ArgTypes, Type),
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.22
diff -u -r1.22 rtti.m
--- compiler/rtti.m	1 Nov 2002 09:56:54 -0000	1.22
+++ compiler/rtti.m	7 Nov 2002 11:34:17 -0000
@@ -435,11 +435,15 @@
 			% so that we can continue to use the above-mentioned
 			% abstract interfaces rather than hard-coding tests
 			% on the import_status.
+			% Note that for is_special_pred_instance we also
+			% record the arg_types where all the equivalence
+			% types in the args have been expanded out.
 			%
 			is_imported			::	bool,
 			is_pseudo_imported		::	bool,
 			is_exported			::	bool,
-			is_special_pred_instance	::	bool
+			is_special_pred_instance	::	maybe(
+								  list(type))
 		).
 
 %-----------------------------------------------------------------------------%
@@ -617,7 +621,7 @@
 :- implementation.
 
 :- import_module parse_tree__prog_util.	% for mercury_public_builtin_module
-:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_data, hlds__special_pred.
 :- import_module check_hlds__type_util, check_hlds__mode_util.
 :- import_module ll_backend__code_util.	% for code_util__compiler_generated
 :- import_module ll_backend__llds_out.	% for name_mangle and sym_name_mangle
@@ -732,7 +736,11 @@
 	IsPseudoImp = (pred_info_is_pseudo_imported(PredInfo) -> yes ; no),
 	IsExported = (procedure_is_exported(PredInfo, ProcId) -> yes ; no),
 	IsSpecialPredInstance =
-		(code_util__compiler_generated(PredInfo) -> yes ; no),
+		( is_special_pred(ModuleInfo, PredInfo, NewArgs) ->
+			yes(NewArgs)
+		;
+			no
+		),
 	ProcHeadVarsWithNames = list__map((func(Var) = Var - Name :-
 			Name = varset__lookup_name(ProcVarSet, Var)
 		), ProcHeadVars),
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.33
diff -u -r1.33 special_pred.m
--- compiler/special_pred.m	30 Jun 2002 17:06:40 -0000	1.33
+++ compiler/special_pred.m	7 Nov 2002 11:34:17 -0000
@@ -103,6 +103,12 @@
 :- pred can_generate_special_pred_clauses_for_type(type_ctor, hlds_type_body).
 :- mode can_generate_special_pred_clauses_for_type(in, in) is semidet.
 
+	% is_special_pred(M, P, Ts) is true iff P is a special pred
+	% and Ts are the arg_types for the special pred with all the
+	% equivalence types expanded.
+:- pred is_special_pred(module_info::in,
+		pred_info::in, list(type)::out) is semidet.
+
 :- implementation.
 
 :- import_module parse_tree__prog_util.
@@ -223,4 +229,18 @@
 	Body \= abstract_type,
 	\+ type_ctor_has_hand_defined_rtti(TypeCtor).
 
+%-----------------------------------------------------------------------------%
+
+is_special_pred(ModuleInfo, PredInfo, ExpandedArgTypes) :-
+	pred_info_name(PredInfo, PredName),
+	pred_info_arity(PredInfo, PredArity),
+	special_pred_name_arity(SpecialPredType, _, PredName, PredArity),
+
+	pred_info_arg_types(PredInfo, ArgTypes),
+	special_pred_get_type(PredName, ArgTypes, Type),
+	module_info_types(ModuleInfo, TypeTable),
+	ExpandedType = expand_equivalence_type(TypeTable, Type),
+	special_pred_info(SpecialPredType, ExpandedType,
+			_, ExpandedArgTypes, _, _).
+	
 %-----------------------------------------------------------------------------%
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.109
diff -u -r1.109 type_util.m
--- compiler/type_util.m	1 Nov 2002 07:06:59 -0000	1.109
+++ compiler/type_util.m	7 Nov 2002 11:34:18 -0000
@@ -468,6 +468,9 @@
 :- pred get_unconstrained_tvars(list(tvar), list(class_constraint), list(tvar)).
 :- mode get_unconstrained_tvars(in, in, out) is det.
 
+	% Expand an equivalence type into its base representation.
+:- func expand_equivalence_type(type_table, (type)) = (type).
+
 %-----------------------------------------------------------------------------%
 
 	% If possible, get the argument types for the cons_id.
@@ -489,6 +492,7 @@
 
 :- import_module parse_tree__prog_io, parse_tree__prog_io_goal.
 :- import_module parse_tree__prog_util, libs__options, libs__globals.
+:- import_module hlds__error_util.
 :- import_module bool, char, int, string.
 :- import_module assoc_list, require, varset.
 
@@ -1740,5 +1744,29 @@
 	;
 		list__duplicate(Arity, no, MaybeTypes)
 	).
+
+%-----------------------------------------------------------------------------%
+
+expand_equivalence_type(TypeTable, Type0) = Type :-
+	( type_to_ctor_and_args(Type0, TypeCtor, _) ->
+		( map__search(TypeTable, TypeCtor, TypeDefn) ->
+			hlds_data__get_type_defn_body(TypeDefn, TypeBody),
+			( TypeBody = eqv_type(EqvType) ->
+				Type = expand_equivalence_type(
+						TypeTable, EqvType)
+			;
+				Type = Type0
+			)
+		;
+			Type = Type0
+		)
+	;
+		unexpected(this_file, "type_to_ctor_and_args failed")
+	).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "type_util.m".
 
 %-----------------------------------------------------------------------------%
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.325
diff -u -r1.325 typecheck.m
--- compiler/typecheck.m	25 Sep 2002 06:49:13 -0000	1.325
+++ compiler/typecheck.m	7 Nov 2002 11:34:20 -0000
@@ -791,6 +791,8 @@
 	pred_info_arg_types(PredInfo, ArgTypes),
 	special_pred_get_type(PredName, ArgTypes, Type),
 	type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
+	classify_type_ctor(ModuleInfo, TypeCtor, BuiltinType),
+	BuiltinType = user_type,
 	module_info_types(ModuleInfo, TypeTable),
 	map__lookup(TypeTable, TypeCtor, TypeDefn),
 	hlds_data__get_type_defn_body(TypeDefn, Body),

--------------------------------------------------------------------------
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
--------------------------------------------------------------------------