[m-rev.] diff: fix higher_order.m bug

[Simon Taylor]

Estimated hours taken: 5
Branches: main, release

Fix a bug reported by Zoltan where higher_order.m was
generating code containing references to undefined
type-info variables.

compiler/higher_order.m:
	Specialize all calls as if the procedure interface
	requires type-info liveness. The type-infos may
	be needed when specializing calls in the body of
	the specialized procedure to procedures whose
	interface requires type-info liveness.

tests/valid/Mmakefile:
tests/valid/higher_order5.m:
	Test case.

Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.105
diff -u -u -r1.105 higher_order.m
--- compiler/higher_order.m	18 Mar 2003 02:43:36 -0000	1.105
+++ compiler/higher_order.m	17 May 2003 01:57:14 -0000
@@ -1453,13 +1453,8 @@
 	% specialization code is expecting to come from the curried
 	% arguments of the higher-order arguments will not be present
 	% in the specialized argument list.
-	module_info_pred_info(ModuleInfo, CalledPred, CalledPredInfo),
-	module_info_globals(ModuleInfo, Globals),
-	proc_interface_should_use_typeinfo_liveness(CalledPredInfo,
-		CalledProc, Globals, TypeInfoLiveness),
 	get_extra_arguments(HigherOrderArgs, Args0, Args),
-	compute_extra_typeinfos(TypeInfoLiveness,
-		Info, Args, ExtraTypeInfoTVars),
+	compute_extra_typeinfos(Info, Args, ExtraTypeInfoTVars),
 
 	proc_info_vartypes(ProcInfo, VarTypes),
 	map__apply_to_list(Args0, VarTypes, CallArgTypes),
@@ -1467,7 +1462,7 @@
 
 	Request = request(Caller, proc(CalledPred, CalledProc), Args0,
 		ExtraTypeInfoTVars, HigherOrderArgs, CallArgTypes,
-		TypeInfoLiveness, TVarSet, IsUserSpecProc, Context),
+		yes, TVarSet, IsUserSpecProc, Context),
 
 	% Check to see if any of the specialized
 	% versions of the called pred apply here.
@@ -1520,40 +1515,38 @@
 		Result = no_request
 	).
 
