[m-dev.] diff: fix bugs in type specialization

Simon Taylor stayl at cs.mu.OZ.AU
Fri Sep 1 22:48:49 AEDT 2000



Estimated hours taken: 4

Fix type specialization of calls to class methods for which
the instance declaration has unconstrained type variables.
Fix bugs in the specialization of existentially quantified
procedures.

compiler/higher_order.m:
	Extract the type_infos for the unconstrained type variables
	from the typeclass_info and pass them to the call.

	Only pass the universally quantified type parameters, not
	the head_type_params, when working out type substitutions
	for specialized versions of predicates, since the existentially
	quantified type variables can be bound by the substitution.

compiler/polymorphism.m:
	Make sure that the types of the type_infos for existentially
	quantified types match the types of the variables they describe.
	We were getting this right for the types returned by
	pred_info_arg_types, but the types in the vartypes fields
	of the clauses_infos and proc_infos weren't bound enough.
	As a result, polymorphism was producing unifications such as
	`TypeInfo_for_T : type_info(T) =
		TypeInfo_for_string : type_info(string)'.
	This is likely to cause problems for optimization passes.

tests/hard_coded/typeclasses/Mmakefile:
	Remove `--no-user-guided-type-specialization' flags which
	were used to work around these bugs.

tests/hard_coded/typeclasses/instance_unconstrained_tvar_type_spec.m:
tests/hard_coded/typeclasses/instance_unconstrained_tvar_type_spec.exp:
	Test case.



Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.68
diff -u -u -r1.68 higher_order.m
--- compiler/higher_order.m	2000/08/10 05:10:54	1.68
+++ compiler/higher_order.m	2000/09/01 10:55:13
@@ -292,8 +292,7 @@
 		Sizes, Sizes, ModuleInfo, ModuleInfo).
 get_specialization_requests(Params, [PredId | PredIds], NewPreds, Requests0,
 		Requests, GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo) :-
-	module_info_preds(ModuleInfo0, Preds0),
-	map__lookup(Preds0, PredId, PredInfo0),
+	module_info_pred_info(ModuleInfo0, PredId, PredInfo0),
 	pred_info_non_imported_procids(PredInfo0, NonImportedProcs),
 	(
 		NonImportedProcs = [],
@@ -320,8 +319,8 @@
 			ModuleInfo1, ModuleInfo2, PredInfo1, PredInfo2,
 			NewPreds, Requests1, Requests2, Procs1, Procs),
 		pred_info_set_procedures(PredInfo2, Procs, PredInfo),
