[m-dev.] for review: fix polymorphism bug
David Glen JEFFERY
dgj at cs.mu.OZ.AU
Wed Feb 7 17:23:36 AEDT 2001
Hi,
This is for Fergus to review.
-----------------------------------------------------------------------------
Estimated hours taken: 12
Fix a bug reported by petdr on October 30th last year.
compiler/polymorphism.m:
When looking up the variable which contains a typeclass info for
a particular constraint to be passed to a call, handle the case where
there is *no* variable for such a constraint. This occurs in the case
where the producer of the variable occurs later on in the goal (but
will get re-ordered by the mode checker). The solution is to just
create a variable for the typeclass info, and whenever creating
a `head' variable to hold a constraint being produced by a call,
check first whether there is already a variable allocated for that
constraint.
tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/reordered_existential_constraint.exp:
tests/hard_coded/typeclasses/reordered_existential_constraint.m:
A test case for this. (Not the same as petdr's original test case,
but much simpler and exhibits the same bug).
-----------------------------------------------------------------------------
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.205
diff -u -t -r1.205 polymorphism.m
--- compiler/polymorphism.m 2001/01/15 07:15:31 1.205
+++ compiler/polymorphism.m 2001/02/06 04:00:47
@@ -861,7 +861,7 @@
% for unconstrained, universally quantified type variables.
% to the initial tvar->type_info_var mapping
%
- ToLocn = lambda([TheVar::in, TheLocn::out] is det,
+ ToLocn = (pred(TheVar::in, TheLocn::out) is det :-
TheLocn = type_info(TheVar)),
list__map(ToLocn, UnivHeadTypeInfoVars, UnivTypeLocns),
@@ -2087,8 +2087,7 @@
Info1, Info).
:- pred polymorphism__make_typeclass_info_var(class_constraint,
- existq_tvars, prog_context,
- list(hlds_goal), list(hlds_goal),
+ existq_tvars, prog_context, list(hlds_goal), list(hlds_goal),
poly_info, poly_info, maybe(prog_var)).
:- mode polymorphism__make_typeclass_info_var(in, in, in, in, out,
in, out, out) is det.
@@ -2096,247 +2095,270 @@
polymorphism__make_typeclass_info_var(Constraint, ExistQVars,
Context, ExtraGoals0, ExtraGoals,
Info0, Info, MaybeVar) :-
- Constraint = constraint(ClassName, ConstrainedTypes),
- list__length(ConstrainedTypes, ClassArity),
- ClassId = class_id(ClassName, ClassArity),
-
- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
- TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
-
(
- map__search(TypeClassInfoMap0, Constraint, Location)
+ map__search(Info0^typeclass_info_map, Constraint, Location)
->
- % We already have a typeclass_info for this constraint
+ % We already have a typeclass_info for this constraint,
+ % either from a parameter to the pred or from an
+ % existentially quantified goal that we have already
+ % processed.
+
ExtraGoals = ExtraGoals0,
Var = Location,
MaybeVar = yes(Var),
Info = Info0
;
- % We don't have the typeclass_info as a parameter to
- % the pred, so we must be able to create it from
- % somewhere else
+ % We don't have the typeclass_info, we must either have
+ % a proof that tells us how to make it, or it will be
+ % produced by an existentially typed goal that we
+ % will process later on.
+
+ map__search(Info0^proof_map, Constraint, Proof)
+ ->
+ polymorphism__make_typeclass_info_from_proof(Constraint, Proof,
+ ExistQVars, Context, MaybeVar, ExtraGoals0, ExtraGoals,
+ Info0, Info)
+ ;
+ polymorphism__make_typeclass_info_head_var(Constraint,
+ NewVar, Info0, Info1),
+ map__det_insert(Info1^typeclass_info_map, Constraint, NewVar,
+ NewTypeClassInfoMap),
+ Info = (Info1^typeclass_info_map := NewTypeClassInfoMap),
+ MaybeVar = yes(NewVar),
+ ExtraGoals = ExtraGoals0
+ ).
+
+:- pred polymorphism__make_typeclass_info_from_proof(class_constraint,
+ constraint_proof, existq_tvars, prog_context, maybe(prog_var),
+ list(hlds_goal), list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_from_proof(in, in, in, in, out,
+ in, out, in, out) is det.
- % Work out how to make it
- map__lookup(Proofs, Constraint, Proof),
+polymorphism__make_typeclass_info_from_proof(Constraint, Proof, ExistQVars,
+ Context, MaybeVar, ExtraGoals0, ExtraGoals, Info0, Info) :-
+ Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
+ TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
+ Constraint = constraint(ClassName, ConstrainedTypes),
+ list__length(ConstrainedTypes, ClassArity),
+ ClassId = class_id(ClassName, ClassArity),
+ (
+ % We have to construct the typeclass_info
+ % using an instance declaration
+ Proof = apply_instance(InstanceNum),
+
+ module_info_instances(ModuleInfo, InstanceTable),
+ map__lookup(InstanceTable, ClassId, InstanceList),
+ list__index1_det(InstanceList, InstanceNum,
+ ProofInstanceDefn),
+
+ ProofInstanceDefn = hlds_instance_defn(_, _, _,
+ InstanceConstraints0, InstanceTypes0, _, _,
+ InstanceTVarset, SuperClassProofs0),
+
+ term__vars_list(InstanceTypes0, InstanceTvars),
+ get_unconstrained_tvars(InstanceTvars,
+ InstanceConstraints0, UnconstrainedTvars0),
+
+ % We can ignore the typevarset because all the
+ % type variables that are created are bound
+ % when we call type_list_subsumes then apply
+ % the resulting bindings.
+ varset__merge_subst(TypeVarSet, InstanceTVarset,
+ _NewTVarset, RenameSubst),
+ term__apply_substitution_to_list(InstanceTypes0,
+ RenameSubst, InstanceTypes),
(
- % We have to construct the typeclass_info
- % using an instance declaration
- Proof = apply_instance(InstanceNum),
-
- module_info_instances(ModuleInfo, InstanceTable),
- map__lookup(InstanceTable, ClassId, InstanceList),
- list__index1_det(InstanceList, InstanceNum,
- ProofInstanceDefn),
-
- ProofInstanceDefn = hlds_instance_defn(_, _, _,
- InstanceConstraints0, InstanceTypes0, _, _,
- InstanceTVarset, SuperClassProofs0),
-
- term__vars_list(InstanceTypes0, InstanceTvars),
- get_unconstrained_tvars(InstanceTvars,
- InstanceConstraints0, UnconstrainedTvars0),
-
- % We can ignore the typevarset because all the
- % type variables that are created are bound
- % when we call type_list_subsumes then apply
- % the resulting bindings.
- 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(InstanceTypes,
+ ConstrainedTypes, InstanceSubst0)
+ ->
+ InstanceSubst = InstanceSubst0
+ ;
+ error("poly: wrong instance decl")
+ ),
- apply_subst_to_constraint_list(RenameSubst,
- InstanceConstraints0, InstanceConstraints1),
- apply_rec_subst_to_constraint_list(InstanceSubst,
- InstanceConstraints1, InstanceConstraints),
- apply_subst_to_constraint_proofs(RenameSubst,
- SuperClassProofs0, SuperClassProofs1),
- apply_rec_subst_to_constraint_proofs(InstanceSubst,
- SuperClassProofs1, SuperClassProofs2),
-
- term__var_list_to_term_list(UnconstrainedTvars0,
- UnconstrainedTypes0),
- term__apply_substitution_to_list(UnconstrainedTypes0,
- RenameSubst, UnconstrainedTypes1),
- term__apply_rec_substitution_to_list(
- UnconstrainedTypes1, InstanceSubst,
- UnconstrainedTypes),
-
- map__overlay(Proofs, SuperClassProofs2,
- SuperClassProofs),
-
- % Make the type_infos for the types
- % that are constrained by this. These
- % are packaged in the typeclass_info
- polymorphism__make_type_info_vars(
- ConstrainedTypes, Context,
- InstanceExtraTypeInfoVars, TypeInfoGoals,
- Info0, Info1),
-
- % Make the typeclass_infos for the
- % constraints from the context of the
- % instance decl.
- polymorphism__make_typeclass_info_vars_2(
- InstanceConstraints,
- ExistQVars, Context,
- [], InstanceExtraTypeClassInfoVars0,
- ExtraGoals0, ExtraGoals1,
- Info1, Info2),
-
- % Make the type_infos for the unconstrained
- % type variables from the head of the
- % instance declaration
- polymorphism__make_type_info_vars(
- UnconstrainedTypes, Context,
- InstanceExtraTypeInfoUnconstrainedVars,
- UnconstrainedTypeInfoGoals,
- Info2, Info3),
-
- % The variables are built up in
- % reverse order.
- list__reverse(InstanceExtraTypeClassInfoVars0,
- InstanceExtraTypeClassInfoVars),
-
- polymorphism__construct_typeclass_info(
- InstanceExtraTypeInfoUnconstrainedVars,
- InstanceExtraTypeInfoVars,
- InstanceExtraTypeClassInfoVars,
- ClassId, Constraint, InstanceNum,
- ConstrainedTypes,
- SuperClassProofs, ExistQVars, Var, NewGoals,
- Info3, Info),
-
- MaybeVar = yes(Var),
-
- % Oh, yuck. The type_info goals have
- % already been reversed, so lets
- % reverse them back.
- list__reverse(TypeInfoGoals, RevTypeInfoGoals),
- list__reverse(UnconstrainedTypeInfoGoals,
- RevUnconstrainedTypeInfoGoals),
-
- list__condense([RevUnconstrainedTypeInfoGoals,
- NewGoals, ExtraGoals1, RevTypeInfoGoals],
- ExtraGoals)
+ apply_subst_to_constraint_list(RenameSubst,
+ InstanceConstraints0, InstanceConstraints1),
+ apply_rec_subst_to_constraint_list(InstanceSubst,
+ InstanceConstraints1, InstanceConstraints),
+ apply_subst_to_constraint_proofs(RenameSubst,
+ SuperClassProofs0, SuperClassProofs1),
+ apply_rec_subst_to_constraint_proofs(InstanceSubst,
+ SuperClassProofs1, SuperClassProofs2),
+
+ term__var_list_to_term_list(UnconstrainedTvars0,
+ UnconstrainedTypes0),
+ term__apply_substitution_to_list(UnconstrainedTypes0,
+ RenameSubst, UnconstrainedTypes1),
+ term__apply_rec_substitution_to_list(
+ UnconstrainedTypes1, InstanceSubst,
+ UnconstrainedTypes),
+
+ map__overlay(Proofs, SuperClassProofs2,
+ SuperClassProofs),
+
+ % Make the type_infos for the types
+ % that are constrained by this. These
+ % are packaged in the typeclass_info
+ polymorphism__make_type_info_vars(
+ ConstrainedTypes, Context,
+ InstanceExtraTypeInfoVars, TypeInfoGoals,
+ Info0, Info1),
+
+ % Make the typeclass_infos for the
+ % constraints from the context of the
+ % instance decl.
+ polymorphism__make_typeclass_info_vars_2(
+ InstanceConstraints,
+ ExistQVars, Context,
+ [], InstanceExtraTypeClassInfoVars0,
+ ExtraGoals0, ExtraGoals1,
+ Info1, Info2),
+
+ % Make the type_infos for the unconstrained
+ % type variables from the head of the
+ % instance declaration
+ polymorphism__make_type_info_vars(
+ UnconstrainedTypes, Context,
+ InstanceExtraTypeInfoUnconstrainedVars,
+ UnconstrainedTypeInfoGoals,
+ Info2, Info3),
+
+ % The variables are built up in
+ % reverse order.
+ list__reverse(InstanceExtraTypeClassInfoVars0,
+ InstanceExtraTypeClassInfoVars),
+
+ polymorphism__construct_typeclass_info(
+ InstanceExtraTypeInfoUnconstrainedVars,
+ InstanceExtraTypeInfoVars,
+ InstanceExtraTypeClassInfoVars,
+ ClassId, Constraint, InstanceNum,
+ ConstrainedTypes,
+ SuperClassProofs, ExistQVars, Var, NewGoals,
+ Info3, Info),
+
+ MaybeVar = yes(Var),
+
+ % Oh, yuck. The type_info goals have
+ % already been reversed, so lets
+ % reverse them back.
+ list__reverse(TypeInfoGoals, RevTypeInfoGoals),
+ list__reverse(UnconstrainedTypeInfoGoals,
+ RevUnconstrainedTypeInfoGoals),
+
+ list__condense([RevUnconstrainedTypeInfoGoals,
+ NewGoals, ExtraGoals1, RevTypeInfoGoals],
+ ExtraGoals)
+ ;
+ % We have to extract the typeclass_info from
+ % another one
+ Proof = superclass(SubClassConstraint),
+
+ % First create a variable to hold the new
+ % typeclass_info
+ unqualify_name(ClassName, ClassNameString),
+ polymorphism__new_typeclass_info_var(VarSet0,
+ VarTypes0, Constraint, ClassNameString,
+ Var, VarSet1, VarTypes1),
+
+ MaybeVar = yes(Var),
+
+ % Then work out where to extract it from
+ SubClassConstraint =
+ constraint(SubClassName, SubClassTypes),
+ list__length(SubClassTypes, SubClassArity),
+ SubClassId = class_id(SubClassName, SubClassArity),
+
+ Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet,
+ TypeInfoMap0, TypeClassInfoMap0, Proofs,
+ PredName, ModuleInfo),
+
+ % Make the typeclass_info for the subclass
+ polymorphism__make_typeclass_info_var(
+ SubClassConstraint,
+ ExistQVars, Context,
+ ExtraGoals0, ExtraGoals1,
+ Info1, Info2,
+ MaybeSubClassVar),
+ ( MaybeSubClassVar = yes(SubClassVar0) ->
+ SubClassVar = SubClassVar0
;
- % We have to extract the typeclass_info from
- % another one
- Proof = superclass(SubClassConstraint),
-
- % First create a variable to hold the new
- % typeclass_info
- unqualify_name(ClassName, ClassNameString),
- polymorphism__new_typeclass_info_var(VarSet0,
- VarTypes0, Constraint, ClassNameString,
- Var, VarSet1, VarTypes1),
-
- MaybeVar = yes(Var),
-
- % Then work out where to extract it from
- SubClassConstraint =
- constraint(SubClassName, SubClassTypes),
- list__length(SubClassTypes, SubClassArity),
- SubClassId = class_id(SubClassName, SubClassArity),
-
- Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet,
- TypeInfoMap0, TypeClassInfoMap0, Proofs,
- PredName, ModuleInfo),
-
- % Make the typeclass_info for the subclass
- polymorphism__make_typeclass_info_var(
- SubClassConstraint,
- ExistQVars, Context,
- ExtraGoals0, ExtraGoals1,
- Info1, Info2,
- MaybeSubClassVar),
- ( MaybeSubClassVar = yes(SubClassVar0) ->
- SubClassVar = SubClassVar0
- ;
- error("MaybeSubClassVar = no")
- ),
+ error("MaybeSubClassVar = no")
+ ),
- % Look up the definition of the subclass
- module_info_classes(ModuleInfo, ClassTable),
- map__lookup(ClassTable, SubClassId, SubClassDefn),
- SubClassDefn = hlds_class_defn(_, SuperClasses0,
- SubClassVars, _, _, _, _),
-
- % Work out which superclass typeclass_info to
- % take
- map__from_corresponding_lists(SubClassVars,
- SubClassTypes, SubTypeSubst),
- apply_subst_to_constraint_list(SubTypeSubst,
- SuperClasses0, SuperClasses),
- (
- list__nth_member_search(SuperClasses,
- Constraint, SuperClassIndex0)
- ->
- SuperClassIndex0 = SuperClassIndex
- ;
- % We shouldn't have got this far if
- % the constraints were not satisfied
- error("polymorphism.m: constraint not in constraint list")
+ % Look up the definition of the subclass
+ module_info_classes(ModuleInfo, ClassTable),
+ map__lookup(ClassTable, SubClassId, SubClassDefn),
+ SubClassDefn = hlds_class_defn(_, SuperClasses0,
+ SubClassVars, _, _, _, _),
+
+ % Work out which superclass typeclass_info to
+ % take
+ map__from_corresponding_lists(SubClassVars,
+ SubClassTypes, SubTypeSubst),
+ apply_subst_to_constraint_list(SubTypeSubst,
+ SuperClasses0, SuperClasses),
+ (
+ list__nth_member_search(SuperClasses,
+ Constraint, SuperClassIndex0)
+ ->
+ SuperClassIndex0 = SuperClassIndex
+ ;
+ % We shouldn't have got this far if
+ % the constraints were not satisfied
+ error("polymorphism.m: constraint not in constraint list")
+ ),
+
+ poly_info_get_varset(Info2, VarSet2),
+ poly_info_get_var_types(Info2, VarTypes2),
+ polymorphism__make_count_var(SuperClassIndex, VarSet2,
+ VarTypes2, IndexVar, IndexGoal, VarSet,
+ VarTypes),
+ poly_info_set_varset_and_types(VarSet, VarTypes,
+ Info2, Info),
+
+ % We extract the superclass typeclass_info by
+ % inserting a call to
+ % superclass_from_typeclass_info in
+ % private_builtin.
+ % Note that superclass_from_typeclass_info
+ % does not need extra type_info arguments
+ % even though its declaration is polymorphic.
+
+ % Make the goal for the call
+ varset__init(DummyTVarSet0),
+ varset__new_var(DummyTVarSet0, TCVar,
+ DummyTVarSet),
+ mercury_private_builtin_module(PrivateBuiltin),
+ ExtractSuperClass = qualified(PrivateBuiltin,
+ "superclass_from_typeclass_info"),
+ construct_type(qualified(PrivateBuiltin,
+ "typeclass_info") - 1,
+ [term__variable(TCVar)],
+ TypeClassInfoType),
+ construct_type(unqualified("int") - 0, [], IntType),
+ get_pred_id_and_proc_id(ExtractSuperClass, predicate,
+ DummyTVarSet,
+ [TypeClassInfoType, IntType, TypeClassInfoType],
+ ModuleInfo, PredId, ProcId),
+ Call = call(PredId, ProcId,
+ [SubClassVar, IndexVar, Var],
+ not_builtin, no,
+ ExtractSuperClass
),
- poly_info_get_varset(Info2, VarSet2),
- poly_info_get_var_types(Info2, VarTypes2),
- polymorphism__make_count_var(SuperClassIndex, VarSet2,
- VarTypes2, IndexVar, IndexGoal, VarSet,
- VarTypes),
- poly_info_set_varset_and_types(VarSet, VarTypes,
- Info2, Info),
-
- % We extract the superclass typeclass_info by
- % inserting a call to
- % superclass_from_typeclass_info in
- % private_builtin.
- % Note that superclass_from_typeclass_info
- % does not need extra type_info arguments
- % even though its declaration is polymorphic.
-
- % Make the goal for the call
- varset__init(DummyTVarSet0),
- varset__new_var(DummyTVarSet0, TCVar,
- DummyTVarSet),
- mercury_private_builtin_module(PrivateBuiltin),
- ExtractSuperClass = qualified(PrivateBuiltin,
- "superclass_from_typeclass_info"),
- construct_type(qualified(PrivateBuiltin,
- "typeclass_info") - 1,
- [term__variable(TCVar)],
- TypeClassInfoType),
- construct_type(unqualified("int") - 0, [], IntType),
- get_pred_id_and_proc_id(ExtractSuperClass, predicate,
- DummyTVarSet,
- [TypeClassInfoType, IntType, TypeClassInfoType],
- ModuleInfo, PredId, ProcId),
- Call = call(PredId, ProcId,
- [SubClassVar, IndexVar, Var],
- not_builtin, no,
- ExtractSuperClass
- ),
-
- % Make the goal info for the call
- set__list_to_set([SubClassVar, IndexVar, Var],
- NonLocals),
- goal_info_init(GoalInfo0),
- goal_info_set_nonlocals(GoalInfo0, NonLocals,
- GoalInfo),
+ % Make the goal info for the call
+ set__list_to_set([SubClassVar, IndexVar, Var],
+ NonLocals),
+ goal_info_init(GoalInfo0),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals,
+ GoalInfo),
- % Put them together
- SuperClassGoal = Call - GoalInfo,
+ % Put them together
+ SuperClassGoal = Call - GoalInfo,
- % Add it to the accumulator
- ExtraGoals = [SuperClassGoal,IndexGoal|ExtraGoals1]
- )
+ % Add it to the accumulator
+ ExtraGoals = [SuperClassGoal,IndexGoal|ExtraGoals1]
).
:- pred polymorphism__construct_typeclass_info(list(prog_var), list(prog_var),
@@ -3051,89 +3073,90 @@
is det.
polymorphism__make_typeclass_info_head_vars(Constraints, ExtraHeadVars) -->
- { ExtraHeadVars0 = [] },
- polymorphism__make_typeclass_info_head_vars_2(Constraints,
- ExtraHeadVars0, ExtraHeadVars1),
- { list__reverse(ExtraHeadVars1, ExtraHeadVars) }.
-
-:- pred polymorphism__make_typeclass_info_head_vars_2(list(class_constraint),
- list(prog_var), list(prog_var), poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_head_vars_2(in, in, out, in, out)
- is det.
+ list__map_foldl(polymorphism__make_typeclass_info_head_var,
+ Constraints, ExtraHeadVars).
-polymorphism__make_typeclass_info_head_vars_2([],
- ExtraHeadVars, ExtraHeadVars) --> [].
-polymorphism__make_typeclass_info_head_vars_2([C|Cs],
- ExtraHeadVars0, ExtraHeadVars, Info0, Info) :-
+:- pred polymorphism__make_typeclass_info_head_var(class_constraint,
+ prog_var, poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_head_var(in, out, in, out) is det.
- poly_info_get_varset(Info0, VarSet0),
- poly_info_get_var_types(Info0, VarTypes0),
- poly_info_get_type_info_map(Info0, TypeInfoMap0),
- poly_info_get_module_info(Info0, ModuleInfo),
+polymorphism__make_typeclass_info_head_var(C, ExtraHeadVar, Info0, Info) :-
- C = constraint(ClassName0, ClassTypes),
+ poly_info_get_typeclass_info_map(Info0, TypeClassInfoMap),
+ (
+ map__search(TypeClassInfoMap, C, ExistingVar)
+ ->
+ ExtraHeadVar = ExistingVar,
+ Info = Info0
+ ;
+ poly_info_get_varset(Info0, VarSet0),
+ poly_info_get_var_types(Info0, VarTypes0),
+ poly_info_get_type_info_map(Info0, TypeInfoMap0),
+ poly_info_get_module_info(Info0, ModuleInfo),
- % Work out how many superclass the class has
- list__length(ClassTypes, ClassArity),
- ClassId = class_id(ClassName0, ClassArity),
- module_info_classes(ModuleInfo, ClassTable),
- map__lookup(ClassTable, ClassId, ClassDefn),
- ClassDefn = hlds_class_defn(_, SuperClasses, _, _, _, _, _),
- list__length(SuperClasses, NumSuperClasses),
+ C = constraint(ClassName0, ClassTypes),
- unqualify_name(ClassName0, ClassName),
+ % Work out how many superclass the class has
+ list__length(ClassTypes, ClassArity),
+ ClassId = class_id(ClassName0, ClassArity),
+ module_info_classes(ModuleInfo, ClassTable),
+ map__lookup(ClassTable, ClassId, ClassDefn),
+ ClassDefn = hlds_class_defn(_, SuperClasses, _, _, _, _, _),
+ list__length(SuperClasses, NumSuperClasses),
+
+ unqualify_name(ClassName0, ClassName),
+
+ % Make a new variable to contain the dictionary for
+ % this typeclass constraint
+ polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, C,
+ ClassName, ExtraHeadVar, VarSet1, VarTypes1),
+
+ % Find all the type variables in the constraint, and
+ % remember what index they appear in in the typeclass
+ % info.
+
+ % The first type_info will be just after the superclass
+ % infos
+ First is NumSuperClasses + 1,
+ term__vars_list(ClassTypes, ClassTypeVars0),
+ MakeIndex = (pred(Elem0::in, Elem::out,
+ Index0::in, Index::out) is det :-
+ Elem = Elem0 - Index0,
+ Index is Index0 + 1,
+ % the following call is a work-around for a
+ % compiler bug with intermodule optimization:
+ % it is needed to resolve a type ambiguity
+ is_pair(Elem)
+ ),
+ list__map_foldl(MakeIndex, ClassTypeVars0, ClassTypeVars,
+ First, _),
+
- % Make a new variable to contain the dictionary for this
- % typeclass constraint
- polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, C,
- ClassName, Var, VarSet1, VarTypes1),
- ExtraHeadVars1 = [Var | ExtraHeadVars0],
-
- % Find all the type variables in the constraint, and remember
- % what index they appear in in the typeclass info.
-
- % The first type_info will be just after the superclass infos
- First is NumSuperClasses + 1,
- term__vars_list(ClassTypes, ClassTypeVars0),
- MakeIndex = lambda([Elem0::in, Elem::out,
- Index0::in, Index::out] is det,
- (
- Elem = Elem0 - Index0,
- Index is Index0 + 1,
- % the following call is a work-around for a compiler
- % bug with intermodule optimization: it is needed to
- % resolve a type ambiguity
- is_pair(Elem)
- )),
- list__map_foldl(MakeIndex, ClassTypeVars0, ClassTypeVars, First, _),
-
+ % Work out which ones haven't been seen before
+ IsNew = (pred(TypeVar0::in) is semidet :-
+ TypeVar0 = TypeVar - _Index,
+ \+ map__search(TypeInfoMap0, TypeVar, _)
+ ),
+ list__filter(IsNew, ClassTypeVars, NewClassTypeVars),
- % Work out which ones haven't been seen before
- IsNew = lambda([TypeVar0::in] is semidet,
- (
- TypeVar0 = TypeVar - _Index,
- \+ map__search(TypeInfoMap0, TypeVar, _)
- )),
- list__filter(IsNew, ClassTypeVars, NewClassTypeVars),
-
- % Make an entry in the TypeInfo locations map for each new
- % type variable. The type variable can be found at the
- % previously calculated offset with the new typeclass_info
- MakeEntry = lambda([IndexedTypeVar::in,
- LocnMap0::in, LocnMap::out] is det,
- (
- IndexedTypeVar = TheTypeVar - Location,
- map__set(LocnMap0, TheTypeVar,
- typeclass_info(Var, Location), LocnMap)
- )),
- list__foldl(MakeEntry, NewClassTypeVars, TypeInfoMap0, TypeInfoMap1),
-
- poly_info_set_varset_and_types(VarSet1, VarTypes1, Info0, Info1),
- poly_info_set_type_info_map(TypeInfoMap1, Info1, Info2),
-
- % Handle the rest of the constraints
- polymorphism__make_typeclass_info_head_vars_2(Cs,
- ExtraHeadVars1, ExtraHeadVars, Info2, Info).
+ % Make an entry in the TypeInfo locations map for each
+ % new type variable. The type variable can be found at
+ % the previously calculated offset with the new
+ % typeclass_info
+ MakeEntry = (pred(IndexedTypeVar::in,
+ LocnMap0::in, LocnMap::out) is det :-
+ IndexedTypeVar = TheTypeVar - Location,
+ map__set(LocnMap0, TheTypeVar,
+ typeclass_info(ExtraHeadVar, Location),
+ LocnMap)
+ ),
+ list__foldl(MakeEntry, NewClassTypeVars, TypeInfoMap0,
+ TypeInfoMap1),
+
+ poly_info_set_varset_and_types(VarSet1, VarTypes1, Info0,
+ Info1),
+ poly_info_set_type_info_map(TypeInfoMap1, Info1, Info)
+ ).
:- pred is_pair(pair(_, _)::in) is det.
is_pair(_).
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.43
diff -u -t -r1.43 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile 2001/01/15 07:27:28 1.43
+++ tests/hard_coded/typeclasses/Mmakefile 2001/02/06 04:11:43
@@ -42,6 +42,7 @@
nondet_class_method \
operator_classname \
record_syntax \
+ reordered_existential_constraint \
superclass_bug \
superclass_bug2 \
superclass_call \
New File: tests/hard_coded/typeclasses/reordered_existential_constraint.exp
===================================================================
Hi!
New File: tests/hard_coded/typeclasses/reordered_existential_constraint.m
===================================================================
:- module reordered_existential_constraint.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.
:- implementation.
main --> { foobar }, io__write_string("Hi!\n").
:- typeclass c(T) where [].
:- instance c(int) where [].
%:- pred q(T).
:- pred q(T) <= c(T).
:- mode q(in) is det.
q(_).
%:- some [T] pred p(T).
:- some [T] pred p(T) => c(T).
:- mode p(out) is det.
p(1).
:- pred foobar is det.
foobar :-
q(X), % XXX polymorphism aborts here, looking for the variable that
% contains the type class info for c(T).
p(X).
dgj
--
David Jeffery (dgj at cs.mu.oz.au) | If your thesis is utterly vacuous
PhD student, | Use first-order predicate calculus.
Dept. of Comp. Sci. & Soft. Eng.| With sufficient formality
The University of Melbourne | The sheerist banality
Australia | Will be hailed by the critics: "Miraculous!"
| -- Anon.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list