-	% If `--typeinfo-liveness' is set, specializing type `T' to `list(U)'
-	% requires passing in the type-info for `U'. This predicate
-	% works out which extra variables to pass in given the argument
-	% list for the call.
-:- pred compute_extra_typeinfos(bool::in, higher_order_info::in,
+	% Specializing type `T' to `list(U)' requires passing in the
+	% type-info for `U'. This predicate works out which extra
+	% variables to pass in given the argument list for the call.
+	% This needs to be done even if --typeinfo-liveness is not
+	% set because the type-infos may be needed when specializing
+	% calls inside the specialized version.
+:- pred compute_extra_typeinfos(higher_order_info::in,
 		list(prog_var)::in, list(tvar)::out) is det.
 
-compute_extra_typeinfos(TypeInfoLiveness, Info, Args1, ExtraTypeInfoTVars) :-
-	( TypeInfoLiveness = yes ->
-		% Work out which type variables don't already have type-infos
-		% in the list of argument types.
-		% The list is in the order which the type variables occur
-		% in the list of argument types so that the extra type-info
-		% arguments for calls to imported user-guided type
-		% specialization procedures can be matched against the
-		% specialized version (`goal_util__extra_nonlocal_typeinfos'
-		% is not used here because the type variables are returned
-		% sorted by variable number, which will vary between calls).
-		ProcInfo = Info ^ proc_info,
-		proc_info_vartypes(ProcInfo, VarTypes),
-		map__apply_to_list(Args1, VarTypes, ArgTypes),
-		term__vars_list(ArgTypes, AllTVars),
-		( AllTVars = [] ->
-			ExtraTypeInfoTVars = []
-		;
-			list__foldl(arg_type_contains_type_info_for_tvar,
-				ArgTypes, [], TypeInfoTVars),
-			list__delete_elems(AllTVars, TypeInfoTVars,
-				ExtraTypeInfoTVars0),
-			list__remove_dups(ExtraTypeInfoTVars0,
-				ExtraTypeInfoTVars)
-		)
-	;
+compute_extra_typeinfos(Info, Args1, ExtraTypeInfoTVars) :-
+	% Work out which type variables don't already have type-infos
+	% in the list of argument types.
+	% The list is in the order which the type variables occur
+	% in the list of argument types so that the extra type-info
+	% arguments for calls to imported user-guided type
+	% specialization procedures can be matched against the
+	% specialized version (`goal_util__extra_nonlocal_typeinfos'
+	% is not used here because the type variables are returned
+	% sorted by variable number, which will vary between calls).
+	ProcInfo = Info ^ proc_info,
+	proc_info_vartypes(ProcInfo, VarTypes),
+	map__apply_to_list(Args1, VarTypes, ArgTypes),
+	term__vars_list(ArgTypes, AllTVars),
+	( AllTVars = [] ->
 		ExtraTypeInfoTVars = []
+	;
+		list__foldl(arg_type_contains_type_info_for_tvar,
+			ArgTypes, [], TypeInfoTVars),
+		list__delete_elems(AllTVars, TypeInfoTVars,
+			ExtraTypeInfoTVars0),
+		list__remove_dups(ExtraTypeInfoTVars0,
+			ExtraTypeInfoTVars)
 	).
 
 :- pred arg_type_contains_type_info_for_tvar((type)::in, list(tvar)::in,
@@ -1672,9 +1665,17 @@
 		% specialization.
 		MatchIsPartial = no
 	;
-		Params ^ type_spec = no
-	;
-		pred_info_is_imported(CalleePredInfo)
+		MatchIsPartial = yes,
+		pred_info_get_markers(CalleePredInfo, Markers),
+
+		% Always fully specialize calls to class methods.
+		\+ check_marker(Markers, class_method),
+		\+ check_marker(Markers, class_instance_method),
+		(
+			Params ^ type_spec = no
+		;
+			pred_info_is_imported(CalleePredInfo)
+		)
 	),
 
 	% Rename apart type variables.
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.128
diff -u -u -r1.128 Mmakefile
--- tests/valid/Mmakefile	13 May 2003 06:25:55 -0000	1.128
+++ tests/valid/Mmakefile	16 May 2003 13:26:55 -0000
@@ -85,6 +85,7 @@
 	higher_order2 \
 	higher_order3 \
 	higher_order4 \
+	higher_order5 \
 	higher_order_implied_mode \
 	ho_func_call \
 	ho_inst \
Index: tests/valid/higher_order5.m
===================================================================
RCS file: tests/valid/higher_order5.m
diff -N tests/valid/higher_order5.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/valid/higher_order5.m	16 May 2003 13:26:22 -0000
@@ -0,0 +1,59 @@
+:- module higher_order5.
+
+:- interface.
+
+:- pred definite_vars(robdd(T)::in, vars_entailed_result(T)::out,
+		vars_entailed_result(T)::out) is det.
+
+:- type robdd(T).
+
+:- type entailment_result(T)
+	--->	all_vars
+	;	some_vars(vars :: T).
+
+:- type vars_entailed_result(T) == entailment_result(sparse_bitset(T)).
+
+:- type pair(T, U) ---> pair(T, U).
+
+:- type sparse_bitset(T) ---> sparse_bitset(T).
+
+:- type equivalent_vars_map(T) ---> equivalent_vars_map(pair(T, T)).
+
+:- type equivalent_result(T) == entailment_result(equivalent_vars_map(T)).
+
+%---------------------------------------------------------------------------%
+:- implementation.
+
+:- type robdd(T) ---> robdd(int).
+
+definite_vars(R, T, F) :-
+	definite_vars(id(R), T_tr, F_tr),
+	T = T_tr `intersection` T_tr,
+	F = F_tr `intersection` F_tr.
+
+:- func id(T) = T.
+id(T) = T.
+
+:- type imp_res_2(T) ---> imps(pair(T, vars_entailed_result(T))).
+
+:- typeclass intersectable(T) where [
+	func T `intersection` T = T
+].
+
+:- instance intersectable(sparse_bitset(T)) where [
+	intersection(sparse_bitset(A), _) = sparse_bitset(A)
+].
+
+:- instance intersectable(entailment_result(T)) <= intersectable(T) where [
+	( all_vars `intersection` R = R ),
+	( some_vars(Vs) `intersection` all_vars = some_vars(Vs) ),
+	( some_vars(Vs0) `intersection` some_vars(Vs1) =
+		some_vars(Vs0 `intersection` Vs1) )
+].
+
+:- instance intersectable(imp_res_2(T)) where [
+	imps(pair(A, ResA)) `intersection` imps(pair(_, ResB)) =
+		imps(pair(A, intersection(ResA, ResB)))
+].
+
+%------------------------------------------------------------------------%
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------