-		map__det_update(Preds0, PredId, PredInfo, Preds),
-		module_info_set_preds(ModuleInfo2, Preds, ModuleInfo3)
+		module_info_set_pred_info(ModuleInfo2,
+			PredId, PredInfo, ModuleInfo3)
 	),
 	get_specialization_requests(Params, PredIds, NewPreds,
 		Requests2, Requests, GoalSizes1, GoalSizes,
@@ -739,10 +738,14 @@
 			map__lookup(Instances, ClassId, InstanceList),
 			list__index1_det(InstanceList, Instance, InstanceDefn),
 			InstanceDefn = hlds_instance_defn(_, _,
-				InstanceConstraints, _, _,
+				InstanceConstraints, InstanceTypes0, _,
 				yes(ClassInterface), _, _),
-			list__length(InstanceConstraints, InstanceArity),
-			list__take(InstanceArity, OtherTypeClassArgs,
+			term__vars_list(InstanceTypes0, InstanceTvars),
+			get_unconstrained_tvars(InstanceTvars,
+				InstanceConstraints, UnconstrainedTVars),
+			NumArgsToExtract = list__length(InstanceConstraints)
+					+ list__length(UnconstrainedTVars),
+			list__take(NumArgsToExtract, OtherTypeClassArgs,
 				InstanceConstraintArgs)
 		->
 			list__index1_det(ClassInterface, Method,
@@ -782,37 +785,31 @@
 		pred_info_typevarset(CallerPredInfo0, TVarSet0),
 		find_matching_instance_method(Instances, Method,
 			ClassArgs, PredId, ProcId, InstanceConstraints,
-			TVarSet0, TVarSet)
+			UnconstrainedTVarTypes, TVarSet0, TVarSet)
 	->
 		pred_info_set_typevarset(CallerPredInfo0,
 			TVarSet, CallerPredInfo),
 		% Pull out the argument typeclass_infos.
-		( InstanceConstraints = [] ->
+		( InstanceConstraints = [], UnconstrainedTVarTypes = [] ->
 			ExtraGoals = [],
 			CallerProcInfo = CallerProcInfo0,
 			AllArgs = Args
 		;
-			mercury_private_builtin_module(PrivateBuiltin),
-			module_info_get_predicate_table(ModuleInfo, PredTable),
-			ExtractArgSymName = qualified(PrivateBuiltin,
-				"instance_constraint_from_typeclass_info"),
-			(
-				predicate_table_search_pred_sym_arity(
-					PredTable, ExtractArgSymName,
-					3, [ExtractArgPredId0])
-			->
-				ExtractArgPredId = ExtractArgPredId0
-			;
-				error(
-	"higher_order.m: can't find `instance_constraint_from_typeclass_info'")
-			),
-			hlds_pred__initial_proc_id(ExtractArgProcId),
-			get_arg_typeclass_infos(PredVar, ExtractArgPredId,
-				ExtractArgProcId, ExtractArgSymName,
-				InstanceConstraints, 1,
-				ExtraGoals, ArgTypeClassInfos,
-				CallerProcInfo0, CallerProcInfo),
-			list__append(ArgTypeClassInfos, Args, AllArgs)
+			get_unconstrained_instance_type_infos(ModuleInfo,
+				PredVar, UnconstrainedTVarTypes, 1,
+				ArgTypeInfoGoals, ArgTypeInfoVars,
+				CallerProcInfo0, CallerProcInfo1),
+			FirstArgTypeclassInfo =
+				list__length(UnconstrainedTVarTypes) + 1,
+			get_arg_typeclass_infos(ModuleInfo, PredVar, 
+				InstanceConstraints, FirstArgTypeclassInfo,
+				ArgTypeClassInfoGoals, ArgTypeClassInfoVars,
+				CallerProcInfo1, CallerProcInfo),
+			list__condense(
+				[ArgTypeInfoVars, ArgTypeClassInfoVars, Args],
+				AllArgs),
+			list__append(ArgTypeInfoGoals,
+				ArgTypeClassInfoGoals, ExtraGoals)
 		),
 		Info1 = info(PredVars, Requests0, NewPreds, PredProcId,
 			CallerPredInfo, CallerProcInfo, ModuleInfo,
@@ -828,16 +825,20 @@
 
 :- pred find_matching_instance_method(list(hlds_instance_defn)::in, int::in,
 	list(type)::in, pred_id::out, proc_id::out,
-	list(class_constraint)::out, tvarset::in, tvarset::out) is semidet.
+	list(class_constraint)::out, list(type)::out,
+	tvarset::in, tvarset::out) is semidet.
 
 find_matching_instance_method([Instance | Instances], MethodNum,
-		ClassTypes, PredId, ProcId, Constraints, TVarSet0, TVarSet) :-
+		ClassTypes, PredId, ProcId, Constraints,
+		UnconstrainedTVarTypes, TVarSet0, TVarSet) :-
         (
 		instance_matches(ClassTypes, Instance,
-			Constraints0, TVarSet0, TVarSet1)
+			Constraints0, UnconstrainedTVarTypes0,
+			TVarSet0, TVarSet1)
 	->
 		TVarSet = TVarSet1,
 		Constraints = Constraints0,
+		UnconstrainedTVarTypes = UnconstrainedTVarTypes0,
 		Instance = hlds_instance_defn(_, _, _,
 			_, _, yes(ClassInterface), _, _),
 		list__index1_det(ClassInterface, MethodNum,
@@ -845,60 +846,129 @@
 	;
 		find_matching_instance_method(Instances, MethodNum,
 			ClassTypes, PredId, ProcId, Constraints,
-			TVarSet0, TVarSet)
+			UnconstrainedTVarTypes, TVarSet0, TVarSet)
 	).
 
 :- pred instance_matches(list(type)::in, hlds_instance_defn::in,
-	list(class_constraint)::out, tvarset::in, tvarset::out) is semidet.
+	list(class_constraint)::out, list(type)::out,
+	tvarset::in, tvarset::out) is semidet.
 
