[m-rev.] first step toward functional dependencies (2/3)
Mark Brown
mark at cs.mu.OZ.AU
Wed Mar 23 23:21:04 AEDT 2005
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.261
diff -u -r1.261 polymorphism.m
--- compiler/polymorphism.m 22 Mar 2005 06:40:17 -0000 1.261
+++ compiler/polymorphism.m 23 Mar 2005 09:15:26 -0000
@@ -266,15 +266,15 @@
proc_info::in, proc_info::out, module_info::out) is det.
% Build the type describing the typeclass_info for the
- % given class_constraint.
-:- pred polymorphism__build_typeclass_info_type(class_constraint::in,
+ % given prog_constraint.
+:- pred polymorphism__build_typeclass_info_type(prog_constraint::in,
(type)::out) is det.
- % From the type of a typeclass_info variable find the class_constraint
+ % From the type of a typeclass_info variable find the prog_constraint
% about which the variable carries information, failing if the
% type is not a valid typeclass_info type.
:- pred polymorphism__typeclass_info_class_constraint((type)::in,
- class_constraint::out) is semidet.
+ prog_constraint::out) is semidet.
% From the type of a type_info variable find the type about which
% the type_info or type_ctor_info carries information, failing if the
@@ -772,7 +772,7 @@
UnconstrainedTVars, ExtraHeadTypeInfoVars,
ExistHeadTypeClassInfoVars, !Info).
-:- pred polymorphism__setup_headvars_2(pred_info::in, class_constraints::in,
+:- pred polymorphism__setup_headvars_2(pred_info::in, prog_constraints::in,
list(prog_var)::in, list(mode)::in, list(tvar)::in,
list(prog_var)::in, list(prog_var)::in, list(prog_var)::out,
list(mode)::out, list(tvar)::out, list(tvar)::out,
@@ -953,7 +953,7 @@
ExistQVarsForCall = [],
Goal0 = _ - GoalInfo,
goal_info_get_context(GoalInfo, Context),
- apply_rec_subst_to_constraint_list(PredToActualTypeSubst,
+ apply_rec_subst_to_prog_constraint_list(PredToActualTypeSubst,
PredExistConstraints, ActualExistConstraints),
polymorphism__make_typeclass_info_vars(ActualExistConstraints,
ExistQVarsForCall, Context, ExistTypeClassVars,
@@ -1398,20 +1398,23 @@
yes(CallUnifyContext), QualifiedPName),
%
- % construct a goal_info for the lambda goal, making sure
- % to set up the nonlocals field in the goal_info correctly
+ % Construct a goal_info for the lambda goal, making sure
+ % to set up the nonlocals field in the goal_info correctly.
+ % The goal_path is needed to compute constraint_ids correctly.
%
goal_info_get_nonlocals(GoalInfo0, NonLocals),
set__insert_list(NonLocals, LambdaVars, OutsideVars),
set__list_to_set(Args, InsideVars),
set__intersect(OutsideVars, InsideVars, LambdaNonLocals),
+ goal_info_get_goal_path(GoalInfo0, GoalPath),
goal_info_init(LambdaGoalInfo0),
goal_info_set_context(LambdaGoalInfo0, Context,
LambdaGoalInfo1),
goal_info_set_nonlocals(LambdaGoalInfo1, LambdaNonLocals,
LambdaGoalInfo2),
add_goal_info_purity_feature(LambdaGoalInfo2, Purity,
- LambdaGoalInfo),
+ LambdaGoalInfo3),
+ goal_info_set_goal_path(LambdaGoalInfo3, GoalPath, LambdaGoalInfo),
LambdaGoal = LambdaGoalExpr - LambdaGoalInfo,
%
@@ -1477,7 +1480,7 @@
term__var_list_to_term_list(CtorExistQVars, CtorExistQVarTerms),
term__apply_substitution_to_list(CtorExistQVarTerms, CtorToParentSubst,
ParentExistQVarsTerms),
- apply_subst_to_constraint_list(CtorToParentSubst,
+ apply_subst_to_prog_constraint_list(CtorToParentSubst,
CtorExistentialConstraints, ParentExistentialConstraints),
term__apply_substitution_to_list(CtorArgTypes, CtorToParentSubst,
ParentArgTypes),
@@ -1496,7 +1499,7 @@
%
% Apply those type bindings to the existential type class constraints
%
- apply_rec_subst_to_constraint_list(ParentToActualTypeSubst,
+ apply_rec_subst_to_prog_constraint_list(ParentToActualTypeSubst,
ParentExistentialConstraints,
ActualExistentialConstraints),
@@ -1655,7 +1658,7 @@
make_foreign_args(Vars, ArgInfos, OrigArgTypes, Args).
:- pred polymorphism__foreign_proc_add_typeclass_info((mode)::in,
- pragma_foreign_code_impl::in, tvarset::in, class_constraint::in,
+ pragma_foreign_code_impl::in, tvarset::in, prog_constraint::in,
maybe(pair(string, mode))::out) is det.
polymorphism__foreign_proc_add_typeclass_info(Mode, Impl, TypeVarSet,
@@ -1779,19 +1782,19 @@
map__init(PredToParentTypeSubst),
TypeVarSet = TypeVarSet0,
ParentArgTypes = PredArgTypes,
- ParentTypeVars0 = [],
- ParentExistQVarTerms1 = []
+ ParentTypeVars = [],
+ ParentExistQVarTerms = []
;
% (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__vars_list(ParentArgTypes, ParentTypeVars),
term__var_list_to_term_list(PredExistQVars,
PredExistQVarTerms),
term__apply_substitution_to_list(PredExistQVarTerms,
- PredToParentTypeSubst, ParentExistQVarTerms1)
+ PredToParentTypeSubst, ParentExistQVarTerms)
),
PredModule = pred_info_module(PredInfo),
@@ -1801,7 +1804,7 @@
(
% Optimize for the common case of non-polymorphic call
% with no constraints.
- ParentTypeVars0 = [],
+ ParentTypeVars = [],
PredClassContext = constraints([], [])
;
% Some builtins don't need or want the type_info.
@@ -1818,70 +1821,74 @@
ExtraGoals = [],
ExtraVars = []
;
- list__remove_dups(ParentTypeVars0, ParentTypeVars1),
- map__apply_to_list(ArgVars0, VarTypes, ActualArgTypes),
- type_list_subsumes_det(ParentArgTypes, ActualArgTypes,
- ParentToActualTypeSubst),
- apply_subst_to_constraints(PredToParentTypeSubst,
- PredClassContext, ParentClassContext),
-
poly_info_set_typevarset(TypeVarSet, !Info),
- % Make the universally quantified typeclass_infos
- % for the call, and return a list of which type
- % variables were constrained by those constraints
- goal_info_get_context(GoalInfo0, Context),
- ParentClassContext = constraints(ParentUniversalConstraints,
- ParentExistentialConstraints),
-
- % Compute which type variables are constrained
+ % Compute which "parent" type variables are constrained
% by the type class constraints.
- constraint_list_get_tvars(ParentExistentialConstraints,
- ParentExistConstrainedTVars),
- constraint_list_get_tvars(ParentUniversalConstraints,
+ apply_subst_to_prog_constraints(PredToParentTypeSubst,
+ PredClassContext, ParentClassContext),
+ ParentClassContext = constraints(ParentUnivConstraints,
+ ParentExistConstraints),
+ constraint_list_get_tvars(ParentUnivConstraints,
ParentUnivConstrainedTVars),
+ constraint_list_get_tvars(ParentExistConstraints,
+ ParentExistConstrainedTVars),
+
+ % Calculate the set of unconstrained type vars.
+ list__remove_dups(ParentTypeVars,
+ ParentUnconstrainedTypeVars0),
+ list__delete_elems(ParentUnconstrainedTypeVars0,
+ ParentUnivConstrainedTVars,
+ ParentUnconstrainedTypeVars1),
+ list__delete_elems(ParentUnconstrainedTypeVars1,
+ ParentExistConstrainedTVars,
+ ParentUnconstrainedTypeVars),
+ term__var_list_to_term_list(ParentUnconstrainedTypeVars,
+ ParentUnconstrainedTypes),
- 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),
+ % Calculate the "parent to actual" binding.
+ map__apply_to_list(ArgVars0, VarTypes, ActualArgTypes),
+ type_list_subsumes_det(ParentArgTypes, ActualArgTypes,
+ ParentToActualTypeSubst),
+ % Make the universally quantified typeclass_infos
+ % for the call.
+ poly_info_get_constraint_map(!.Info, ConstraintMap),
+ goal_info_get_goal_path(GoalInfo0, GoalPath),
+ list__length(ParentUnivConstraints, NumUnivConstraints),
+ lookup_hlds_constraint_list(ConstraintMap, universal, GoalPath,
+ NumUnivConstraints, ActualUnivConstraints),
+ term__apply_rec_substitution_to_list(ParentExistQVarTerms,
+ ParentToActualTypeSubst, ActualExistQVarTerms),
+ term__term_list_to_var_list(ActualExistQVarTerms,
+ ActualExistQVars),
+ goal_info_get_context(GoalInfo0, Context),
polymorphism__make_typeclass_info_vars(
- ActualUniversalConstraints, ParentExistQVars, Context,
- UnivTypeClassVars, ExtraTypeClassGoals, !Info),
+ ActualUnivConstraints, ActualExistQVars, Context,
+ ExtraUnivClassVars, ExtraUnivClassGoals, !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(ParentToActualTypeSubst,
- ParentExistentialConstraints,
- ActualExistentialConstraints),
+ list__length(ParentExistConstraints, NumExistConstraints),
+ lookup_hlds_constraint_list(ConstraintMap, existential,
+ GoalPath, NumExistConstraints, ActualExistConstraints),
polymorphism__make_existq_typeclass_info_vars(
- ActualExistentialConstraints, ExistTypeClassVars,
+ ActualExistConstraints, ExtraExistClassVars,
ExtraExistClassGoals, !Info),
- list__append(UnivTypeClassVars, ExistTypeClassVars,
- ExtraTypeClassVars),
+ % Make variables to hold typeinfos for any remaining
+ % (that is, unconstrained) type vars.
+ term__apply_rec_substitution_to_list(ParentUnconstrainedTypes,
+ ParentToActualTypeSubst, ActualUnconstrainedTypes),
+ polymorphism__make_type_info_vars(ActualUnconstrainedTypes,
+ Context, ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
- % 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(ActualTypes, Context,
- ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
- ExtraGoals = ExtraTypeClassGoals ++ ExtraExistClassGoals
+ % Add up the extra vars and goals.
+ ExtraGoals = ExtraUnivClassGoals ++ ExtraExistClassGoals
++ ExtraTypeInfoGoals,
- ExtraVars = ExtraTypeInfoVars ++ ExtraTypeClassVars,
+ ExtraVars = ExtraTypeInfoVars ++ ExtraUnivClassVars
+ ++ ExtraExistClassVars,
%
% update the non-locals
@@ -1995,7 +2002,7 @@
%-----------------------------------------------------------------------------%
-:- pred polymorphism__update_typeclass_infos(list(class_constraint)::in,
+:- pred polymorphism__update_typeclass_infos(list(prog_constraint)::in,
list(prog_var)::in, poly_info::in, poly_info::out) is det.
polymorphism__update_typeclass_infos(Constraints, Vars, !Info) :-
@@ -2004,10 +2011,9 @@
TypeClassInfoMap0, TypeClassInfoMap),
poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info).
-:- pred insert_typeclass_info_locns(list(class_constraint)::in,
+:- pred insert_typeclass_info_locns(list(prog_constraint)::in,
list(prog_var)::in,
- map(class_constraint, prog_var)::in,
- map(class_constraint, prog_var)::out) is det.
+ typeclass_info_varmap::in, typeclass_info_varmap::out) is det.
insert_typeclass_info_locns([], [], !TypeClassInfoMap).
insert_typeclass_info_locns([C | Cs], [V | Vs], !TypeClassInfoMap) :-
@@ -2111,7 +2117,7 @@
% have already had their typeclass_infos initialized; for them, we
% just return the variable in the TypeClassInfoMap.
-:- pred polymorphism__make_typeclass_info_vars(list(class_constraint)::in,
+:- pred polymorphism__make_typeclass_info_vars(list(prog_constraint)::in,
existq_tvars::in, prog_context::in,
list(prog_var)::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
@@ -2133,7 +2139,7 @@
% Accumulator version of the above.
:- pred polymorphism__make_typeclass_info_vars_2(
- list(class_constraint)::in, list(class_constraint)::in,
+ list(prog_constraint)::in, list(prog_constraint)::in,
existq_tvars::in, prog_context::in,
list(prog_var)::in, list(prog_var)::out,
list(hlds_goal)::in, list(hlds_goal)::out,
@@ -2149,8 +2155,8 @@
polymorphism__make_typeclass_info_vars_2(Constraints, Seen, ExistQVars,
Context, !ExtraVars, !ExtraGoals, !Info).
-:- pred polymorphism__make_typeclass_info_var(class_constraint::in,
- list(class_constraint)::in, existq_tvars::in, prog_context::in,
+:- pred polymorphism__make_typeclass_info_var(prog_constraint::in,
+ list(prog_constraint)::in, existq_tvars::in, prog_context::in,
list(hlds_goal)::in, list(hlds_goal)::out,
poly_info::in, poly_info::out, maybe(prog_var)::out) is det.
@@ -2185,8 +2191,8 @@
MaybeVar = yes(NewVar)
).
-:- pred polymorphism__make_typeclass_info_from_proof(class_constraint::in,
- list(class_constraint)::in, constraint_proof::in, existq_tvars::in,
+:- pred polymorphism__make_typeclass_info_from_proof(prog_constraint::in,
+ list(prog_constraint)::in, constraint_proof::in, existq_tvars::in,
prog_context::in, maybe(prog_var)::out,
list(hlds_goal)::in, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
@@ -2213,8 +2219,8 @@
MaybeVar, !ExtraGoals, !Info)
).
-:- pred polymorphism__make_typeclass_info_from_instance(class_constraint::in,
- list(class_constraint)::in, class_id::in, int::in, existq_tvars::in,
+:- pred polymorphism__make_typeclass_info_from_instance(prog_constraint::in,
+ list(prog_constraint)::in, class_id::in, int::in, existq_tvars::in,
prog_context::in, maybe(prog_var)::out,
list(hlds_goal)::in, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
@@ -2224,7 +2230,8 @@
!ExtraGoals, !Info) :-
Constraint = constraint(_ClassName, ConstrainedTypes),
!.Info = poly_info(_VarSet0, _VarTypes0, TypeVarSet, _TypeInfoMap0,
- _TypeClassInfoMap0, Proofs, _PredName, ModuleInfo),
+ _TypeClassInfoMap0, Proofs, _ConstraintMap, _PredName,
+ ModuleInfo),
module_info_instances(ModuleInfo, InstanceTable),
map__lookup(InstanceTable, ClassId, InstanceList),
@@ -2247,9 +2254,9 @@
term__apply_substitution_to_list(InstanceTypes0,
RenameSubst, InstanceTypes),
type_list_subsumes_det(InstanceTypes, ConstrainedTypes, InstanceSubst),
- apply_subst_to_constraint_list(RenameSubst,
+ apply_subst_to_prog_constraint_list(RenameSubst,
InstanceConstraints0, InstanceConstraints1),
- apply_rec_subst_to_constraint_list(InstanceSubst,
+ apply_rec_subst_to_prog_constraint_list(InstanceSubst,
InstanceConstraints1, InstanceConstraints2),
% XXX document diamond as guess
InstanceConstraints = InstanceConstraints2 `list__delete_elems` Seen,
@@ -2308,8 +2315,8 @@
list__condense([RevUnconstrainedTypeInfoGoals, NewGoals,
!.ExtraGoals, RevTypeInfoGoals], !:ExtraGoals).
-:- pred polymorphism__make_typeclass_info_from_subclass(class_constraint::in,
- list(class_constraint)::in, class_id::in, class_constraint::in,
+:- pred polymorphism__make_typeclass_info_from_subclass(prog_constraint::in,
+ list(prog_constraint)::in, class_id::in, prog_constraint::in,
existq_tvars::in, prog_context::in, maybe(prog_var)::out,
list(hlds_goal)::in, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
@@ -2318,7 +2325,8 @@
Seen, ClassId, SubClassConstraint, ExistQVars, Context,
MaybeVar, !ExtraGoals, !Info) :-
!.Info = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
- TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
+ TypeClassInfoMap0, Proofs, ConstraintMap, PredName,
+ ModuleInfo),
ClassId = class_id(ClassName, _ClassArity),
% First create a variable to hold the new typeclass_info.
unqualify_name(ClassName, ClassNameString),
@@ -2330,7 +2338,8 @@
list__length(SubClassTypes, SubClassArity),
SubClassId = class_id(SubClassName, SubClassArity),
!:Info = poly_info(VarSet1, VarTypes1, TypeVarSet, TypeInfoMap0,
- TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
+ TypeClassInfoMap0, Proofs, ConstraintMap, PredName,
+ ModuleInfo),
% Make the typeclass_info for the subclass
polymorphism__make_typeclass_info_var(SubClassConstraint, Seen,
@@ -2350,7 +2359,7 @@
% Work out which superclass typeclass_info to take.
map__from_corresponding_lists(SubClassVars, SubClassTypes,
SubTypeSubst),
- apply_subst_to_constraint_list(SubTypeSubst, SuperClasses0,
+ apply_subst_to_prog_constraint_list(SubTypeSubst, SuperClasses0,
SuperClasses),
(
list__nth_member_search(SuperClasses, Constraint,
@@ -2382,8 +2391,8 @@
:- pred polymorphism__construct_typeclass_info(list(prog_var)::in,
list(prog_var)::in, list(prog_var)::in, class_id::in,
- class_constraint::in, int::in, list(type)::in,
- map(class_constraint, constraint_proof)::in, existq_tvars::in,
+ prog_constraint::in, int::in, list(type)::in,
+ constraint_proof_map::in, existq_tvars::in,
prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out)
is det.
@@ -2491,7 +2500,7 @@
%---------------------------------------------------------------------------%
:- pred polymorphism__get_arg_superclass_vars(hlds_class_defn::in,
- list(type)::in, map(class_constraint, constraint_proof)::in,
+ list(type)::in, constraint_proof_map::in,
existq_tvars::in, list(prog_var)::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
@@ -2511,8 +2520,9 @@
term__vars_list(ClassVars1, ClassVars),
map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
- apply_subst_to_constraint_list(Subst, SuperClasses0, SuperClasses1),
- apply_rec_subst_to_constraint_list(TypeSubst, SuperClasses1,
+ apply_subst_to_prog_constraint_list(Subst, SuperClasses0,
+ SuperClasses1),
+ apply_rec_subst_to_prog_constraint_list(TypeSubst, SuperClasses1,
SuperClasses),
poly_info_set_proofs(SuperClassProofs, !Info),
@@ -2521,7 +2531,7 @@
poly_info_set_proofs(Proofs, !Info).
-:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint)::in,
+:- pred polymorphism__make_superclasses_from_proofs(list(prog_constraint)::in,
existq_tvars::in, list(hlds_goal)::in, list(hlds_goal)::out,
poly_info::in, poly_info::out, list(prog_var)::in, list(prog_var)::out)
is det.
@@ -2547,7 +2557,7 @@
% Produce the typeclass_infos for the existential class
% constraints for a call or deconstruction unification.
:- pred polymorphism__make_existq_typeclass_info_vars(
- list(class_constraint)::in, list(prog_var)::out, list(hlds_goal)::out,
+ list(prog_constraint)::in, list(prog_var)::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
polymorphism__make_existq_typeclass_info_vars(ExistentialConstraints,
@@ -3038,7 +3048,7 @@
% Create a head var for each class constraint, and make an entry in
% the typeinfo locations map for each constrained type var.
-:- pred polymorphism__make_typeclass_info_head_vars(list(class_constraint)::in,
+:- pred polymorphism__make_typeclass_info_head_vars(list(prog_constraint)::in,
list(prog_var)::out, poly_info::in, poly_info::out) is det.
polymorphism__make_typeclass_info_head_vars(Constraints, ExtraHeadVars,
@@ -3046,7 +3056,7 @@
list__map_foldl(polymorphism__make_typeclass_info_head_var,
Constraints, ExtraHeadVars, !Info).
-:- pred polymorphism__make_typeclass_info_head_var(class_constraint::in,
+:- pred polymorphism__make_typeclass_info_head_var(prog_constraint::in,
prog_var::out, poly_info::in, poly_info::out) is det.
polymorphism__make_typeclass_info_head_var(Constraint, ExtraHeadVar, !Info) :-
@@ -3137,7 +3147,7 @@
is_pair(_).
-:- pred polymorphism__new_typeclass_info_var(class_constraint::in, string::in,
+:- pred polymorphism__new_typeclass_info_var(prog_constraint::in, string::in,
prog_var::out, prog_varset::in, prog_varset::out,
map(prog_var, type)::in, map(prog_var, type)::out) is det.
@@ -3380,10 +3390,10 @@
%---------------------------------------------------------------------------%
-:- func get_constrained_vars(class_constraint) = list(tvar).
+:- func get_constrained_vars(prog_constraint) = list(tvar).
-get_constrained_vars(ClassConstraint) = CVars :-
- ClassConstraint = constraint(_, CTypes),
+get_constrained_vars(Constraint) = CVars :-
+ Constraint = constraint(_, CTypes),
term__vars_list(CTypes, CVars).
%---------------------------------------------------------------------------%
@@ -3402,13 +3412,12 @@
% for each of the pred's type
% parameters
- typeclass_info_map :: map(class_constraint, prog_var),
+ typeclass_info_map :: typeclass_info_varmap,
% specifies the location of
% the typeclass_info var
% for each of the pred's class
% constraints
- proof_map :: map(class_constraint,
- constraint_proof),
+ proof_map :: constraint_proof_map,
% specifies why each constraint
% that was eliminated from the
% pred was able to be eliminated
@@ -3422,6 +3431,9 @@
% first is the information
% calculated here in
% polymorphism.m
+ constraint_map :: constraint_map,
+ % specifies the constraints at each
+ % location in the goal
pred_info :: pred_info,
module_info :: module_info
@@ -3440,22 +3452,24 @@
clauses_info_vartypes(ClausesInfo, VarTypes),
pred_info_typevarset(PredInfo, TypeVarSet),
pred_info_get_constraint_proofs(PredInfo, Proofs),
+ pred_info_get_constraint_map(PredInfo, ConstraintMap),
map__init(TypeInfoMap),
map__init(TypeClassInfoMap),
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
- TypeClassInfoMap, Proofs, PredInfo, ModuleInfo).
+ TypeClassInfoMap, Proofs, ConstraintMap, PredInfo, ModuleInfo).
% create_poly_info creates a poly_info for an existing procedure.
% (See also init_poly_info.)
create_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
pred_info_typevarset(PredInfo, TypeVarSet),
pred_info_get_constraint_proofs(PredInfo, Proofs),
+ pred_info_get_constraint_map(PredInfo, ConstraintMap),
proc_info_varset(ProcInfo, VarSet),
proc_info_vartypes(ProcInfo, VarTypes),
proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap),
proc_info_typeclass_info_varmap(ProcInfo, TypeClassInfoMap),
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
- TypeClassInfoMap, Proofs, PredInfo, ModuleInfo).
+ TypeClassInfoMap, Proofs, ConstraintMap, PredInfo, ModuleInfo).
% create_poly_info creates a poly_info for a call.
% (See also init_poly_info.)
@@ -3463,14 +3477,16 @@
PolyInfo) :-
pred_info_typevarset(PredInfo, TypeVarSet),
pred_info_get_constraint_proofs(PredInfo, Proofs),
+ pred_info_get_constraint_map(PredInfo, ConstraintMap),
proc_info_typeinfo_varmap(ProcInfo, TypeInfoMap),
proc_info_typeclass_info_varmap(ProcInfo, TypeClassInfoMap),
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
- TypeClassInfoMap, Proofs, PredInfo, ModuleInfo).
+ TypeClassInfoMap, Proofs, ConstraintMap, PredInfo, ModuleInfo).
poly_info_extract(Info, !PredInfo, !ProcInfo, ModuleInfo) :-
Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap,
- TypeclassInfoLocations, _Proofs, _OldPredInfo, ModuleInfo),
+ TypeclassInfoLocations, _Proofs, _ConstraintMap, _OldPredInfo,
+ ModuleInfo),
% set the new values of the fields in proc_info and pred_info
proc_info_set_varset(VarSet, !ProcInfo),
@@ -3487,9 +3503,10 @@
:- pred poly_info_get_type_info_map(poly_info::in, type_info_varmap::out)
is det.
:- pred poly_info_get_typeclass_info_map(poly_info::in,
- map(class_constraint, prog_var)::out) is det.
-:- pred poly_info_get_proofs(poly_info::in,
- map(class_constraint, constraint_proof)::out) is det.
+ typeclass_info_varmap::out) is det.
+:- pred poly_info_get_proofs(poly_info::in, constraint_proof_map::out) is det.
+:- pred poly_info_get_constraint_map(poly_info::in, constraint_map::out)
+ is det.
:- pred poly_info_get_pred_info(poly_info::in, pred_info::out) is det.
:- pred poly_info_get_module_info(poly_info::in, module_info::out) is det.
@@ -3499,6 +3516,7 @@
poly_info_get_type_info_map(PolyInfo, PolyInfo ^ type_info_varmap).
poly_info_get_typeclass_info_map(PolyInfo, PolyInfo ^ typeclass_info_map).
poly_info_get_proofs(PolyInfo, PolyInfo ^ proof_map).
+poly_info_get_constraint_map(PolyInfo, PolyInfo ^ constraint_map).
poly_info_get_pred_info(PolyInfo, PolyInfo ^ pred_info).
poly_info_get_module_info(PolyInfo, PolyInfo ^ module_info).
@@ -3510,9 +3528,11 @@
poly_info::out) is det.
:- pred poly_info_set_type_info_map(type_info_varmap::in,
poly_info::in, poly_info::out) is det.
-:- pred poly_info_set_typeclass_info_map(map(class_constraint, prog_var)::in,
+:- pred poly_info_set_typeclass_info_map(typeclass_info_varmap::in,
+ poly_info::in, poly_info::out) is det.
+:- pred poly_info_set_proofs(constraint_proof_map::in,
poly_info::in, poly_info::out) is det.
-:- pred poly_info_set_proofs(map(class_constraint, constraint_proof)::in,
+:- pred poly_info_set_constraint_map(constraint_map::in,
poly_info::in, poly_info::out) is det.
:- pred poly_info_set_module_info(module_info::in, poly_info::in,
poly_info::out) is det.
@@ -3525,6 +3545,8 @@
poly_info_set_typeclass_info_map(TypeClassInfoMap, PI,
PI ^ typeclass_info_map := TypeClassInfoMap).
poly_info_set_proofs(Proofs, PI, PI ^ proof_map := Proofs).
+poly_info_set_constraint_map(ConstraintMap, PI,
+ PI ^ constraint_map := ConstraintMap).
poly_info_set_module_info(ModuleInfo, PI, PI ^ module_info := ModuleInfo).
%---------------------------------------------------------------------------%
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.70
diff -u -r1.70 post_typecheck.m
--- compiler/post_typecheck.m 22 Mar 2005 06:40:18 -0000 1.70
+++ compiler/post_typecheck.m 22 Mar 2005 12:23:48 -0000
@@ -242,25 +242,25 @@
pred_info::in, pred_info::out, bool::in, int::out, io::di, io::uo)
is det.
-post_typecheck__check_type_bindings(ModuleInfo, PredId, PredInfo0, PredInfo,
- ReportErrs, NumErrors, !IO) :-
+post_typecheck__check_type_bindings(ModuleInfo, PredId, !PredInfo, ReportErrs,
+ NumErrors, !IO) :-
(
ReportErrs = yes,
- pred_info_get_unproven_body_constraints(PredInfo0,
+ pred_info_get_unproven_body_constraints(!.PredInfo,
UnprovenConstraints0),
UnprovenConstraints0 \= []
->
list__sort_and_remove_dups(UnprovenConstraints0,
UnprovenConstraints),
report_unsatisfied_constraints(UnprovenConstraints,
- PredId, PredInfo0, ModuleInfo, !IO),
+ PredId, !.PredInfo, ModuleInfo, !IO),
list__length(UnprovenConstraints, NumErrors)
;
NumErrors = 0
),
- pred_info_clauses_info(PredInfo0, ClausesInfo0),
- pred_info_get_head_type_params(PredInfo0, HeadTypeParams),
+ pred_info_clauses_info(!.PredInfo, ClausesInfo0),
+ pred_info_get_head_type_params(!.PredInfo, HeadTypeParams),
clauses_info_varset(ClausesInfo0, VarSet),
clauses_info_vartypes(ClausesInfo0, VarTypesMap0),
map__to_assoc_list(VarTypesMap0, VarTypesList),
@@ -268,14 +268,14 @@
check_type_bindings_2(VarTypesList, HeadTypeParams, [], Errs,
Set0, Set),
( Errs = [] ->
- PredInfo = PredInfo0
+ true
;
( ReportErrs = yes ->
%
% report the warning
%
- report_unresolved_type_warning(Errs, PredId, PredInfo0,
- ModuleInfo, VarSet, !IO)
+ report_unresolved_type_warning(Errs, PredId,
+ !.PredInfo, ModuleInfo, VarSet, !IO)
;
true
),
@@ -283,13 +283,15 @@
%
% bind all the type variables in `Set' to `void' ...
%
- pred_info_get_constraint_proofs(PredInfo0, Proofs0),
+ pred_info_get_constraint_proofs(!.PredInfo, Proofs0),
+ pred_info_get_constraint_map(!.PredInfo, ConstraintMap0),
bind_type_vars_to_void(Set, VarTypesMap0, VarTypesMap,
- Proofs0, Proofs),
+ Proofs0, Proofs, ConstraintMap0, ConstraintMap),
clauses_info_set_vartypes(VarTypesMap,
ClausesInfo0, ClausesInfo),
- pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo1),
- pred_info_set_constraint_proofs(Proofs, PredInfo1, PredInfo)
+ pred_info_set_clauses_info(ClausesInfo, !PredInfo),
+ pred_info_set_constraint_proofs(Proofs, !PredInfo),
+ pred_info_set_constraint_map(ConstraintMap, !PredInfo)
).
:- pred check_type_bindings_2(assoc_list(prog_var, (type))::in, list(tvar)::in,
@@ -314,9 +316,11 @@
%
:- pred bind_type_vars_to_void(set(tvar)::in,
map(prog_var, type)::in, map(prog_var, type)::out,
- constraint_proof_map::in, constraint_proof_map::out) is det.
+ constraint_proof_map::in, constraint_proof_map::out,
+ constraint_map::in, constraint_map::out) is det.
-bind_type_vars_to_void(UnboundTypeVarsSet, !VarTypesMap, !Proofs) :-
+bind_type_vars_to_void(UnboundTypeVarsSet, !VarTypesMap, !Proofs,
+ !ConstraintMap) :-
%
% first create a pair of corresponding lists (UnboundTypeVars, Voids)
% that map the unbound type variables to void
@@ -341,13 +345,14 @@
Types0, Types),
map__from_corresponding_lists(Vars, Types, !:VarTypesMap),
- apply_subst_to_constraint_proofs(VoidSubst, !Proofs).
+ apply_subst_to_constraint_proofs(VoidSubst, !Proofs),
+ apply_subst_to_constraint_map(VoidSubst, !ConstraintMap).
%-----------------------------------------------------------------------------%
%
% report an error: unsatisfied type class constraints
%
-:- pred report_unsatisfied_constraints(list(class_constraint)::in,
+:- pred report_unsatisfied_constraints(list(prog_constraint)::in,
pred_id::in, pred_info::in, module_info::in, io::di, io::uo) is det.
report_unsatisfied_constraints(Constraints, PredId, PredInfo, ModuleInfo) -->
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.121
diff -u -r1.121 prog_data.m
--- compiler/prog_data.m 22 Mar 2005 06:40:18 -0000 1.121
+++ compiler/prog_data.m 22 Mar 2005 12:23:48 -0000
@@ -110,7 +110,7 @@
pf_maybe_detism :: maybe(determinism),
pf_cond :: condition,
pf_purity :: purity,
- pf_class_context :: class_constraints
+ pf_class_context :: prog_constraints
)
% The WithType and WithInst fields hold the `with_type`
% and `with_inst` annotations, which are syntactic
@@ -144,7 +144,7 @@
)
; typeclass(
- tc_constraints :: list(class_constraint),
+ tc_constraints :: list(prog_constraint),
tc_class_name :: class_name,
tc_class_params :: list(tvar),
tc_class_methods :: class_interface,
@@ -152,7 +152,7 @@
)
; instance(
- ci_deriving_class :: list(class_constraint),
+ ci_deriving_class :: list(prog_constraint),
ci_class_name :: class_name,
ci_types :: list(type),
ci_method_instances :: instance_body,
@@ -795,18 +795,18 @@
% expected semantics.
% (This invariant now applies to all types, but is
% especially important here.)
-:- type class_constraint
+:- type prog_constraint
---> constraint(
class_name,
list(type)
).
-:- type class_constraints
+:- type prog_constraints
---> constraints(
- univ_constraints :: list(class_constraint),
+ univ_constraints :: list(prog_constraint),
% universally quantified
% constraints
- exist_constraints :: list(class_constraint)
+ exist_constraints :: list(prog_constraint)
% existentially quantified
% constraints
).
@@ -844,7 +844,7 @@
maybe(determinism), % any determinism declaration
condition, % any attached declaration
purity, % any purity annotation
- class_constraints, % the typeclass constraints on
+ prog_constraints, % the typeclass constraints on
% the declaration
prog_context % the declaration's context
)
@@ -1237,7 +1237,7 @@
:- type constructor
---> ctor(
cons_exist :: existq_tvars,
- cons_constraints :: list(class_constraint),
+ cons_constraints :: list(prog_constraint),
% existential constraints
cons_name :: sym_name,
cons_args :: list(constructor_arg)
@@ -1309,8 +1309,8 @@
% returned by term__context_init). prog_io_util__convert_type
% ensures this is the case. There are at least two reasons that this
% is required:
- % - Various parts of the code to handle typeclasses creates maps
- % indexed by `class_constraint's, which contain types.
+ % - Various parts of the code to handle typeclasses create maps
+ % indexed by `prog_constraint's, which contain types.
% - Smart recompilation requires that the items which occur in
% interface files can be unified using the builtin unification
% operation.
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.241
diff -u -r1.241 prog_io.m
--- compiler/prog_io.m 22 Mar 2005 06:40:19 -0000 1.241
+++ compiler/prog_io.m 22 Mar 2005 12:23:48 -0000
@@ -2565,7 +2565,7 @@
).
:- func convert_constructor_3(module_name, list(tvar),
- list(class_constraint), term, term) = maybe1(constructor).
+ list(prog_constraint), term, term) = maybe1(constructor).
convert_constructor_3(ModuleName, ExistQVars, Constraints, Term0, Term1) =
Result :-
@@ -2614,7 +2614,7 @@
:- pred process_pred_or_func_2(pred_or_func::in, maybe_functor::in, term::in,
varset::in, maybe(type)::in, maybe(inst)::in, maybe(determinism)::in,
- condition::in, existq_tvars::in, class_constraints::in,
+ condition::in, existq_tvars::in, prog_constraints::in,
inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det.
process_pred_or_func_2(PredOrFunc, ok(F, As0), PredType, VarSet0,
@@ -2697,7 +2697,7 @@
:- pred get_class_context_and_inst_constraints(module_name::in,
decl_attrs::in, decl_attrs::out,
- maybe3(existq_tvars, class_constraints, inst_var_sub)::out) is det.
+ maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det.
get_class_context_and_inst_constraints(ModuleName, RevAttributes0,
RevAttributes, MaybeContext) :-
@@ -2752,7 +2752,7 @@
:- pred combine_quantifier_results(maybe_class_and_inst_constraints::in,
maybe_class_and_inst_constraints::in, existq_tvars::in,
- maybe3(existq_tvars, class_constraints, inst_var_sub)::out) is det.
+ maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det.
combine_quantifier_results(error(Msg, Term), _, _, error(Msg, Term)).
combine_quantifier_results(ok(_, _), error(Msg, Term), _, error(Msg, Term)).
@@ -2805,7 +2805,7 @@
ok(CC0 ++ CC1, IC0 `map__merge` IC1)).
:- pred get_existential_constraints_from_term(module_name::in,
- term::in, term::out, maybe1(list(class_constraint))::out) is det.
+ term::in, term::out, maybe1(list(prog_constraint))::out) is det.
get_existential_constraints_from_term(ModuleName, !PredType,
MaybeExistentialConstraints) :-
@@ -2865,7 +2865,7 @@
).
:- pred process_func_2(module_name::in, varset::in, term::in, condition::in,
- maybe(determinism)::in, existq_tvars::in, class_constraints::in,
+ maybe(determinism)::in, existq_tvars::in, prog_constraints::in,
inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det.
process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet,
@@ -2887,7 +2887,7 @@
:- pred process_func_3(maybe_functor::in, term::in, term::in, term::in,
varset::in, maybe(determinism)::in, condition::in, existq_tvars::in,
- class_constraints::in, inst_var_sub::in, decl_attrs::in,
+ prog_constraints::in, inst_var_sub::in, decl_attrs::in,
maybe1(item)::out) is det.
process_func_3(ok(F, As0), FuncTerm, ReturnTypeTerm, FullTerm, VarSet0,
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.34
diff -u -r1.34 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 22 Mar 2005 06:40:20 -0000 1.34
+++ compiler/prog_io_typeclass.m 22 Mar 2005 12:23:48 -0000
@@ -32,14 +32,14 @@
% parse a list of class constraints
:- pred parse_class_constraints(module_name::in, term::in,
- maybe1(list(class_constraint))::out) is det.
+ maybe1(list(prog_constraint))::out) is det.
% parse a list of class and inst constraints
:- pred parse_class_and_inst_constraints(module_name::in, term::in,
maybe_class_and_inst_constraints::out) is det.
:- type maybe_class_and_inst_constraints ==
- maybe2(list(class_constraint), inst_var_sub).
+ maybe2(list(prog_constraint), inst_var_sub).
:- implementation.
@@ -161,7 +161,7 @@
).
:- pred parse_superclass_constraints(module_name::in, term::in,
- maybe1(list(class_constraint))::out) is det.
+ maybe1(list(prog_constraint))::out) is det.
parse_superclass_constraints(ModuleName, Constraints, Result) :-
parse_simple_class_constraints(ModuleName, Constraints,
@@ -286,7 +286,7 @@
% Parse constraints which can only constrain type variables and ground types.
:- pred parse_simple_class_constraints(module_name::in, term::in, string::in,
- maybe1(list(class_constraint))::out) is det.
+ maybe1(list(prog_constraint))::out) is det.
parse_simple_class_constraints(ModuleName, ConstraintsTerm, ErrorMessage,
Result) :-
@@ -354,7 +354,7 @@
ok(ClassConstraints, InstConstraints ^ elem(InstVar) := Inst).
:- type class_or_inst_constraint
- ---> class_constraint(class_constraint)
+ ---> class_constraint(prog_constraint)
; inst_constraint(inst_var, inst).
:- pred parse_class_or_inst_constraint(module_name::in, term::in,
@@ -388,7 +388,7 @@
convert_inst(no_allow_constrained_inst_var, Arg2, Inst).
:- pred extract_class_constraints(maybe_class_and_inst_constraints::in,
- maybe1(list(class_constraint))::out) is det.
+ maybe1(list(prog_constraint))::out) is det.
extract_class_constraints(ok(ClassConstraints, _), ok(ClassConstraints)).
extract_class_constraints(error(String, Term), error(String, Term)).
@@ -455,7 +455,7 @@
).
:- pred parse_instance_constraints(module_name::in, term::in,
- maybe1(list(class_constraint))::out) is det.
+ maybe1(list(prog_constraint))::out) is det.
parse_instance_constraints(ModuleName, Constraints, Result) :-
parse_simple_class_constraints(ModuleName, Constraints,
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.1
diff -u -r1.1 prog_type.m
--- compiler/prog_type.m 21 Jan 2005 03:27:46 -0000 1.1
+++ compiler/prog_type.m 22 Mar 2005 12:23:48 -0000
@@ -87,15 +87,15 @@
% return the list of type variables contained in a
% list of constraints
%
-:- pred constraint_list_get_tvars(list(class_constraint)::in, list(tvar)::out)
+:- pred constraint_list_get_tvars(list(prog_constraint)::in, list(tvar)::out)
is det.
% constraint_list_get_tvars(Constraint, TVars):
% return the list of type variables contained in a constraint.
%
-:- pred constraint_get_tvars(class_constraint::in, list(tvar)::out) is det.
+:- pred constraint_get_tvars(prog_constraint::in, list(tvar)::out) is det.
-:- pred get_unconstrained_tvars(list(tvar)::in, list(class_constraint)::in,
+:- pred get_unconstrained_tvars(list(tvar)::in, list(prog_constraint)::in,
list(tvar)::out) is det.
%-----------------------------------------------------------------------------%
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.72
diff -u -r1.72 prog_util.m
--- compiler/prog_util.m 22 Mar 2005 06:40:20 -0000 1.72
+++ compiler/prog_util.m 22 Mar 2005 12:23:48 -0000
@@ -17,6 +17,7 @@
:- import_module parse_tree__prog_data.
:- import_module list.
+:- import_module map.
:- import_module std_util.
:- import_module term.
:- import_module varset.
@@ -284,6 +285,35 @@
%-----------------------------------------------------------------------------%
+:- pred apply_rec_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
+ prog_constraints::out) is det.
+
+:- pred apply_rec_subst_to_prog_constraint_list(tsubst::in,
+ list(prog_constraint)::in, list(prog_constraint)::out) is det.
+
+:- pred apply_rec_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
+ prog_constraint::out) is det.
+
+:- pred apply_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
+ prog_constraints::out) is det.
+
+:- pred apply_subst_to_prog_constraint_list(tsubst::in,
+ list(prog_constraint)::in, list(prog_constraint)::out) is det.
+
+:- pred apply_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
+ prog_constraint::out) is det.
+
+:- pred apply_variable_renaming_to_prog_constraints(map(tvar, tvar)::in,
+ prog_constraints::in, prog_constraints::out) is det.
+
+:- pred apply_variable_renaming_to_prog_constraint_list(map(tvar, tvar)::in,
+ list(prog_constraint)::in, list(prog_constraint)::out) is det.
+
+:- pred apply_variable_renaming_to_prog_constraint(map(tvar, tvar)::in,
+ prog_constraint::in, prog_constraint::out) is det.
+
+%-----------------------------------------------------------------------------%
+
:- implementation.
:- import_module parse_tree__mercury_to_mercury.
@@ -292,7 +322,6 @@
:- import_module bool.
:- import_module int.
-:- import_module map.
:- import_module require.
:- import_module string.
:- import_module varset.
@@ -700,6 +729,56 @@
;
error("hlds_pred__get_state_args_det")
).
+
+%-----------------------------------------------------------------------------%
+
+apply_rec_subst_to_prog_constraints(Subst, Constraints0, Constraints) :-
+ Constraints0 = constraints(UnivCs0, ExistCs0),
+ apply_rec_subst_to_prog_constraint_list(Subst, UnivCs0, UnivCs),
+ apply_rec_subst_to_prog_constraint_list(Subst, ExistCs0, ExistCs),
+ Constraints = constraints(UnivCs, ExistCs).
+
+apply_rec_subst_to_prog_constraint_list(Subst, !Constraints) :-
+ list__map(apply_rec_subst_to_prog_constraint(Subst), !Constraints).
+
+apply_rec_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
+ Constraint0 = constraint(ClassName, Types0),
+ term__apply_rec_substitution_to_list(Types0, Subst, Types),
+ Constraint = constraint(ClassName, Types).
+
+apply_subst_to_prog_constraints(Subst,
+ constraints(UniversalCs0, ExistentialCs0),
+ constraints(UniversalCs, ExistentialCs)) :-
+ apply_subst_to_prog_constraint_list(Subst, UniversalCs0, UniversalCs),
+ apply_subst_to_prog_constraint_list(Subst, ExistentialCs0,
+ ExistentialCs).
+
+apply_subst_to_prog_constraint_list(Subst, !Constraints) :-
+ list__map(apply_subst_to_prog_constraint(Subst), !Constraints).
+
+apply_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
+ Constraint0 = constraint(ClassName, Types0),
+ term__apply_substitution_to_list(Types0, Subst, Types),
+ Constraint = constraint(ClassName, Types).
+
+apply_variable_renaming_to_prog_constraints(Renaming, Constraints0,
+ Constraints) :-
+ Constraints0 = constraints(UnivConstraints0, ExistConstraints0),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ UnivConstraints0, UnivConstraints),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ ExistConstraints0, ExistConstraints),
+ Constraints = constraints(UnivConstraints, ExistConstraints).
+
+apply_variable_renaming_to_prog_constraint_list(Renaming, !Constraints) :-
+ list.map(apply_variable_renaming_to_prog_constraint(Renaming),
+ !Constraints).
+
+apply_variable_renaming_to_prog_constraint(Renaming, !Constraint) :-
+ !.Constraint = constraint(ClassName, ClassArgTypes0),
+ term.apply_variable_renaming_to_list(ClassArgTypes0, Renaming,
+ ClassArgTypes),
+ !:Constraint = constraint(ClassName, ClassArgTypes).
%-----------------------------------------------------------------------------%
:- end_module prog_util.
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.17
diff -u -r1.17 recompilation.usage.m
--- compiler/recompilation.usage.m 22 Mar 2005 06:40:22 -0000 1.17
+++ compiler/recompilation.usage.m 22 Mar 2005 12:23:48 -0000
@@ -1489,7 +1489,7 @@
recompilation__usage__find_items_used_by_inst_name(InstName, !Info).
:- pred recompilation__usage__find_items_used_by_class_context(
- class_constraints::in,
+ prog_constraints::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
recompilation__usage__find_items_used_by_class_context(
@@ -1500,7 +1500,7 @@
Constraints2, !Info).
:- pred recompilation__usage__find_items_used_by_class_constraints(
- list(class_constraint)::in,
+ list(prog_constraint)::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
recompilation__usage__find_items_used_by_class_constraints(Constraints,
@@ -1509,7 +1509,7 @@
Constraints, !Info).
:- pred recompilation__usage__find_items_used_by_class_constraint(
- class_constraint::in,
+ prog_constraint::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
recompilation__usage__find_items_used_by_class_constraint(
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.14
diff -u -r1.14 recompilation.version.m
--- compiler/recompilation.version.m 22 Mar 2005 06:40:22 -0000 1.14
+++ compiler/recompilation.version.m 22 Mar 2005 12:23:48 -0000
@@ -794,7 +794,7 @@
%
% Apply a substitution to the existq_tvars, types_and_modes, and
- % class_constraints so that the type variables from both declarations
+ % prog_constraints so that the type variables from both declarations
% being checked are contained in the same tvarset, then check that
% they are identical.
%
@@ -806,9 +806,9 @@
% declaration in a single varset (it doesn't know which are which).
%
:- pred pred_or_func_type_is_unchanged(tvarset::in, existq_tvars::in,
- list(type_and_mode)::in, maybe(type)::in, class_constraints::in,
+ list(type_and_mode)::in, maybe(type)::in, prog_constraints::in,
tvarset::in, existq_tvars::in, list(type_and_mode)::in,
- maybe(type)::in, class_constraints::in) is semidet.
+ maybe(type)::in, prog_constraints::in) is semidet.
pred_or_func_type_is_unchanged(TVarSet1, ExistQVars1, TypesAndModes1,
MaybeWithType1, Constraints1, TVarSet2, ExistQVars2,
@@ -858,9 +858,9 @@
%
% Check that the class constraints are identical.
%
- apply_subst_to_constraints(RenameSubst,
+ apply_subst_to_prog_constraints(RenameSubst,
Constraints2, RenamedConstraints2),
- apply_rec_subst_to_constraints(Types2ToTypes1Subst,
+ apply_rec_subst_to_prog_constraints(Types2ToTypes1Subst,
RenamedConstraints2, SubstConstraints2),
Constraints1 = SubstConstraints2.
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.79
diff -u -r1.79 table_gen.m
--- compiler/table_gen.m 22 Mar 2005 06:40:27 -0000 1.79
+++ compiler/table_gen.m 22 Mar 2005 12:23:48 -0000
@@ -1740,6 +1740,7 @@
pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
pred_info_get_class_context(PredInfo0, ClassContext),
pred_info_get_constraint_proofs(PredInfo0, ClassProofs),
+ pred_info_get_constraint_map(PredInfo0, ClassConstraintMap),
pred_info_get_aditi_owner(PredInfo0, Owner),
pred_info_get_origin(PredInfo0, OrigOrigin),
pred_info_clauses_info(PredInfo0, ClausesInfo),
@@ -1756,8 +1757,8 @@
Origin = transformed(table_generator, OrigOrigin, OrigPredId),
pred_info_init(ModuleName, PredName, Arity, PredOrFunc, Context,
Origin, Status, GoalType, Markers, ArgTypes, TypeVarSet,
- ExistQVars, ClassContext, ClassProofs, Owner, ClausesInfo,
- PredInfo),
+ ExistQVars, ClassContext, ClassProofs, ClassConstraintMap,
+ Owner, ClausesInfo, PredInfo),
ModuleInfo0 = !.TableInfo ^ table_module_info,
module_info_get_predicate_table(ModuleInfo0, PredTable0),
Index: compiler/type_class_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_class_info.m,v
retrieving revision 1.8
diff -u -r1.8 type_class_info.m
--- compiler/type_class_info.m 22 Mar 2005 06:40:29 -0000 1.8
+++ compiler/type_class_info.m 22 Mar 2005 12:23:48 -0000
@@ -30,7 +30,7 @@
:- pred type_class_info__generate_rtti(module_info::in, bool::in,
list(rtti_data)::out) is det.
-:- func generate_class_constraint(class_constraint) = tc_constraint.
+:- func generate_class_constraint(prog_constraint) = tc_constraint.
:- func generate_class_name(class_id) = tc_name.
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.62
diff -u -r1.62 type_ctor_info.m
--- compiler/type_ctor_info.m 22 Mar 2005 06:40:29 -0000 1.62
+++ compiler/type_ctor_info.m 22 Mar 2005 12:23:48 -0000
@@ -834,7 +834,7 @@
% of a functor.
:- pred type_ctor_info__generate_exist_into(list(tvar)::in,
- list(class_constraint)::in, class_table::in, exist_info::out) is det.
+ list(prog_constraint)::in, class_table::in, exist_info::out) is det.
type_ctor_info__generate_exist_into(ExistTvars, Constraints, ClassTable,
ExistInfo) :-
@@ -862,7 +862,7 @@
ExistTvars, ExistLocns),
ExistInfo = exist_info(TIsPlain, TIsInTCIs, TCConstraints, ExistLocns).
-:- pred find_type_info_index(list(class_constraint)::in, class_table::in,
+:- pred find_type_info_index(list(prog_constraint)::in, class_table::in,
int::in, tvar::in, map(tvar, exist_typeinfo_locn)::in,
map(tvar, exist_typeinfo_locn)::out) is det.
@@ -879,8 +879,8 @@
Locn = typeinfo_in_tci(Slot, RealTypeInfoIndex),
map__det_insert(LocnMap0, Tvar, Locn, LocnMap).
-:- pred first_matching_type_class_info(list(class_constraint)::in, tvar::in,
- class_constraint::out, int::in, int::out, int::out) is det.
+:- pred first_matching_type_class_info(list(prog_constraint)::in, tvar::in,
+ prog_constraint::out, int::in, int::out, int::out) is det.
first_matching_type_class_info([], _, _, _, _, _) :-
error("first_matching_type_class_info: not found").
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.148
diff -u -r1.148 type_util.m
--- compiler/type_util.m 22 Mar 2005 06:40:29 -0000 1.148
+++ compiler/type_util.m 22 Mar 2005 12:23:48 -0000
@@ -289,7 +289,7 @@
---> ctor_defn(
tvarset,
existq_tvars,
- list(class_constraint), % existential constraints
+ list(prog_constraint), % existential constraints
list(type), % functor argument types
(type) % functor result type
).
@@ -394,53 +394,63 @@
tsubst::in, map(tvar, type)::in, map(prog_var, prog_var)::in,
map(tvar, type_info_locn)::out) is det.
- % Update a map from class_constraint to var, using the type renaming
+ % Update a map from prog_constraint to var, using the type renaming
% and substitution to rename tvars and a variable substition to
% rename vars. The type renaming is applied before the type
% substitution.
%
:- pred apply_substitutions_to_typeclass_var_map(
- map(class_constraint, prog_var)::in, tsubst::in, map(tvar, type)::in,
- map(prog_var, prog_var)::in, map(class_constraint, prog_var)::out)
+ typeclass_info_varmap::in, tsubst::in, map(tvar, type)::in,
+ map(prog_var, prog_var)::in, typeclass_info_varmap::out)
is det.
-:- pred apply_rec_subst_to_constraints(tsubst::in, class_constraints::in,
- class_constraints::out) is det.
+:- pred apply_rec_subst_to_constraints(tsubst::in, hlds_constraints::in,
+ hlds_constraints::out) is det.
:- pred apply_rec_subst_to_constraint_list(tsubst::in,
- list(class_constraint)::in, list(class_constraint)::out) is det.
+ list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
-:- pred apply_rec_subst_to_constraint(tsubst::in, class_constraint::in,
- class_constraint::out) is det.
+:- pred apply_rec_subst_to_constraint(tsubst::in, hlds_constraint::in,
+ hlds_constraint::out) is det.
-:- pred apply_subst_to_constraints(tsubst::in, class_constraints::in,
- class_constraints::out) is det.
+:- pred apply_subst_to_constraints(tsubst::in, hlds_constraints::in,
+ hlds_constraints::out) is det.
-:- pred apply_subst_to_constraint_list(tsubst::in, list(class_constraint)::in,
- list(class_constraint)::out) is det.
+:- pred apply_subst_to_constraint_list(tsubst::in, list(hlds_constraint)::in,
+ list(hlds_constraint)::out) is det.
-:- pred apply_subst_to_constraint(tsubst::in, class_constraint::in,
- class_constraint::out) is det.
+:- pred apply_subst_to_constraint(tsubst::in, hlds_constraint::in,
+ hlds_constraint::out) is det.
:- pred apply_subst_to_constraint_proofs(tsubst::in,
- map(class_constraint, constraint_proof)::in,
- map(class_constraint, constraint_proof)::out) is det.
+ constraint_proof_map::in, constraint_proof_map::out) is det.
:- pred apply_rec_subst_to_constraint_proofs(tsubst::in,
- map(class_constraint, constraint_proof)::in,
- map(class_constraint, constraint_proof)::out) is det.
+ constraint_proof_map::in, constraint_proof_map::out) is det.
+
+:- pred apply_subst_to_constraint_map(tsubst::in,
+ constraint_map::in, constraint_map::out) is det.
+
+:- pred apply_rec_subst_to_constraint_map(tsubst::in,
+ constraint_map::in, constraint_map::out) is det.
:- pred apply_variable_renaming_to_type_map(map(tvar, tvar)::in,
vartypes::in, vartypes::out) is det.
:- pred apply_variable_renaming_to_constraints(map(tvar, tvar)::in,
- class_constraints::in, class_constraints::out) is det.
+ hlds_constraints::in, hlds_constraints::out) is det.
:- pred apply_variable_renaming_to_constraint_list(map(tvar, tvar)::in,
- list(class_constraint)::in, list(class_constraint)::out) is det.
+ list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
:- pred apply_variable_renaming_to_constraint(map(tvar, tvar)::in,
- class_constraint::in, class_constraint::out) is det.
+ hlds_constraint::in, hlds_constraint::out) is det.
+
+:- pred apply_variable_renaming_to_constraint_proofs(map(tvar, tvar)::in,
+ constraint_proof_map::in, constraint_proof_map::out) is det.
+
+:- pred apply_variable_renaming_to_constraint_map(map(tvar, tvar)::in,
+ constraint_map::in, constraint_map::out) is det.
% Apply a renaming (partial map) to a list.
% Useful for applying a variable renaming to a list of variables.
@@ -1651,13 +1661,13 @@
:- pred apply_substitutions_to_typeclass_var_map_2(tsubst::in,
map(tvar, type)::in, map(prog_var, prog_var)::in,
- pair(class_constraint, prog_var)::in,
- pair(class_constraint, prog_var)::out) is det.
+ pair(prog_constraint, prog_var)::in,
+ pair(prog_constraint, prog_var)::out) is det.
apply_substitutions_to_typeclass_var_map_2(TRenaming, TSubst, VarRenaming,
Constraint0 - Var0, Constraint - Var) :-
- apply_subst_to_constraint(TRenaming, Constraint0, Constraint1),
- apply_rec_subst_to_constraint(TSubst, Constraint1, Constraint),
+ apply_subst_to_prog_constraint(TRenaming, Constraint0, Constraint1),
+ apply_rec_subst_to_prog_constraint(TSubst, Constraint1, Constraint),
( map__search(VarRenaming, Var0, Var1) ->
Var = Var1
;
@@ -1666,19 +1676,19 @@
%-----------------------------------------------------------------------------%
-apply_rec_subst_to_constraints(Subst, Constraints0, Constraints) :-
- Constraints0 = constraints(UnivCs0, ExistCs0),
+apply_rec_subst_to_constraints(Subst, !Constraints) :-
+ !.Constraints = constraints(UnivCs0, ExistCs0),
apply_rec_subst_to_constraint_list(Subst, UnivCs0, UnivCs),
apply_rec_subst_to_constraint_list(Subst, ExistCs0, ExistCs),
- Constraints = constraints(UnivCs, ExistCs).
+ !:Constraints = constraints(UnivCs, ExistCs).
apply_rec_subst_to_constraint_list(Subst, !Constraints) :-
list__map(apply_rec_subst_to_constraint(Subst), !Constraints).
-apply_rec_subst_to_constraint(Subst, Constraint0, Constraint) :-
- Constraint0 = constraint(ClassName, Types0),
- term__apply_rec_substitution_to_list(Types0, Subst, Types),
- Constraint = constraint(ClassName, Types).
+apply_rec_subst_to_constraint(Subst, !Constraint) :-
+ !.Constraint = constraint(Ids, Name, Types0),
+ term.apply_rec_substitution_to_list(Types0, Subst, Types),
+ !:Constraint = constraint(Ids, Name, Types).
apply_subst_to_constraints(Subst,
constraints(UniversalCs0, ExistentialCs0),
@@ -1690,27 +1700,26 @@
list__map(apply_subst_to_constraint(Subst), Constraints0, Constraints).
apply_subst_to_constraint(Subst, Constraint0, Constraint) :-
- Constraint0 = constraint(ClassName, Types0),
+ Constraint0 = constraint(Ids, ClassName, Types0),
term__apply_substitution_to_list(Types0, Subst, Types),
- Constraint = constraint(ClassName, Types).
+ Constraint = constraint(Ids, ClassName, Types).
apply_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :-
map__foldl(apply_subst_to_constraint_proofs_2(Subst), Proofs0,
map__init, Proofs).
:- pred apply_subst_to_constraint_proofs_2(tsubst::in,
- class_constraint::in, constraint_proof::in,
- map(class_constraint, constraint_proof)::in,
- map(class_constraint, constraint_proof)::out) is det.
+ prog_constraint::in, constraint_proof::in,
+ constraint_proof_map::in, constraint_proof_map::out) is det.
apply_subst_to_constraint_proofs_2(Subst, Constraint0, Proof0, Map0, Map) :-
- apply_subst_to_constraint(Subst, Constraint0, Constraint),
+ apply_subst_to_prog_constraint(Subst, Constraint0, Constraint),
(
Proof0 = apply_instance(_),
Proof = Proof0
;
Proof0 = superclass(Super0),
- apply_subst_to_constraint(Subst, Super0, Super),
+ apply_subst_to_prog_constraint(Subst, Super0, Super),
Proof = superclass(Super)
),
map__set(Map0, Constraint, Proof, Map).
@@ -1720,22 +1729,41 @@
map__init, Proofs).
:- pred apply_rec_subst_to_constraint_proofs_2(tsubst::in,
- class_constraint::in, constraint_proof::in,
- map(class_constraint, constraint_proof)::in,
- map(class_constraint, constraint_proof)::out) is det.
+ prog_constraint::in, constraint_proof::in,
+ constraint_proof_map::in, constraint_proof_map::out) is det.
apply_rec_subst_to_constraint_proofs_2(Subst, Constraint0, Proof0, Map0, Map) :-
- apply_rec_subst_to_constraint(Subst, Constraint0, Constraint),
+ apply_rec_subst_to_prog_constraint(Subst, Constraint0, Constraint),
(
Proof0 = apply_instance(_),
Proof = Proof0
;
Proof0 = superclass(Super0),
- apply_rec_subst_to_constraint(Subst, Super0, Super),
+ apply_rec_subst_to_prog_constraint(Subst, Super0, Super),
Proof = superclass(Super)
),
map__set(Map0, Constraint, Proof, Map).
+apply_subst_to_constraint_map(Subst, !ConstraintMap) :-
+ map__map_values(apply_subst_to_constraint_map_2(Subst),
+ !ConstraintMap).
+
+:- pred apply_subst_to_constraint_map_2(tsubst::in, constraint_id::in,
+ prog_constraint::in, prog_constraint::out) is det.
+
+apply_subst_to_constraint_map_2(Subst, _Key, !Value) :-
+ apply_subst_to_prog_constraint(Subst, !Value).
+
+apply_rec_subst_to_constraint_map(Subst, !ConstraintMap) :-
+ map__map_values(apply_rec_subst_to_constraint_map_2(Subst),
+ !ConstraintMap).
+
+:- pred apply_rec_subst_to_constraint_map_2(tsubst::in, constraint_id::in,
+ prog_constraint::in, prog_constraint::out) is det.
+
+apply_rec_subst_to_constraint_map_2(Subst, _Key, !Value) :-
+ apply_rec_subst_to_prog_constraint(Subst, !Value).
+
apply_variable_renaming_to_type_map(Renaming, Map0, Map) :-
map__map_values(
(pred(_::in, Type0::in, Type::out) is det :-
@@ -1755,10 +1783,44 @@
!Constraints).
apply_variable_renaming_to_constraint(Renaming, Constraint0, Constraint) :-
- Constraint0 = constraint(ClassName, ClassArgTypes0),
+ Constraint0 = constraint(Ids, ClassName, ClassArgTypes0),
term__apply_variable_renaming_to_list(ClassArgTypes0,
Renaming, ClassArgTypes),
- Constraint = constraint(ClassName, ClassArgTypes).
+ Constraint = constraint(Ids, ClassName, ClassArgTypes).
+
+apply_variable_renaming_to_constraint_proofs(Renaming, Proofs0, Proofs) :-
+ ( map__is_empty(Proofs0) ->
+ % optimize simple case
+ Proofs = Proofs0
+ ;
+ map__keys(Proofs0, Keys0),
+ map__values(Proofs0, Values0),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ Keys0, Keys),
+ list__map(rename_constraint_proof(Renaming), Values0, Values),
+ map__from_corresponding_lists(Keys, Values, Proofs)
+ ).
+
+:- pred rename_constraint_proof(map(tvar, tvar)::in, constraint_proof::in,
+ constraint_proof::out) is det.
+
+% apply a type variable renaming to a class constraint proof
+
+rename_constraint_proof(_TSubst, apply_instance(Num), apply_instance(Num)).
+rename_constraint_proof(TSubst, superclass(ClassConstraint0),
+ superclass(ClassConstraint)) :-
+ apply_variable_renaming_to_prog_constraint(TSubst, ClassConstraint0,
+ ClassConstraint).
+
+apply_variable_renaming_to_constraint_map(Renaming, !ConstraintMap) :-
+ map__map_values(apply_variable_renaming_to_constraint_map_2(Renaming),
+ !ConstraintMap).
+
+:- pred apply_variable_renaming_to_constraint_map_2(map(tvar, tvar)::in,
+ constraint_id::in, prog_constraint::in, prog_constraint::out) is det.
+
+apply_variable_renaming_to_constraint_map_2(Renaming, _Key, !Value) :-
+ apply_variable_renaming_to_prog_constraint(Renaming, !Value).
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
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