[m-rev.] for review: more polymorphism.m improvements

Zoltan Somogyi zs at cs.mu.OZ.AU
Mon Oct 27 15:23:27 AEDT 2003 

For review by Fergus.

Improve the clarity of polymorphism.m further.

compiler/polymorphism.m:
	When a data structure involving type variables has several versions
	which differ in which tvarset those type variables come from (the raw
	tvarset of a called predicate's pred_info, the renamed-apart version
	in which those type variables have been lifted into the caller's
	newly expanded tvarset, and the version in which the type variables
	in the types of the formal parameters been replaced with the actual
	(possibly polymorphic) types from the actual arguments), use a
	mnemonic prefix to distinguish them, not a numerical suffix of
	the kind we use for other kinds of transformations.

	Put the code handling foreign_procs into its own predicate, to
	make debugging easier.

compiler/prog_data.m:
	Add field names to the class_constraints type, for use in
	polymorphism.m.

compiler/type_util.m:
	Add a utility predicate, factoring out repeated code from
	polymorphism.m.

library/varset.m:
	Clarify the documentation of varset__merge_subst.

cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.245
diff -u -b -r1.245 polymorphism.m
--- compiler/polymorphism.m	24 Oct 2003 06:17:46 -0000	1.245
+++ compiler/polymorphism.m	26 Oct 2003 13:43:55 -0000
@@ -533,7 +533,7 @@
 	pred_info_set_clauses_info(ClausesInfo, PredInfo1, PredInfo2),
 
 	%
-	% do a pass over the proc_infos, copying the relevant information
+	% Do a pass over the proc_infos, copying the relevant information
 	% from the clauses_info and the poly_info, and updating all
 	% the argmodes with modes for the extra arguments.
 	%
@@ -570,7 +570,7 @@
 		Clauses0, Clauses, Info1, Info),
 
 	%
-	% set the new values of the fields in clauses_info
+	% Set the new values of the fields in clauses_info.
 	%
 	poly_info_get_varset(Info, VarSet),
 	poly_info_get_var_types(Info, VarTypes),
@@ -593,7 +593,7 @@
 	( pred_info_is_imported(PredInfo0) ->
 		true
 	;
-		!.Clause = clause(ProcIds, Goal0, Lang, Context),
+		Goal0 = !.Clause ^ clause_body,
 		%
 		% process any polymorphic calls inside the goal
 		%
@@ -610,7 +610,7 @@
 		pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
 		polymorphism__fixup_quantification(NewHeadVars, ExistQVars,
 			Goal2, Goal, !Info),
-		!:Clause = clause(ProcIds, Goal, Lang, Context)
+		!:Clause = !.Clause ^ clause_body := Goal
 	).
 
 :- pred polymorphism__process_proc_in_table(pred_info::in, clauses_info::in,
@@ -900,26 +900,26 @@
 		!Info) :-
 	poly_info_get_var_types(!.Info, VarTypes0),
 	pred_info_arg_types(PredInfo, ArgTypes),
-	pred_info_get_class_context(PredInfo, ClassContext),
+	pred_info_get_class_context(PredInfo, PredClassContext),
 
 	%
 	% Figure out the bindings for any existentially quantified
 	% type variables in the head.
 	%
-	ClassContext = constraints(_UnivConstraints, ExistConstraints0),
+	PredExistConstraints = PredClassContext ^ exist_constraints,
 	( map__is_empty(VarTypes0) ->
 		% this can happen for compiler-generated procedures
-		map__init(TypeSubst)
+		map__init(PredToActualTypeSubst)
 	;
 		map__apply_to_list(HeadVars0, VarTypes0, ActualArgTypes),
 		type_list_subsumes(ArgTypes, ActualArgTypes, ArgTypeSubst)
 	->
-		TypeSubst = ArgTypeSubst
+		PredToActualTypeSubst = ArgTypeSubst
 	;
 		% this can happen for unification procedures
 		% of equivalence types
 		% error("polymorphism.m: type_list_subsumes failed")
-		map__init(TypeSubst)
+		map__init(PredToActualTypeSubst)
 	),
 
 	%
@@ -929,16 +929,15 @@
 	ExistQVarsForCall = [],
 	Goal0 = _ - GoalInfo,
 	goal_info_get_context(GoalInfo, Context),