-instance_matches(ClassTypes, Instance, Constraints, TVarSet0, TVarSet) :-
+instance_matches(ClassTypes, Instance, Constraints, UnconstrainedTVarTypes,
+		TVarSet0, TVarSet) :-
 	Instance = hlds_instance_defn(_, _, Constraints0,
 		InstanceTypes0, _, _, InstanceTVarSet, _),
 	varset__merge_subst(TVarSet0, InstanceTVarSet, TVarSet,
 		RenameSubst),
 	term__apply_substitution_to_list(InstanceTypes0,
 		RenameSubst, InstanceTypes),
-	type_list_subsumes(InstanceTypes, ClassTypes, Subst),
 	apply_subst_to_constraint_list(RenameSubst,
 		Constraints0, Constraints1),
+	term__vars_list(InstanceTypes, InstanceTVars),
+	get_unconstrained_tvars(InstanceTVars, Constraints1,
+		UnconstrainedTVars0),
+
+	type_list_subsumes(InstanceTypes, ClassTypes, Subst),
 	apply_rec_subst_to_constraint_list(Subst,
-		Constraints1, Constraints).
+		Constraints1, Constraints),
+
+	term__var_list_to_term_list(UnconstrainedTVars0,
+		UnconstrainedTVarTypes0),
+	term__apply_rec_substitution_to_list(UnconstrainedTVarTypes0,
+		Subst, UnconstrainedTVarTypes).
 
 	% Build calls to
 	% `private_builtin:instance_constraint_from_typeclass_info/3'
 	% to extract the typeclass_infos for the constraints on an instance.
 	% This simulates the action of `do_call_class_method' in
 	% runtime/mercury_ho_call.c.
-:- pred get_arg_typeclass_infos(prog_var::in, pred_id::in, proc_id::in,
-		sym_name::in, list(class_constraint)::in, int::in,
-		list(hlds_goal)::out, list(prog_var)::out,
-		proc_info::in, proc_info::out) is det.
+:- pred get_arg_typeclass_infos(module_info::in, prog_var::in,
+		list(class_constraint)::in, int::in, list(hlds_goal)::out,
+		list(prog_var)::out, proc_info::in, proc_info::out) is det.
+
+get_arg_typeclass_infos(ModuleInfo, TypeClassInfoVar,
+		InstanceConstraints, Index, Goals, Vars,
+		ProcInfo0, ProcInfo) :-
+
+	MakeResultType = polymorphism__build_typeclass_info_type,
+	get_typeclass_info_args(ModuleInfo, TypeClassInfoVar,
+		"instance_constraint_from_typeclass_info", MakeResultType,
+		InstanceConstraints, Index, Goals, Vars, ProcInfo0, ProcInfo).
 
-get_arg_typeclass_infos(_, _, _, _, [], _, [], [], ProcInfo, ProcInfo).
-get_arg_typeclass_infos(TypeClassInfoVar, PredId, ProcId, SymName,
-		[InstanceConstraint | InstanceConstraints],
-		ConstraintNum, [ConstraintNumGoal, CallGoal | Goals],
-		[ArgTypeClassInfoVar | Vars], ProcInfo0, ProcInfo) :-
-	polymorphism__build_typeclass_info_type(InstanceConstraint,
-		ArgTypeClassInfoType),
-	proc_info_create_var_from_type(ProcInfo0, ArgTypeClassInfoType,
-		ArgTypeClassInfoVar, ProcInfo1),
+	% Build calls to
+	% `private_builtin:unconstrained_type_info_from_typeclass_info/3'
+	% to extract the type-infos for the unconstrained type variables
+	% of an instance declaration.
+	% This simulates the action of `do_call_class_method' in
+	% runtime/mercury_ho_call.c.
+:- pred get_unconstrained_instance_type_infos(module_info::in,
+		prog_var::in, list(type)::in, int::in, list(hlds_goal)::out,
+		list(prog_var)::out, proc_info::in, proc_info::out) is det.
+
+get_unconstrained_instance_type_infos(ModuleInfo, TypeClassInfoVar,
+		UnconstrainedTVarTypes, Index, Goals, Vars,
+		ProcInfo0, ProcInfo) :-
+	MakeResultType = polymorphism__build_type_info_type,
+	get_typeclass_info_args(ModuleInfo, TypeClassInfoVar,
+		"unconstrained_type_info_from_typeclass_info",
+		MakeResultType, UnconstrainedTVarTypes,
+		Index, Goals, Vars, ProcInfo0, ProcInfo).
+
+:- pred get_typeclass_info_args(module_info::in, prog_var::in, string::in,
+		pred(T, type)::(pred(in, out) is det),
+		list(T)::in, int::in, list(hlds_goal)::out,
+		list(prog_var)::out, proc_info::in, proc_info::out) is det.
+
+get_typeclass_info_args(ModuleInfo, TypeClassInfoVar, PredName, MakeResultType,
+		Args, Index, Goals, Vars, ProcInfo0, ProcInfo) :-
+	mercury_private_builtin_module(PrivateBuiltin),
+	SymName = qualified(PrivateBuiltin, PredName),
+	module_info_get_predicate_table(ModuleInfo, PredTable),
+	(
+		predicate_table_search_pred_sym_arity(PredTable,
+			SymName, 3, [ExtractArgPredId0])
+	->
+		ExtractArgPredId = ExtractArgPredId0
+	;
+		string__append("higher_order.m: can't find private_builtin__",
+			PredName, Msg),
+		error(Msg)
+	),
+	hlds_pred__initial_proc_id(ExtractArgProcId),
+	get_typeclass_info_args_2(TypeClassInfoVar, ExtractArgPredId,
+		ExtractArgProcId, SymName, MakeResultType,
+		Args, Index, Goals, Vars, ProcInfo0, ProcInfo).
+
+:- pred get_typeclass_info_args_2(prog_var::in, pred_id::in, proc_id::in,
+		sym_name::in, pred(T, type)::(pred(in, out) is det),
+		list(T)::in, int::in, list(hlds_goal)::out,
+		list(prog_var)::out, proc_info::in, proc_info::out) is det.
+
+get_typeclass_info_args_2(_, _, _, _, _, [], _, [], [], ProcInfo, ProcInfo).
+get_typeclass_info_args_2(TypeClassInfoVar, PredId, ProcId, SymName,
+		MakeResultType, [Arg | Args], Index,
+		[IndexGoal, CallGoal | Goals],
+		[ResultVar | Vars], ProcInfo0, ProcInfo) :-
+	MakeResultType(Arg, ResultType),
+	proc_info_create_var_from_type(ProcInfo0, ResultType,
+		ResultVar, ProcInfo1),
 	MaybeContext = no,
-	make_int_const_construction(ConstraintNum, ConstraintNumGoal,
-		ConstraintNumVar, ProcInfo1, ProcInfo2),
-	Args = [TypeClassInfoVar, ConstraintNumVar, ArgTypeClassInfoVar],
+	make_int_const_construction(Index, IndexGoal,
+		IndexVar, ProcInfo1, ProcInfo2),
+	CallArgs = [TypeClassInfoVar, IndexVar, ResultVar],
 
-	set__list_to_set(Args, NonLocals),
+	set__list_to_set(CallArgs, NonLocals),
 	instmap_delta_init_reachable(InstMapDelta0),