-	apply_rec_subst_to_constraint_list(TypeSubst, ExistConstraints0,
-		ExistConstraints),
-	polymorphism__make_typeclass_info_vars(ExistConstraints,
+	apply_rec_subst_to_constraint_list(PredToActualTypeSubst,
+		PredExistConstraints, ActualExistConstraints),
+	polymorphism__make_typeclass_info_vars(ActualExistConstraints,
 		ExistQVarsForCall, Context, ExistTypeClassVars,
 		ExtraTypeClassGoals, !Info),
-	polymorphism__update_typeclass_infos(ExistConstraints,
+	polymorphism__update_typeclass_infos(ActualExistConstraints,
 		ExistTypeClassVars, !Info),
-	polymorphism__assign_var_list(
-		ExistTypeClassInfoHeadVars, ExistTypeClassVars,
-		ExtraTypeClassUnifyGoals),
+	polymorphism__assign_var_list(ExistTypeClassInfoHeadVars,
+		ExistTypeClassVars, ExtraTypeClassUnifyGoals),
 
 	%
 	% apply the type bindings to the unconstrained type variables
@@ -948,15 +947,13 @@
 	term__var_list_to_term_list(UnconstrainedTVars,
 		UnconstrainedTVarTerms),
 	term__apply_substitution_to_list(UnconstrainedTVarTerms,
-		TypeSubst, ActualTypes),
+		PredToActualTypeSubst, ActualTypes),
 	polymorphism__make_type_info_vars(ActualTypes, Context,
 		TypeInfoVars, ExtraTypeInfoGoals, !Info),
 	polymorphism__assign_var_list(TypeInfoHeadVars, TypeInfoVars,
 		ExtraTypeInfoUnifyGoals),
-	list__condense([[Goal0],
-		ExtraTypeClassGoals, ExtraTypeClassUnifyGoals,
-		ExtraTypeInfoGoals, ExtraTypeInfoUnifyGoals],
-		GoalList),
+	list__condense([[Goal0], ExtraTypeClassGoals, ExtraTypeClassUnifyGoals,
+		ExtraTypeInfoGoals, ExtraTypeInfoUnifyGoals], GoalList),
 	conj_list_to_goal(GoalList, GoalInfo, Goal).
 
 :- pred polymorphism__assign_var_list(list(prog_var)::in, list(prog_var)::in,
@@ -1001,72 +998,29 @@
 	GoalExpr = generic_call(_, _, _, _),
 	Goal = GoalExpr - GoalInfo.
 
-polymorphism__process_goal_expr(Goal0, GoalInfo, Goal, !Info) :-
-	Goal0 = call(PredId, ProcId, ArgVars0, Builtin, UnifyContext, Name),
-	polymorphism__process_call(PredId, ArgVars0, GoalInfo,
-		ArgVars, _ExtraVars, CallGoalInfo, ExtraGoals, !Info),
-	CallExpr = call(PredId, ProcId, ArgVars, Builtin, UnifyContext, Name),
-	Call = CallExpr - CallGoalInfo,
+polymorphism__process_goal_expr(Goal0, GoalInfo0, Goal, !Info) :-
+	PredId = Goal0 ^ call_pred_id,
+	ArgVars0 = Goal0 ^ call_args,
+	polymorphism__process_call(PredId, ArgVars0, ArgVars,
+		GoalInfo0, GoalInfo, _ExtraVars, ExtraGoals, !Info),
+	CallExpr = Goal0 ^ call_args := ArgVars,
+	Call = CallExpr - GoalInfo,
 	list__append(ExtraGoals, [Call], GoalList),
-	conj_list_to_goal(GoalList, GoalInfo, Goal).
+	conj_list_to_goal(GoalList, GoalInfo0, Goal).
 
-polymorphism__process_goal_expr(Goal0, GoalInfo, Goal, !Info) :-
-	Goal0 = foreign_proc(Attributes, PredId, ProcId,
-		ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode0),
-	polymorphism__process_call(PredId, ArgVars0, GoalInfo,
-		ArgVars, ExtraVars, CallGoalInfo, ExtraGoals, !Info),
-
-	%
-	% insert the type_info vars into the arg-name map,
-	% so that the foreign_proc can refer to the type_info variable
-	% for type T as `TypeInfo_for_T'.
-	%
+polymorphism__process_goal_expr(Goal0, GoalInfo0, Goal, !Info) :-
+	Goal0 = foreign_proc(_, PredId, _, _, _, _, _),
 	poly_info_get_module_info(!.Info, ModuleInfo),
 	module_info_pred_info(ModuleInfo, PredId, PredInfo),
-
 	PredModule = pred_info_module(PredInfo),
 	PredName = pred_info_name(PredInfo),
 	PredArity = pred_info_arity(PredInfo),
 
 	( no_type_info_builtin(PredModule, PredName, PredArity) ->
-		Goal = Goal0 - GoalInfo
-	;
-		list__length(ExtraVars, NumExtraVars),
-		polymorphism__process_foreign_proc(PredInfo, NumExtraVars,
-			PragmaCode0, OrigArgTypes0, OrigArgTypes,
-			ArgInfo0, ArgInfo),
-
-		%
-		% Add the type info arguments to the list of variables
-		% to call for a pragma import.
-		%
-		(
-			PragmaCode0 = import(Name, HandleReturn,
-				Variables0, MaybeContext)
-		->
-			(
-				list__remove_suffix(ArgInfo, ArgInfo0,
-					TypeVarArgInfos)
-			->
-				Variables = type_info_vars(ModuleInfo,
-					TypeVarArgInfos, Variables0)
-			;
-				error("polymorphism__process_goal_expr")
-			),
-			PragmaCode = import(Name, HandleReturn,
-				Variables, MaybeContext)
+		Goal = Goal0 - GoalInfo0
 		;
-			PragmaCode = PragmaCode0
-		),
-
-		%
-		% plug it all back together
-		%
-		CallExpr = foreign_proc(Attributes, PredId, ProcId, ArgVars,
-			ArgInfo, OrigArgTypes, PragmaCode),
-		Call = CallExpr - CallGoalInfo,
-		list__append(ExtraGoals, [Call], GoalList),
-		conj_list_to_goal(GoalList, GoalInfo, Goal)
+		polymorphism__process_foreign_proc(ModuleInfo, PredInfo,
+			Goal0, GoalInfo0, Goal, !Info)
 	).
 
 polymorphism__process_goal_expr(GoalExpr, GoalInfo, Goal, !Info) :-
@@ -1305,7 +1259,7 @@
 
 		% check if variable has a higher-order type
 		type_is_higher_order(TypeOfX, Purity, _PredOrFunc,
-			EvalMethod, PredArgTypes),
+			EvalMethod, CalleeArgTypes),
 		ConsId0 = pred_const(PredId, ProcId, _)
 	->
 		%
@@ -1314,7 +1268,7 @@
 		poly_info_get_varset(!.Info, VarSet0),
 		goal_info_get_context(GoalInfo0, Context),
 		convert_pred_to_lambda_goal(Purity, EvalMethod,
-			X0, PredId, ProcId, ArgVars0, PredArgTypes,
+			X0, PredId, ProcId, ArgVars0, CalleeArgTypes,
 			UnifyContext, GoalInfo0, Context, ModuleInfo0,
 			Functor0, VarSet0, VarSet, VarTypes0, VarTypes),
 		poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
@@ -1482,21 +1436,24 @@
 		ActualArgTypes, ActualRetType, Context,
 		ExtraVars, ExtraGoals, !Info) :-
 
-	CtorDefn = ctor_defn(CtorTypeVarSet, ExistQVars0,
-		ExistentialConstraints0, CtorArgTypes0, CtorRetType0),
+	CtorDefn = ctor_defn(CtorTypeVarSet, CtorExistQVars,
+		CtorExistentialConstraints, CtorArgTypes, CtorRetType),
 
 	%
 	% rename apart the type variables in the constructor definition
 	%
 	poly_info_get_typevarset(!.Info, TypeVarSet0),
-	varset__merge_subst(TypeVarSet0, CtorTypeVarSet, TypeVarSet, Subst),
-	term__var_list_to_term_list(ExistQVars0, ExistQVarTerms0),
-	term__apply_substitution_to_list(ExistQVarTerms0, Subst,
-		ExistQVarsTerms1),
-	apply_subst_to_constraint_list(Subst, ExistentialConstraints0,
-		ExistentialConstraints1),
-	term__apply_substitution_to_list(CtorArgTypes0, Subst, CtorArgTypes1),
-	term__apply_substitution(CtorRetType0, Subst, CtorRetType1),
+	varset__merge_subst(TypeVarSet0, CtorTypeVarSet, TypeVarSet,
+		CtorToParentSubst),
+	term__var_list_to_term_list(CtorExistQVars, CtorExistQVarTerms),
+	term__apply_substitution_to_list(CtorExistQVarTerms, CtorToParentSubst,
+		ParentExistQVarsTerms),
+	apply_subst_to_constraint_list(CtorToParentSubst,
+		CtorExistentialConstraints, ParentExistentialConstraints),
+	term__apply_substitution_to_list(CtorArgTypes, CtorToParentSubst,
+		ParentArgTypes),
+	term__apply_substitution(CtorRetType, CtorToParentSubst,
+		ParentRetType),
 	poly_info_set_typevarset(TypeVarSet, !Info),
 
 	%
@@ -1504,21 +1461,15 @@
 	% argument and return types.
 	% These are the ones that might bind the ExistQVars.
 	%
-	(
-		type_list_subsumes([CtorRetType1 | CtorArgTypes1],
-			[ActualRetType | ActualArgTypes], TypeSubst1)
-	->
-		TypeSubst = TypeSubst1
-	;
-		error("polymorphism__process_existq_unify_functor: " ++
-			"type unification failed")
-	),
+	type_list_subsumes_det([ParentRetType | ParentArgTypes],
+		[ActualRetType | ActualArgTypes], ParentToActualTypeSubst),
 
 	%
 	% Apply those type bindings to the existential type class constraints
 	%
-	apply_rec_subst_to_constraint_list(TypeSubst, ExistentialConstraints1,
-		ExistentialConstraints),
+	apply_rec_subst_to_constraint_list(ParentToActualTypeSubst,
+		ParentExistentialConstraints,
+		ActualExistentialConstraints),
 
 	%
 	% create type_class_info variables for the
@@ -1528,14 +1479,14 @@
 	(
 		IsConstruction = yes,
 		% assume it's a construction
-		polymorphism__make_typeclass_info_vars(ExistentialConstraints,
-			[], Context, ExtraTypeClassVars, ExtraTypeClassGoals,
-			!Info)
+		polymorphism__make_typeclass_info_vars(
+			ActualExistentialConstraints, [], Context,
+			ExtraTypeClassVars, ExtraTypeClassGoals, !Info)
 	;
 		IsConstruction = no,
 		% assume it's a deconstruction
 		polymorphism__make_existq_typeclass_info_vars(
-			ExistentialConstraints, ExtraTypeClassVars,
+			ActualExistentialConstraints, ExtraTypeClassVars,
 			ExtraTypeClassGoals, !Info)
 	),
 
@@ -1544,20 +1495,21 @@
 	% variables, and then apply the type bindings to those type variables
 	% to figure out what types they are bound to.
 	%
-	constraint_list_get_tvars(ExistentialConstraints1,
-		ExistConstrainedTVars),
-	term__var_list_to_term_list(ExistConstrainedTVars,
-		ExistConstrainedTVarTerms),
-	list__delete_elems(ExistQVarsTerms1, ExistConstrainedTVarTerms,
-		UnconstrainedExistQVarTerms),
-	term__apply_rec_substitution_to_list(UnconstrainedExistQVarTerms,
-		TypeSubst, ExistentialTypes),
+	constraint_list_get_tvars(ParentExistentialConstraints,
+		ParentExistConstrainedTVars),
+	term__var_list_to_term_list(ParentExistConstrainedTVars,
+		ParentExistConstrainedTVarTerms),
+	list__delete_elems(ParentExistQVarsTerms,
+		ParentExistConstrainedTVarTerms,
+		ParentUnconstrainedExistQVarTerms),
+	term__apply_rec_substitution_to_list(ParentUnconstrainedExistQVarTerms,
+		ParentToActualTypeSubst, ActualExistentialTypes),
 
 	%
 	% create type_info variables for the _unconstrained_
 	% existentially quantified type variables
 	%
-	polymorphism__make_type_info_vars(ExistentialTypes, Context,
+	polymorphism__make_type_info_vars(ActualExistentialTypes, Context,
 		ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
 
 	%
@@ -1570,13 +1522,60 @@
 
 %-----------------------------------------------------------------------------%
 
-:- pred polymorphism__process_foreign_proc(pred_info::in, int::in,
+:- pred polymorphism__process_foreign_proc(module_info::in, pred_info::in,
+	hlds_goal_expr::in(bound(foreign_proc(ground,ground,ground,ground,
+	ground,ground,ground))), hlds_goal_info::in, hlds_goal::out,
+	poly_info::in, poly_info::out) is det.
+
+polymorphism__process_foreign_proc(ModuleInfo, PredInfo, Goal0, GoalInfo0,
+		Goal, !Info) :-
+	%
+	% insert the type_info vars into the arg-name map,
+	% so that the foreign_proc can refer to the type_info variable
+	% for type T as `TypeInfo_for_T'.
+	%
+	Goal0 = foreign_proc(Attributes, PredId, ProcId,
+		ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode0),
+	polymorphism__process_call(PredId, ArgVars0, ArgVars,
+		GoalInfo0, GoalInfo, ExtraVars, ExtraGoals, !Info),
+	list__length(ExtraVars, NumExtraVars),
+	polymorphism__process_foreign_proc_args(PredInfo, NumExtraVars,
+		PragmaCode0, OrigArgTypes0, OrigArgTypes,
+		ArgInfo0, ArgInfo),
+
+	%
+	% Add the type info arguments to the list of variables
+	% to call for a pragma import.
+	%
+	( PragmaCode0 = import(Name, HandleReturn, Variables0, MaybeContext) ->
+		( list__remove_suffix(ArgInfo, ArgInfo0, TypeVarArgInfos) ->
+			Variables = type_info_vars(ModuleInfo,
+				TypeVarArgInfos, Variables0)
+		;
+			error("polymorphism__process_goal_expr")
+		),
+		PragmaCode = import(Name, HandleReturn,
+			Variables, MaybeContext)
+	;
+		PragmaCode = PragmaCode0
+	),
+
+	%
+	% plug it all back together
+	%
+	CallExpr = foreign_proc(Attributes, PredId, ProcId, ArgVars,
+		ArgInfo, OrigArgTypes, PragmaCode),
+	Call = CallExpr - GoalInfo,
+	list__append(ExtraGoals, [Call], GoalList),
+	conj_list_to_goal(GoalList, GoalInfo0, Goal).
+
+:- pred polymorphism__process_foreign_proc_args(pred_info::in, int::in,
 	pragma_foreign_code_impl::in, list(type)::in, list(type)::out,
 	list(maybe(pair(string, mode)))::in,
 	list(maybe(pair(string, mode)))::out) is det.
 
-polymorphism__process_foreign_proc(PredInfo, NumExtraVars, Impl, OrigArgTypes0,
-		OrigArgTypes, ArgInfo0, ArgInfo) :-
+polymorphism__process_foreign_proc_args(PredInfo, NumExtraVars, Impl,
+		OrigArgTypes0, OrigArgTypes, ArgInfo0, ArgInfo) :-
 	pred_info_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
 		PredArgTypes),
 
@@ -1770,40 +1769,52 @@
 % existential/universal type_infos and type_class_infos
 % in a more consistent manner.
 
-:- pred polymorphism__process_call(pred_id::in, list(prog_var)::in,
-	hlds_goal_info::in, list(prog_var)::out, list(prog_var)::out,
-	hlds_goal_info::out, list(hlds_goal)::out,
+:- pred polymorphism__process_call(pred_id::in,
+	list(prog_var)::in, list(prog_var)::out,
+	hlds_goal_info::in, hlds_goal_info::out,
+	list(prog_var)::out, list(hlds_goal)::out,
 	poly_info::in, poly_info::out) is det.
 
-polymorphism__process_call(PredId, ArgVars0, GoalInfo0,
-		ArgVars, ExtraVars, GoalInfo, ExtraGoals, !Info) :-
+polymorphism__process_call(PredId, ArgVars0, ArgVars, GoalInfo0, GoalInfo,
+		ExtraVars, ExtraGoals, !Info) :-
 	poly_info_get_var_types(!.Info, VarTypes),
 	poly_info_get_typevarset(!.Info, TypeVarSet0),
 	poly_info_get_module_info(!.Info, ModuleInfo),
 
 	module_info_pred_info(ModuleInfo, PredId, PredInfo),
-	pred_info_arg_types(PredInfo, PredTypeVarSet, PredExistQVars0,
-		PredArgTypes0),
-	pred_info_get_class_context(PredInfo, PredClassContext0),
-		% rename apart
-		% (this merge might be a performance bottleneck?)
+	pred_info_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
+		PredArgTypes),
+	pred_info_get_class_context(PredInfo, PredClassContext),
+
+		% VarTypes, TypeVarSet* etc come from the caller.
+		% PredTypeVarSet, PredArgTypes, PredExistQVarTerms, etc come
+		% directly from the callee.
+		% ParentArgTypes, ParentExistQVarTerms etc come from a version
+		% of the callee that has been renamed apart from the caller.
+		%
+		% The difference between e.g. PredArgTypes and ParentArgTypes
+		% is the application of PredToParentTypeSubst, which maps the
+		% type variables in the callee to new type variables in the
+		% caller. Adding the new type variables to TypeVarSet0 yields
+		% TypeVarSet.
 	( varset__is_empty(PredTypeVarSet) ->
-		% optimize common case
-		PredArgTypes = PredArgTypes0,
-		PredExistQVarTerms1 = [],
-		PredTypeVars0 = [],
+		% optimize a common case
+		map__init(PredToParentTypeSubst),
 		TypeVarSet = TypeVarSet0,
-		map__init(Subst)
+		ParentArgTypes = PredArgTypes,
+		ParentTypeVars0 = [],
+		ParentExistQVarTerms1 = []
 	;
-		varset__merge_subst(TypeVarSet0, PredTypeVarSet,
-			TypeVarSet, Subst),
-		term__apply_substitution_to_list(PredArgTypes0, Subst,
-			PredArgTypes),
-		term__var_list_to_term_list(PredExistQVars0,
-			PredExistQVarTerms0),
-		term__apply_substitution_to_list(PredExistQVarTerms0, Subst,
-			PredExistQVarTerms1),
-		term__vars_list(PredArgTypes, PredTypeVars0)
+		% (this merge might be a performance bottleneck?)
+		varset__merge_subst(TypeVarSet0, PredTypeVarSet, TypeVarSet,
+			PredToParentTypeSubst),
+		term__apply_substitution_to_list(PredArgTypes,
+			PredToParentTypeSubst, ParentArgTypes),
+		term__vars_list(ParentArgTypes, ParentTypeVars0),
+		term__var_list_to_term_list(PredExistQVars,
+			PredExistQVarTerms),
+		term__apply_substitution_to_list(PredExistQVarTerms,
+			PredToParentTypeSubst, ParentExistQVarTerms1)
 	),
 
 	PredModule = pred_info_module(PredInfo),
@@ -1811,12 +1822,12 @@
 	PredArity = pred_info_arity(PredInfo),
 	(
 		(
-			% optimize for common case of non-polymorphic call
-			% with no constraints
-			PredTypeVars0 = [],
-			PredClassContext0 = constraints([], [])
+			% Optimize for the common case of non-polymorphic call
+			% with no constraints.
+			ParentTypeVars0 = [],
+			PredClassContext = constraints([], [])
 		;
-			% some builtins don't need the type_info
+			% Some builtins don't need or want the type_info.
 			no_type_info_builtin(PredModule, PredName, PredArity)
 		;
 			% Leave Aditi relations alone, since they must
@@ -1831,20 +1842,12 @@
 		ExtraGoals = [],
 		ExtraVars = []
 	;
-		list__remove_dups(PredTypeVars0, PredTypeVars1),
+		list__remove_dups(ParentTypeVars0, ParentTypeVars1),
 		map__apply_to_list(ArgVars0, VarTypes, ActualArgTypes),
-		(
-			type_list_subsumes(PredArgTypes, ActualArgTypes,
-				TypeSubst1)
-		->
-			TypeSubst = TypeSubst1
-		;
-			error("polymorphism__process_goal_expr: " ++
-				"type unification failed")
-		),
-
-		apply_subst_to_constraints(Subst, PredClassContext0,
-			PredClassContext1),
+		type_list_subsumes_det(ParentArgTypes, ActualArgTypes,
+			ParentToActualTypeSubst),
+		apply_subst_to_constraints(PredToParentTypeSubst,
+			PredClassContext, ParentClassContext),
 
 		poly_info_set_typevarset(TypeVarSet, !Info),
 
@@ -1852,52 +1855,54 @@
 			% for the call, and return a list of which type
 			% variables were constrained by those constraints
 		goal_info_get_context(GoalInfo0, Context),
-		PredClassContext1 = constraints(UniversalConstraints1,
-			ExistentialConstraints1),
+		ParentClassContext = constraints(ParentUniversalConstraints,
+			ParentExistentialConstraints),
 
-			% compute which type variables are constrained
-			% by the type class constraints
-		constraint_list_get_tvars(ExistentialConstraints1,
-			ExistConstrainedTVars),
-		constraint_list_get_tvars(UniversalConstraints1,
-			UnivConstrainedTVars),
-
-		apply_rec_subst_to_constraint_list(TypeSubst,
-			UniversalConstraints1, UniversalConstraints2),
-
-		term__apply_rec_substitution_to_list(PredExistQVarTerms1,
-			TypeSubst, PredExistQVarTerms),
-		term__term_list_to_var_list(PredExistQVarTerms,
-			PredExistQVars),
-
-		polymorphism__make_typeclass_info_vars(UniversalConstraints2,
-			PredExistQVars, Context, UnivTypeClassVars,
-			ExtraTypeClassGoals, !Info),
+			% Compute which type variables are constrained
+			% by the type class constraints.
+		constraint_list_get_tvars(ParentExistentialConstraints,
+			ParentExistConstrainedTVars),
+		constraint_list_get_tvars(ParentUniversalConstraints,
+			ParentUnivConstrainedTVars),
+
+		apply_rec_subst_to_constraint_list(ParentToActualTypeSubst,
+			ParentUniversalConstraints,
+			ActualUniversalConstraints),
+
+		term__apply_rec_substitution_to_list(ParentExistQVarTerms1,
+			ParentToActualTypeSubst, ParentExistQVarTerms),
+		term__term_list_to_var_list(ParentExistQVarTerms,
+			ParentExistQVars),
+
+		polymorphism__make_typeclass_info_vars(
+			ActualUniversalConstraints, ParentExistQVars, Context,
+			UnivTypeClassVars, ExtraTypeClassGoals, !Info),
 
 			% Make variables to hold any existentially
 			% quantified typeclass_infos in the call,
 			% insert them into the typeclass_info map
-		apply_rec_subst_to_constraint_list(TypeSubst,
-			ExistentialConstraints1, ExistentialConstraints),
+		apply_rec_subst_to_constraint_list(ParentToActualTypeSubst,
+			ParentExistentialConstraints,
+			ActualExistentialConstraints),
 		polymorphism__make_existq_typeclass_info_vars(
-			ExistentialConstraints, ExistTypeClassVars,
+			ActualExistentialConstraints, ExistTypeClassVars,
 			ExtraExistClassGoals, !Info),
 
 		list__append(UnivTypeClassVars, ExistTypeClassVars,
 			ExtraTypeClassVars),
 
-			% No need to make typeinfos for the constrained vars
-		list__delete_elems(PredTypeVars1, UnivConstrainedTVars,
-			PredTypeVars2),
-		list__delete_elems(PredTypeVars2, ExistConstrainedTVars,
-			PredTypeVars),
-
-		term__var_list_to_term_list(PredTypeVars, PredTypes0),
-		term__apply_rec_substitution_to_list(PredTypes0, TypeSubst,
-			PredTypes),
+			% No need to make typeinfos for the constrained vars.
+		list__delete_elems(ParentTypeVars1,
+			ParentUnivConstrainedTVars, ParentTypeVars2),
+		list__delete_elems(ParentTypeVars2,
+			ParentExistConstrainedTVars, ParentTypeVars),
+
+		term__var_list_to_term_list(ParentTypeVars, ParentTypes),
+		term__apply_rec_substitution_to_list(ParentTypes,
+			ParentToActualTypeSubst, ActualTypes),
 
-		polymorphism__make_type_info_vars(PredTypes,
-			Context, ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
+		polymorphism__make_type_info_vars(ActualTypes, Context,
+			ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
 		list__append(ExtraTypeClassVars, ArgVars0, ArgVars1),
 		list__append(ExtraTypeInfoVars, ArgVars1, ArgVars),
 		ExtraGoals = ExtraTypeClassGoals ++ ExtraExistClassGoals
@@ -2022,6 +2027,8 @@
 % and create a list of goals to initialize those typeclass_info variables
 % to the appropriate typeclass_info structures for the constraints.
 %
+% Constraints should be renamed-apart and actual-to-formal substituted constraints.
+%
 % Constraints which are already in the TypeClassInfoMap are assumed to
 % have already had their typeclass_infos initialized; for them, we
 % just return the variable in the TypeClassInfoMap.
@@ -2031,21 +2038,22 @@
 	list(prog_var)::out, list(hlds_goal)::out,
 	poly_info::in, poly_info::out) is det.
 
-polymorphism__make_typeclass_info_vars(PredClassContext, ExistQVars, Context,
+polymorphism__make_typeclass_info_vars(Constraints, ExistQVars, Context,
 		ExtraVars, ExtraGoals, !Info) :-
 		% initialise the accumulators
-	ExtraVars0 = [],
-	ExtraGoals0 = [],
+	RevExtraVars0 = [],
+	RevExtraGoals0 = [],
 	SeenInstances = [],
 		% do the work
-	polymorphism__make_typeclass_info_vars_2(PredClassContext,
-		SeenInstances, ExistQVars, Context, ExtraVars0, ExtraVars1,
-		ExtraGoals0, ExtraGoals1, !Info),
+	polymorphism__make_typeclass_info_vars_2(Constraints, SeenInstances,
+		ExistQVars, Context, RevExtraVars0, RevExtraVars,
+		RevExtraGoals0, RevExtraGoals, !Info),
 		% We build up the vars and goals in reverse order
-	list__reverse(ExtraVars1, ExtraVars),
-	list__reverse(ExtraGoals1, ExtraGoals).
+	list__reverse(RevExtraVars, ExtraVars),
+	list__reverse(RevExtraGoals, ExtraGoals).
 
 % Accumulator version of the above.
+
 :- pred polymorphism__make_typeclass_info_vars_2(
 	list(class_constraint)::in, list(class_constraint)::in,
 	existq_tvars::in, prog_context::in,
@@ -2134,23 +2142,18 @@
 			% type variables that are created are bound
 			% when we call type_list_subsumes then apply
 			% the resulting bindings.
+			% XXX expand comment
 		varset__merge_subst(TypeVarSet, InstanceTVarset,
 			_NewTVarset, RenameSubst),
 		term__apply_substitution_to_list(InstanceTypes0,
 			RenameSubst, InstanceTypes),
-		(
-			type_list_subsumes(InstanceTypes,
-				ConstrainedTypes, InstanceSubst0)
-		->
-			InstanceSubst = InstanceSubst0
-		;
-			error("poly: wrong instance decl")
-		),
-
+		type_list_subsumes_det(InstanceTypes, ConstrainedTypes,
+			InstanceSubst),
 		apply_subst_to_constraint_list(RenameSubst,
 			InstanceConstraints0, InstanceConstraints1),
 		apply_rec_subst_to_constraint_list(InstanceSubst,
 			InstanceConstraints1, InstanceConstraints2),
+		% XXX document diamond as guess
 		InstanceConstraints =
 			InstanceConstraints2 `list__delete_elems` Seen,
 		apply_subst_to_constraint_proofs(RenameSubst,
@@ -2166,6 +2169,7 @@
 			UnconstrainedTypes1, InstanceSubst,
 			UnconstrainedTypes),
 
+			% XXX why name of output?
 		map__overlay(Proofs, SuperClassProofs2, SuperClassProofs),
 
 			% Make the type_infos for the types
@@ -2210,6 +2214,7 @@
 		list__condense([RevUnconstrainedTypeInfoGoals, NewGoals,
 			!.ExtraGoals, RevTypeInfoGoals], !:ExtraGoals)
 	;
+		% XXX MR_Dictionary should have MR_Dictionaries for superclass
 			% We have to extract the typeclass_info from
 			% another one
 		Proof = superclass(SubClassConstraint),
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.97
diff -u -b -r1.97 prog_data.m
--- compiler/prog_data.m	19 Sep 2003 11:10:04 -0000	1.97
+++ compiler/prog_data.m	26 Oct 2003 12:29:58 -0000
@@ -638,8 +638,10 @@
 
 :- type class_constraints
 	---> constraints(
-		list(class_constraint),	% ordinary (universally quantified)
-		list(class_constraint)	% existentially quantified constraints
+		univ_constraints	:: list(class_constraint),
+					% universally quantified constraints
+		exist_constraints	:: list(class_constraint)
+					% existentially quantified constraints
 	).
 
 :- type class_name == sym_name.
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.128
diff -u -b -r1.128 type_util.m
--- compiler/type_util.m	24 Oct 2003 06:17:50 -0000	1.128
+++ compiler/type_util.m	26 Oct 2003 08:00:54 -0000
@@ -400,6 +400,11 @@
 :- pred type_list_subsumes(list(type), list(type), tsubst).
 :- mode type_list_subsumes(in, in, out) is semidet.
 
+	% This does the same as type_list_subsumes, but aborts instead of
+	% failing.
+:- pred type_list_subsumes_det(list(type), list(type), tsubst).
+:- mode type_list_subsumes_det(in, in, out) is det.
+
 	% arg_type_list_subsumes(TVarSet, ArgTypes,
 	%       CalleeTVarSet, CalleeExistQVars, CalleeArgTypes).
 	%
@@ -1487,6 +1492,13 @@
 	term__vars_list(TypesB, TypesBVars),
 	map__init(TypeSubst0),
 	type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
+
+type_list_subsumes_det(TypesA, TypesB, TypeSubst) :-
+	( type_list_subsumes(TypesA, TypesB, TypeSubstPrime) ->
+		TypeSubst = TypeSubstPrime
+	;
+		error("type_list_subsumes_det: type_list_subsumes failed")
+	).
 
 arg_type_list_subsumes(TVarSet, ArgTypes, CalleeTVarSet,
 		CalleeExistQVars0, CalleeArgTypes0) :-
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing gcc
cvs diff: Diffing gcc/mercury
cvs diff: Diffing java
cvs diff: Diffing java/library
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/varset.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/varset.m,v
retrieving revision 1.68
diff -u -b -r1.68 varset.m
--- library/varset.m	26 May 2003 09:00:31 -0000	1.68
+++ library/varset.m	26 Oct 2003 13:32:49 -0000
@@ -133,21 +133,32 @@
 :- func varset__lookup_vars(varset(T)) = substitution(T).
 
 	% Combine two different varsets, renaming apart:
-	% varset__merge(VarSet0, NewVarSet, Terms0, VarSet, Terms) is
+	% varset__merge(VarSet0, NewVarSet, VarSet, Subst) is
 	% true iff VarSet is the varset that results from joining
-	% VarSet0 to a suitably renamed version of NewVarSet,
-	% and Terms is Terms0 renamed accordingly.
+	% a suitably renamed version of NewVarSet to VarSet0.
 	% (Any bindings in NewVarSet are ignored.)
+	% Subst is a substitution which maps the variables in NewVarSet
+	% into the corresponding fresh variable in VarSet.
+
+:- pred varset__merge_subst(varset(T), varset(T), varset(T), substitution(T)).
+:- mode varset__merge_subst(in, in, out, out) is det.
+
+	% varset__merge(VarSet0, NewVarSet, Terms0, VarSet, Terms):
+	% As varset__merge_subst, except instead of returning the substitution,
+	% this predicate applies it to the given list of terms.
 
 :- pred varset__merge(varset(T), varset(T), list(term(T)),
 		varset(T), list(term(T))).
 :- mode varset__merge(in, in, in, out, out) is det.
 
-	% As above, except return the substitution directly
-	% rather than applying it to a list of terms.
+	% Same as varset__merge_subst, except that the names of variables
+	% in NewVarSet are not included in the final varset.
+	% This is useful if varset__create_name_var_map needs
+	% to be used on the resulting varset.
 
-:- pred varset__merge_subst(varset(T), varset(T), varset(T), substitution(T)).
-:- mode varset__merge_subst(in, in, out, out) is det.
+:- pred varset__merge_subst_without_names(varset(T),
+		varset(T), varset(T), substitution(T)).
+:- mode varset__merge_subst_without_names(in, in, out, out) is det.
 
 	% Same as varset__merge, except that the names of variables
 	% in NewVarSet are not included in the final varset.
@@ -157,13 +168,6 @@
 :- pred varset__merge_without_names(varset(T), varset(T), list(term(T)),
 		varset(T), list(term(T))).
 :- mode varset__merge_without_names(in, in, in, out, out) is det.
-
-	% As above, except return the substitution directly
-	% rather than applying it to a list of terms.
-
-:- pred varset__merge_subst_without_names(varset(T),
-		varset(T), varset(T), substitution(T)).
-:- mode varset__merge_subst_without_names(in, in, out, out) is det.
 
 	% get the bindings for all the bound variables.
 :- pred varset__get_bindings(varset(T), substitution(T)).
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------

More information about the reviews mailing list