-	instmap_delta_insert(InstMapDelta0, ArgTypeClassInfoVar,
+	instmap_delta_insert(InstMapDelta0, ResultVar,
 		ground(shared, no), InstMapDelta),
 	goal_info_init(NonLocals, InstMapDelta, det, GoalInfo),
-	CallGoal = call(PredId, ProcId, Args, not_builtin,
+	CallGoal = call(PredId, ProcId, CallArgs, not_builtin,
 		MaybeContext, SymName) - GoalInfo,
-	get_arg_typeclass_infos(TypeClassInfoVar, PredId, ProcId, SymName,
-		InstanceConstraints, ConstraintNum + 1, Goals,
-		Vars, ProcInfo2, ProcInfo).
+	get_typeclass_info_args_2(TypeClassInfoVar, PredId, ProcId, SymName,
+		MakeResultType, Args, Index + 1, Goals, Vars,
+		ProcInfo2, ProcInfo).
 
+%-----------------------------------------------------------------------------%
+
 :- pred construct_specialized_higher_order_call(module_info::in,
 	pred_id::in, proc_id::in, list(prog_var)::in, hlds_goal_info::in,
 	hlds_goal::out, higher_order_info::in, higher_order_info::out) is det.
@@ -931,7 +1001,8 @@
 	;
 		error("higher_order.m: call expected")
 	),
-	module_info_pred_info(Module0, CalledPred, CalleePredInfo),
+	module_info_pred_proc_info(Module0, CalledPred, CalledProc,
+		CalleePredInfo, CalleeProcInfo),
 	module_info_globals(Module0, Globals),
 	globals__lookup_bool_option(Globals, special_preds, HaveSpecialPreds),
 	(
@@ -966,8 +1037,12 @@
 		Info = Info0,
 		Goal = Goal0
 	;
-		pred_info_arg_types(CalleePredInfo, CalleeArgTypes),
 		pred_info_import_status(CalleePredInfo, CalleeStatus),
+		proc_info_vartypes(CalleeProcInfo, CalleeVarTypes),
+		proc_info_headvars(CalleeProcInfo, CalleeHeadVars),
+		map__apply_to_list(CalleeHeadVars,
+			CalleeVarTypes, CalleeArgTypes),
+
 		proc_info_vartypes(ProcInfo0, VarTypes),
 		find_higher_order_args(Module0, CalleeStatus, Args0,
 			CalleeArgTypes, VarTypes, PredVars, 1, [],
@@ -1006,9 +1081,12 @@
 				pred_info_get_exist_quant_tvars(CalleePredInfo,
 					CalleeExistQTVars),
 				pred_info_typevarset(PredInfo0, TVarSet),
+				pred_info_get_univ_quant_tvars(PredInfo0,
+					CallerUnivQTVars),
 				type_subst_makes_instance_known(
 					Module0, CalleeUnivConstraints0,
-					TVarSet, ArgTypes, CalleeTVarSet,
+					TVarSet, CallerUnivQTVars,
+					ArgTypes, CalleeTVarSet,
 					CalleeExistQTVars, CalleeArgTypes)
 			)
 		->
@@ -1133,11 +1211,13 @@
 	% the class constraints match an instance which was not matched
 	% before.
 :- pred type_subst_makes_instance_known(module_info::in,
-		list(class_constraint)::in, tvarset::in, list(type)::in,
-		tvarset::in, existq_tvars::in, list(type)::in) is semidet.
+		list(class_constraint)::in, tvarset::in, list(tvar)::in,
+		list(type)::in, tvarset::in, existq_tvars::in,
+		list(type)::in) is semidet.
 
 type_subst_makes_instance_known(ModuleInfo, CalleeUnivConstraints0, TVarSet0,
-		ArgTypes, CalleeTVarSet, CalleeExistQVars, CalleeArgTypes0) :-
+		CallerHeadTypeParams, ArgTypes, CalleeTVarSet,
+		CalleeExistQVars, CalleeArgTypes0) :-
 	CalleeUnivConstraints0 \= [],
 	varset__merge_subst(TVarSet0, CalleeTVarSet,
 		TVarSet, TypeRenaming),
@@ -1145,11 +1225,8 @@
 		CalleeArgTypes1),
 
 	% Substitute the types in the callee's class constraints.
-	% Typechecking has already succeeded, so none of the head type
-	% variables will be bound by the substitution.
-	HeadTypeParams = [],
 	inlining__get_type_substitution(CalleeArgTypes1, ArgTypes,
-		HeadTypeParams, CalleeExistQVars, TypeSubn),
+		CallerHeadTypeParams, CalleeExistQVars, TypeSubn),
 	apply_subst_to_constraint_list(TypeRenaming,
 		CalleeUnivConstraints0, CalleeUnivConstraints1),
 	apply_rec_subst_to_constraint_list(TypeSubn,
@@ -1167,8 +1244,8 @@
 	module_info_instances(ModuleInfo, InstanceTable),
 	map__search(InstanceTable, class_id(ClassName, ClassArity), Instances),
 	list__member(Instance, Instances),
-	instance_matches(ConstraintArgs, Instance, _, TVarSet, _),
-	\+ instance_matches(ConstraintArgs0, Instance, _, TVarSet, _).
+	instance_matches(ConstraintArgs, Instance, _, _, TVarSet, _),
+	\+ instance_matches(ConstraintArgs0, Instance, _, _, TVarSet, _).
 
 :- type find_result
 	--->	match(match)
@@ -2265,14 +2342,14 @@
 
 	proc_info_headvars(NewProcInfo0, HeadVars0),
 	proc_info_argmodes(NewProcInfo0, ArgModes0),
-	pred_info_arg_types(NewPredInfo0, _, ExistQVars0, _),
+	pred_info_get_exist_quant_tvars(NewPredInfo0, ExistQVars0),
 	pred_info_typevarset(NewPredInfo0, TypeVarSet0),
 
 	Caller = proc(CallerPredId, CallerProcId),
 	module_info_pred_proc_info(ModuleInfo, CallerPredId, CallerProcId,
 		CallerPredInfo, CallerProcInfo),
 	pred_info_arg_types(CallerPredInfo, CallerTypeVarSet, _, _),
-	pred_info_get_head_type_params(CallerPredInfo, CallerHeadParams),
+	pred_info_get_univ_quant_tvars(CallerPredInfo, CallerHeadParams),
 	proc_info_typeinfo_varmap(CallerProcInfo, CallerTypeInfoVarMap0),
 
 	%
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.194
diff -u -u -r1.194 polymorphism.m
--- compiler/polymorphism.m	2000/08/24 05:59:28	1.194
+++ compiler/polymorphism.m	2000/09/01 11:39:24
@@ -384,27 +384,69 @@
 	%
 	module_info_preds(ModuleInfo0, PredTable0),
 	map__lookup(PredTable0, PredId, PredInfo0),
-	pred_info_clauses_info(PredInfo0, ClausesInfo),
-	clauses_info_vartypes(ClausesInfo, VarTypes),
-	clauses_info_headvars(ClausesInfo, HeadVars),
+	pred_info_clauses_info(PredInfo0, ClausesInfo0),
+	clauses_info_vartypes(ClausesInfo0, VarTypes0),
+	clauses_info_headvars(ClausesInfo0, HeadVars),
 
 	pred_info_arg_types(PredInfo0, TypeVarSet, ExistQVars, ArgTypes0),
 	list__length(ArgTypes0, NumOldArgs),
 	list__length(HeadVars, NumNewArgs),
 	NumExtraArgs is NumNewArgs - NumOldArgs,
 	(
-		list__split_list(NumExtraArgs, HeadVars, ExtraHeadVars,
-				_OldHeadVars)
+		list__split_list(NumExtraArgs, HeadVars, ExtraHeadVars0,
+				OldHeadVars0)
 	->
-		map__apply_to_list(ExtraHeadVars, VarTypes,
-			ExtraArgTypes),
-		list__append(ExtraArgTypes, ArgTypes0, ArgTypes)
+		ExtraHeadVars = ExtraHeadVars0,
+		OldHeadVars = OldHeadVars0
 	;
 		error("polymorphism.m: list__split_list failed")
 	),
 
+	map__apply_to_list(ExtraHeadVars, VarTypes0, ExtraArgTypes),
+	list__append(ExtraArgTypes, ArgTypes0, ArgTypes),
 	pred_info_set_arg_types(PredInfo0, TypeVarSet, ExistQVars,
-		ArgTypes, PredInfo),
+		ArgTypes, PredInfo1),
+
+	%
+	% If the clauses binds some existentially quantified
+	% type variables, make sure the types of the type-infos
+	% for those type variables in the variable types map
+	% are as specific as possible. The predicate argument
+	% types shouldn't be substituted, because the binding
+	% should not be visible to calling predicates.
+	%
+	(
+		ExistQVars \= [],
+		% This can fail for unification procedures
+		% of equivalence types.
+		map__apply_to_list(OldHeadVars, VarTypes0, OldHeadVarTypes),
+		type_list_subsumes(ArgTypes0, OldHeadVarTypes, Subn),
+		\+ map__is_empty(Subn)
+	->
+		list__foldl(
+			(pred(HeadVar::in, Types0::in, Types::out) is det :-
+				map__lookup(Types0, HeadVar, HeadVarType0),
+				term__apply_rec_substitution(HeadVarType0,
+					Subn, HeadVarType),
+				map__set(Types0, HeadVar, HeadVarType, Types)
+			), ExtraHeadVars, VarTypes0, VarTypes),
+		clauses_info_set_vartypes(ClausesInfo0, VarTypes, ClausesInfo),
+		pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo2),
+
+		% Fix up the var-types in the procedures as well.
+		% It would be better if this were done before copying
+		% clauses to procs, but that's difficult to arrange. 
+		pred_info_procedures(PredInfo2, Procs0),
+		map__map_values(
+			(pred(_::in, ProcInfo0::in, ProcInfo::out) is det :- 
+				proc_info_set_vartypes(ProcInfo0,
+					VarTypes, ProcInfo)
+			), Procs0, Procs),
+		pred_info_set_procedures(PredInfo2, Procs, PredInfo)
+	;				
+		PredInfo = PredInfo1
+	),
+
 	map__det_update(PredTable0, PredId, PredInfo, PredTable),
 	module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo1),
 
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.32
diff -u -u -r1.32 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile	2000/08/24 06:08:20	1.32
+++ tests/hard_coded/typeclasses/Mmakefile	2000/08/31 13:56:13
@@ -25,6 +25,7 @@
 	impure_methods \
 	instance_unconstrained_tvar \
 	instance_unconstrained_tvar_dup \
+	instance_unconstrained_tvar_type_spec \
 	inference_test \
 	inference_test_2 \
 	intermod_typeclass_bug \
@@ -63,13 +64,6 @@
 MCFLAGS-unqualified_method = --intermodule-optimization
 MCFLAGS-unqualified_method2 = --intermodule-optimization
 MCFLAGS-unqualified_method3 = --intermodule-optimization
-
-# XXX Type specialization does not yet work for these test cases.
-NO_TYPE_SPEC_FLAGS = --no-user-guided-type-specialisation \
-				--no-type-specialisation
-MCFLAGS-instance_unconstrained_tvar = $(NO_TYPE_SPEC_FLAGS)
-MCFLAGS-instance_unconstrained_tvar_dup = $(NO_TYPE_SPEC_FLAGS)
-MCFLAGS-typeclass_exist_method_2 = $(NO_TYPE_SPEC_FLAGS)
 
 #-----------------------------------------------------------------------------#
 
Index: tests/hard_coded/typeclasses/instance_unconstrained_tvar_type_spec.exp
===================================================================
RCS file: instance_unconstrained_tvar_type_spec.exp
diff -N instance_unconstrained_tvar_type_spec.exp
--- /dev/null	Fri Sep  1 22:26:20 2000
+++ instance_unconstrained_tvar_type_spec.exp	Fri Sep  1 10:19:24 2000
@@ -0,0 +1 @@
+[1, 2, 3]
Index: tests/hard_coded/typeclasses/instance_unconstrained_tvar_type_spec.m
===================================================================
RCS file: instance_unconstrained_tvar_type_spec.m
diff -N instance_unconstrained_tvar_type_spec.m
--- /dev/null	Fri Sep  1 22:26:20 2000
+++ instance_unconstrained_tvar_type_spec.m	Fri Sep  1 00:31:42 2000
@@ -0,0 +1,30 @@
+:- module instance_unconstrained_tvar_type_spec.
+
+:- interface.
+
+:- import_module io, list.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- typeclass p(T) where [
+        pred m(T, io__state, io__state),
+        mode m(in, di, uo) is det
+].
+
+:- instance p(list(T)) where [
+        pred(m/3) is io__write
+].
+
+:- implementation.
+
+main -->
+        call_m([1, 2, 3]),
+        io__nl.
+
+:- pred call_m(T::in, io__state::di, io__state::uo) is det <= p(T).
+:- pragma type_spec(call_m/3, T = list(U)).
+:- pragma no_inline(call_m/3).
+
+call_m(T) -->
+        m(T).
+
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------



More information about the developers mailing list