[m-dev.] diff: tvar renaming bug fix
David Glen JEFFERY
dgj at cs.mu.OZ.AU
Thu Sep 17 22:23:02 AEST 1998
On 16-Sep-1998, Simon Taylor <stayl at cs.mu.OZ.AU> wrote:
>
> I'd like to see another diff after you've fixed these (could you send
> me the full file for polymorphism.m again as well?).
The revised diff is at the end of this message.
> > + % Make the typeclass_infos for the
> > + % constraints from the context of the
> > + % instance decl.
> > + polymorphism__make_typeclass_info_vars_2(
> > + InstanceConstraints, TypeSubst,
> > + ExistQVars, Context, no, _,
> > + [], InstanceExtraTypeClassInfoVars,
> > + ExtraGoals0, ExtraGoals1,
> > + [], _,
> > + Info2, Info3),
>
> I think the use of InstanceSubst and TypeSubst in this section isn't quite
> right (although it probably will work). At the top of this predicate, the
> first thing this predicate does is apply TypeSubst recursively to Constraint.
> That would suggest that instead of applying InstanceSubst to the constraint
> list and passing TypeSubst to polymorphism__make_typeclass_info_vars_2, this
> should not apply InstanceSubst to the constraints but instead pass
> InstanceSubst instead of TypeSubst. Actually, since the unsubstituted
> constraint (Constraint) is no longer used for anything, it might be better
> to substitute the constraints before they are passed in to here from
> polymorphism__process_call and not pass a type substitution at all to
> polymorphism__make_typeclass_info_var.
This is what I've done. As you say, it doesn't make any difference as once
the InstanceSubst has been applied, TypeSubst won't have any effect. The
only other change this required is to explicitly calculate which type vars are
constrained because you can't calculate it once you've applied the TypeSubst.
> > @@ -1807,26 +1764,18 @@
> > MaybePredProcId = no,
> >
> > % Then work out where to extract it from
> > - SubClassConstraint0 =
> > - constraint(SubClassName, SubClassTypes0),
> > - term__apply_substitution_to_list(SubClassTypes0, Subst,
> > - SubClassTypes1),
> > - % we need to maintain the invariant that types in
> > - % class constraints do not contain any information
> > - % in their term__context fields
> > - strip_term_contexts(SubClassTypes1, SubClassTypes),
>
> I assume this is done somwhere else.
You only need to trip the term contexts after applying a substition, so that
call isn't needed. (Note that apply_subst_to_constraint_list etc. all
strip the term contexts for you anyway).
> > @@ -2047,13 +1980,19 @@
> > poly_info_get_proofs(Info0, Proofs),
> >
> > poly_info_get_varset(Info0, VarSet0),
> > - ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet, _),
> > - map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
> > + ClassDefn = hlds_class_defn(SuperClasses0, ClassVars0,
> > + _, ClassVarSet, _),
> > varset__merge_subst(VarSet0, ClassVarSet, VarSet1, Subst),
> > poly_info_set_varset(VarSet1, Info0, Info1),
>
> I'm a bit worried about this -- the ClassVarSet contains type
> variables doesn't it. Should this be being merged into the typevarset
> rather than the varset?
Indeed. I've fixed that up. The funny thing is that it would probably never
cause a bug because there are almost certainly more variables in the varset
than the tvarset, so the rename apart ends up doing the job for you anyway.
Still... another time we've been bitten by ":- type tvar == var".
--------------------------------------------------------------------------
Estimated hours taken: 20
Fix a bug in the renaming of tvars in type class constraint proofs, and
generally clean up the handling of variable renaming in polymorphism.m.
Change the representation of constraint_proofs to only hold the number of an
instance declaration and not the hlds_instance_defn itself. This means that
polymorphism must look up the instance table to get at hlds_instance_defn,
then calculate the appropriate renamings and substitutions. The rationale
behind this is that the proofs for the superclasses, stored in the
hlds_instance_defn, also need to be renamed. However, we can't just rename
them during typecheck.m because they may not contain proofs for *all* their
ancestors --- that would require topologically sorting the instance defns
before check_typeclass.m.
Also delete the code which attempts to specialise class method calls because
Simon's recent change does this anyway.
hlds_data.m:
Change the constraint_proof representation to only hold instance
numbers, not definitions.
polymorphism.m:
When applying an instance decl, look it up in the instance table
rather than trying to use the half-renamed one in the proof.
Also, rather than trying to pass down a renaming substution into
polymorphism__make_typeclass_info_var, rename everything before
calling it.
type_util.m:
Add two new predicates: apply_subst_to_constraint_proofs and
apply_rec_subst_to_constraint_proofs.
typecheck.m:
Only store the instance number in the proof.
--------------------------------------------------------------------------
Index: compiler//hlds_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_data.m,v
retrieving revision 1.26
diff -u -t -r1.26 hlds_data.m
--- hlds_data.m 1998/09/10 06:51:11 1.26
+++ hlds_data.m 1998/09/16 08:26:35
@@ -754,12 +754,24 @@
% `Proof' of why a constraint is redundant
:- type constraint_proof
- % Apply the following instance rule, the second
- % argument being the number of the instance decl.
- ---> apply_instance(hlds_instance_defn, int)
+ % Apply the instance decl with the given number.
+ % Note that we don't store the actual
+ % hlds_instance_defn for two reasons:
+ % - That would require storing a renamed version of
+ % the constraint_proofs for *every* use of an
+ % instance declaration. This would't even get GCed
+ % for a long time because it would be stored in
+ % the pred_info.
+ % - The superclass proofs stored in the
+ % hlds_instance_defn would need to store all the
+ % constraint_proofs for all its ancestors. This
+ % would require the class relation to be
+ % topologically sorted before checking the
+ % instance declarations.
+ ---> apply_instance(int)
- % The constraint is redundant because of the following
- % class's superclass declaration
+ % The constraint is redundant because of the
+ % following class's superclass declaration
; superclass(class_constraint).
%-----------------------------------------------------------------------------%
Index: compiler//hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.201
diff -u -t -r1.201 hlds_out.m
--- hlds_out.m 1998/09/16 07:16:53 1.201
+++ hlds_out.m 1998/09/16 08:26:36
@@ -2495,7 +2495,7 @@
mercury_output_constraint(VarSet, Constraint),
io__write_string(": "),
(
- { Proof = apply_instance(_, Num) },
+ { Proof = apply_instance(Num) },
io__write_string("apply instance decl #"),
io__write_int(Num)
;
Index: compiler//polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.148
diff -u -t -r1.148 polymorphism.m
--- polymorphism.m 1998/09/10 06:51:35 1.148
+++ polymorphism.m 1998/09/17 11:51:37
@@ -436,7 +436,7 @@
% PredId, ProcId, ModuleInfo0, IO0, IO1),
IO1 = IO0,
- polymorphism__process_proc(ProcId, ProcInfo0, PredId, PredInfo0,
+ polymorphism__process_proc(ProcId, ProcInfo0, PredInfo0,
ModuleInfo0, ProcInfo, PredInfo1, ModuleInfo1),
pred_info_procedures(PredInfo1, ProcTable1),
@@ -513,11 +513,11 @@
%---------------------------------------------------------------------------%
-:- pred polymorphism__process_proc(proc_id, proc_info, pred_id, pred_info,
+:- pred polymorphism__process_proc(proc_id, proc_info, pred_info,
module_info, proc_info, pred_info, module_info).
-:- mode polymorphism__process_proc(in, in, in, in, in, out, out, out) is det.
+:- mode polymorphism__process_proc(in, in, in, in, out, out, out) is det.
-polymorphism__process_proc(ProcId, ProcInfo0, PredId, PredInfo0, ModuleInfo0,
+polymorphism__process_proc(ProcId, ProcInfo0, PredInfo0, ModuleInfo0,
ProcInfo, PredInfo, ModuleInfo) :-
proc_info_goal(ProcInfo0, Goal0),
init_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, Info0),
@@ -545,7 +545,7 @@
% and type-infos for existentially quantified type vars
%
polymorphism__produce_existq_tvars(
- PredId, PredInfo0, ProcId, ProcInfo0,
+ PredInfo0, ProcInfo0,
UnconstrainedTVars, ExtraTypeInfoHeadVars,
ExistTypeClassInfoHeadVars,
Goal1, Goal2, Info2, Info3),
@@ -729,13 +729,13 @@
% for existentially quantified type variables in the head
%
:- pred polymorphism__produce_existq_tvars(
- pred_id, pred_info, proc_id, proc_info,
+ pred_info, proc_info,
list(tvar), list(var), list(var), hlds_goal, hlds_goal,
poly_info, poly_info).
-:- mode polymorphism__produce_existq_tvars(in, in, in, in, in, in, in, in, out,
+:- mode polymorphism__produce_existq_tvars(in, in, in, in, in, in, out,
in, out) is det.
-polymorphism__produce_existq_tvars(PredId, PredInfo, ProcId, ProcInfo,
+polymorphism__produce_existq_tvars(PredInfo, ProcInfo,
UnconstrainedTVars, TypeInfoHeadVars,
ExistTypeClassInfoHeadVars, Goal0, Goal, Info0, Info) :-
poly_info_get_var_types(Info0, VarTypes0),
@@ -747,7 +747,7 @@
% Figure out the bindings for any existentially quantified
% type variables in the head.
%
- ClassContext = constraints(_UnivConstraints, ExistConstraints),
+ ClassContext = constraints(_UnivConstraints, ExistConstraints0),
( map__is_empty(VarTypes0) ->
% this can happen for compiler-generated procedures
map__init(TypeSubst)
@@ -767,22 +767,15 @@
% generate code to produce values for any existentially quantified
% typeclass-info variables in the head
%
- map__init(Subst),
ExistQVarsForCall = [],
Goal0 = _ - GoalInfo,
goal_info_get_context(GoalInfo, Context),
+ apply_rec_subst_to_constraint_list(TypeSubst, ExistConstraints0,
+ ExistConstraints),
polymorphism__make_typeclass_info_vars(
- ExistConstraints, Subst, TypeSubst, ExistQVarsForCall, Context,
- hlds_class_proc(PredId, ProcId),
- hlds_class_proc(NewPredId, NewProcId),
+ ExistConstraints, ExistQVarsForCall, Context,
ExistTypeClassVars, ExtraTypeClassGoals,
- _ExistConstrainedTVars, Info0, Info1),
- % sanity check
- ( PredId = NewPredId, ProcId = NewProcId ->
- true
- ;
- error("polymorphism.m: impossible specialization")
- ),
+ Info0, Info1),
polymorphism__assign_var_list(
ExistTypeClassInfoHeadVars, ExistTypeClassVars,
ExtraTypeClassUnifyGoals),
@@ -904,15 +897,15 @@
->
{ poly_info_get_module_info(Info0, ModuleInfo) },
{ polymorphism__get_special_proc(Type, SpecialPredId,
- ModuleInfo, Name, PredId1, ProcId1) }
+ ModuleInfo, Name, PredId, ProcId) }
;
- { PredId1 = PredId0 },
- { ProcId1 = ProcId0 },
+ { PredId = PredId0 },
+ { ProcId = ProcId0 },
{ Name = Name0 }
),
- polymorphism__process_call(PredId1, ProcId1, ArgVars0, GoalInfo,
- PredId, ProcId, ArgVars, _ExtraVars, CallGoalInfo, ExtraGoals),
+ polymorphism__process_call(PredId, ArgVars0, GoalInfo,
+ ArgVars, _ExtraVars, CallGoalInfo, ExtraGoals),
{ Call = call(PredId, ProcId, ArgVars, Builtin, UnifyContext, Name)
- CallGoalInfo },
@@ -1080,10 +1073,10 @@
polymorphism__process_goal(C0, C).
polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
- { Goal0 = pragma_c_code(IsRecursive, PredId0, ProcId0,
+ { Goal0 = pragma_c_code(IsRecursive, PredId, ProcId,
ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode) },
- polymorphism__process_call(PredId0, ProcId0, ArgVars0, GoalInfo,
- PredId, ProcId, ArgVars, ExtraVars, CallGoalInfo, ExtraGoals),
+ polymorphism__process_call(PredId, ArgVars0, GoalInfo,
+ ArgVars, ExtraVars, CallGoalInfo, ExtraGoals),
%
% insert the type_info vars into the arg-name map,
@@ -1280,21 +1273,21 @@
% existential/universal type_infos and type_class_infos
% in a more consistent manner.
-:- pred polymorphism__process_call(pred_id, proc_id, list(var), hlds_goal_info,
- pred_id, proc_id, list(var), list(var), hlds_goal_info,
+:- pred polymorphism__process_call(pred_id, list(var), hlds_goal_info,
+ list(var), list(var), hlds_goal_info,
list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__process_call(in, in, in, in,
- out, out, out, out, out, out, in, out) is det.
+:- mode polymorphism__process_call(in, in, in,
+ out, out, out, out, in, out) is det.
-polymorphism__process_call(PredId0, ProcId0, ArgVars0, GoalInfo0,
- PredId, ProcId, ArgVars, ExtraVars, GoalInfo, ExtraGoals,
+polymorphism__process_call(PredId, ArgVars0, GoalInfo0,
+ ArgVars, ExtraVars, GoalInfo, ExtraGoals,
Info0, Info) :-
poly_info_get_var_types(Info0, VarTypes),
poly_info_get_typevarset(Info0, TypeVarSet0),
poly_info_get_module_info(Info0, ModuleInfo),
- module_info_pred_info(ModuleInfo, PredId0, PredInfo),
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredExistQVars0,
PredArgTypes0),
pred_info_get_class_context(PredInfo, PredClassContext0),
@@ -1332,8 +1325,6 @@
PredName, PredArity)
)
->
- PredId = PredId0,
- ProcId = ProcId0,
ArgVars = ArgVars0,
GoalInfo = GoalInfo0,
ExtraGoals = [],
@@ -1360,21 +1351,22 @@
goal_info_get_context(GoalInfo0, Context),
PredClassContext1 = constraints(UniversalConstraints1,
ExistentialConstraints1),
- polymorphism__make_typeclass_info_vars(
- UniversalConstraints1, Subst, TypeSubst,
- PredExistQVars, Context,
- hlds_class_proc(PredId0, ProcId0),
- hlds_class_proc(PredId, ProcId),
- UnivTypeClassVars, ExtraTypeClassGoals,
- UnivConstrainedTVars, Info1, Info2),
- % compute which type variables were constrained
- % by the existential type class constraints
+ % compute which type variables are constrained
+ % by the type class constraints
constraint_list_get_tvars(ExistentialConstraints1,
ExistConstrainedTVars),
+ constraint_list_get_tvars(UniversalConstraints1,
+ UnivConstrainedTVars),
- list__append(UnivTypeClassVars, ExistTypeClassVars,
- ExtraTypeClassVars),
+ apply_rec_subst_to_constraint_list(TypeSubst,
+ UniversalConstraints1, UniversalConstraints2),
+
+ polymorphism__make_typeclass_info_vars(
+ UniversalConstraints2,
+ PredExistQVars, Context,
+ UnivTypeClassVars, ExtraTypeClassGoals,
+ Info1, Info2),
% Make variables to hold any existentially
% quantified typeclass_infos in the call,
@@ -1387,6 +1379,9 @@
polymorphism__update_typeclass_infos(
ExistentialConstraints, ExistTypeClassVars,
Info3, Info4),
+
+ list__append(UnivTypeClassVars, ExistTypeClassVars,
+ ExtraTypeClassVars),
% No need to make typeinfos for the constrained vars
list__delete_elems(PredTypeVars1, UnivConstrainedTVars,
@@ -1607,122 +1602,83 @@
% Otherwise we return the original pred_proc_id unchanged.
:- pred polymorphism__make_typeclass_info_vars(list(class_constraint),
- substitution, tsubst, existq_tvars, term__context,
- hlds_class_proc, hlds_class_proc,
- list(var), list(hlds_goal), list(tvar),
+ existq_tvars, term__context,
+ list(var), list(hlds_goal),
poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_vars(in, in, in, in, in, in, out,
- out, out, out, in, out) is det.
+:- mode polymorphism__make_typeclass_info_vars(in, in, in,
+ out, out, in, out) is det.
-polymorphism__make_typeclass_info_vars(PredClassContext, Subst, TypeSubst,
- ExistQVars, Context, PredProcId0, PredProcId,
- ExtraVars, ExtraGoals, ConstrainedTVars, Info0, Info) :-
+polymorphism__make_typeclass_info_vars(PredClassContext,
+ ExistQVars, Context,
+ ExtraVars, ExtraGoals, Info0, Info) :-
% initialise the accumulators
ExtraVars0 = [],
ExtraGoals0 = [],
- ConstrainedTVars0 = [],
-
- % The PredProcId is set to `yes(_)' for the first call only,
- % because we can only specialize method calls if we know
- % which instance of the method's type class it is; knowing
- % the instances for any of the other type class constraints
- % on a method doesn't help us specialize the call.
- MaybePredProcId0 = yes(PredProcId0),
% do the work
polymorphism__make_typeclass_info_vars_2(PredClassContext,
- Subst, TypeSubst, ExistQVars, Context,
- MaybePredProcId0, MaybePredProcId,
+ ExistQVars, Context,
ExtraVars0, ExtraVars1,
ExtraGoals0, ExtraGoals1,
- ConstrainedTVars0, ConstrainedTVars,
Info0, Info),
% We build up the vars and goals in reverse order
list__reverse(ExtraVars1, ExtraVars),
- list__reverse(ExtraGoals1, ExtraGoals),
-
- % If we succeeded in specializing this call, then use
- % the specialization, otherwise use the original call.
- ( MaybePredProcId = yes(PredProcId1) ->
- PredProcId = PredProcId1
- ;
- PredProcId = PredProcId0
- ).
+ list__reverse(ExtraGoals1, ExtraGoals).
% Accumulator version of the above.
:- pred polymorphism__make_typeclass_info_vars_2(
- list(class_constraint), substitution, tsubst,
+ list(class_constraint),
existq_tvars, term__context,
- maybe(hlds_class_proc), maybe(hlds_class_proc),
list(var), list(var),
list(hlds_goal), list(hlds_goal),
- list(var), list(var),
poly_info, poly_info).
-:- mode polymorphism__make_typeclass_info_vars_2(in, in, in, in, in,
- in, out, in, out, in, out, in, out, in, out) is det.
+:- mode polymorphism__make_typeclass_info_vars_2(in, in, in,
+ in, out, in, out, in, out) is det.
-polymorphism__make_typeclass_info_vars_2([], _Subst, _TypeSubst, _ExistQVars,
- _Context, MaybePredProcId, MaybePredProcId,
- ExtraVars, ExtraVars,
+polymorphism__make_typeclass_info_vars_2([], _ExistQVars,
+ _Context, ExtraVars, ExtraVars,
ExtraGoals, ExtraGoals,
- ConstrainedTVars, ConstrainedTVars,
Info, Info).
-polymorphism__make_typeclass_info_vars_2([C|Cs], Subst, TypeSubst, ExistQVars,
- Context, MaybePredProcId0, MaybePredProcId,
- ExtraVars0, ExtraVars,
+polymorphism__make_typeclass_info_vars_2([C|Cs], ExistQVars,
+ Context, ExtraVars0, ExtraVars,
ExtraGoals0, ExtraGoals,
- ConstrainedTVars0, ConstrainedTVars,
Info0, Info) :-
- polymorphism__make_typeclass_info_var(C, Subst, TypeSubst, ExistQVars,
- Context, MaybePredProcId0, MaybePredProcId,
- ExtraGoals0, ExtraGoals1,
- ConstrainedTVars0, ConstrainedTVars1,
+ polymorphism__make_typeclass_info_var(C, ExistQVars,
+ Context, ExtraGoals0, ExtraGoals1,
Info0, Info1, MaybeExtraVar),
maybe_insert_var(MaybeExtraVar, ExtraVars0, ExtraVars1),
- polymorphism__make_typeclass_info_vars_2(Cs, Subst, TypeSubst,
- ExistQVars, Context, no, _,
+ polymorphism__make_typeclass_info_vars_2(Cs,
+ ExistQVars, Context,
ExtraVars1, ExtraVars,
ExtraGoals1, ExtraGoals,
- ConstrainedTVars1, ConstrainedTVars,
Info1, Info).
:- pred polymorphism__make_typeclass_info_var(class_constraint,
- substitution, tsubst, existq_tvars, term__context,
- maybe(hlds_class_proc), maybe(hlds_class_proc),
- list(hlds_goal), list(hlds_goal), list(var), list(var),
+ existq_tvars, term__context,
+ list(hlds_goal), list(hlds_goal),
poly_info, poly_info, maybe(var)).
-:- mode polymorphism__make_typeclass_info_var(in, in, in, in, in, in, out,
- in, out, in, out, in, out, out) is det.
+:- mode polymorphism__make_typeclass_info_var(in, in, in, in, out,
+ in, out, out) is det.
-polymorphism__make_typeclass_info_var(Constraint, Subst, TypeSubst, ExistQVars,
- Context, MaybePredProcId0, MaybePredProcId,
- ExtraGoals0, ExtraGoals, ConstrainedTVars0, ConstrainedTVars,
+polymorphism__make_typeclass_info_var(Constraint, ExistQVars,
+ Context, ExtraGoals0, ExtraGoals,
Info0, Info, MaybeVar) :-
- Constraint = constraint(ClassName, NewConstrainedTypes),
- list__length(NewConstrainedTypes, ClassArity),
+ Constraint = constraint(ClassName, ConstrainedTypes),
+ list__length(ConstrainedTypes, ClassArity),
ClassId = class_id(ClassName, ClassArity),
- term__vars_list(NewConstrainedTypes, NewConstrainedTVars),
- list__append(NewConstrainedTVars, ConstrainedTVars0, ConstrainedTVars),
- term__apply_substitution_to_list(NewConstrainedTypes, TypeSubst,
- ConstrainedTypes0),
- % we need to maintain the invariant that types in class constraints
- % do not contain any information in their term__context fields
- strip_term_contexts(ConstrainedTypes0, ConstrainedTypes),
- NewC = constraint(ClassName, ConstrainedTypes),
- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0, TypeInfoMap0,
+ Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeInfoMap0,
TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
(
- map__search(TypeClassInfoMap0, NewC, Location)
+ map__search(TypeClassInfoMap0, Constraint, Location)
->
% We already have a typeclass_info for this constraint
ExtraGoals = ExtraGoals0,
Var = Location,
MaybeVar = yes(Var),
- MaybePredProcId = no,
Info = Info0
;
% We don't have the typeclass_info as a parameter to
@@ -1730,167 +1686,112 @@
% somewhere else
% Work out how to make it
- map__lookup(Proofs, NewC, Proof),
+ map__lookup(Proofs, Constraint, Proof),
(
% We have to construct the typeclass_info
% using an instance declaration
- Proof = apply_instance(ProofInstanceDefn, InstanceNum),
+ Proof = apply_instance(InstanceNum),
+
+ module_info_instances(ModuleInfo, InstanceTable),
+ map__lookup(InstanceTable, ClassId, InstanceList),
+ list__index1_det(InstanceList, InstanceNum,
+ ProofInstanceDefn),
- % The subst has already been applied to these
- % constraints in typecheck.m
ProofInstanceDefn = hlds_instance_defn(_,
- InstanceConstraints, _, _, _, _, _),
+ InstanceConstraints0, InstanceTypes0, _, _,
+ InstanceTVarset, SuperClassProofs0),
- %
- % Check whether the callee is a class method,
- % and that this contraint is the first constraint
- % in that callee's constraint list (the one for
- % its own type class).
- % If so, specialize the call by replacing the
- % generic class method call with a direct call
- % to the class method for this instance.
- %
+ % 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),
(
- % check that this constraint is the
- % first constraint in the callee's
- % constraint list
- MaybePredProcId0 = yes(PredProcId0),
-
- % check that the called pred is a class method
- PredProcId0 = hlds_class_proc(PredId0, _),
- module_info_pred_info(ModuleInfo, PredId0,
- PredInfo),
- pred_info_get_markers(PredInfo, Markers),
- check_marker(Markers, class_method),
-
- % enabling this optimisation causes a bug
- % where implied instances are concerned.
- % When the class method call is inlined, the
- % extra typeclass_infos from the instance
- % declaration are not included. Until that
- % bug is fixed, we will disable the
- % optimisation.
- semidet_fail
+ type_list_subsumes(InstanceTypes,
+ ConstrainedTypes, InstanceSubst0)
->
- % Get the class methods, and figure out
- % the method number of this class method.
- module_info_classes(ModuleInfo, ClassTable),
- map__lookup(ClassTable, ClassId, ClassDefn),
- ClassDefn = hlds_class_defn(_, _, ClassMethods,
- _, _),
- ( list__nth_member_search(ClassMethods,
- PredProcId0, MethodNum0) ->
- MethodNum = MethodNum0
- ;
- error("poly: nth_member_search failed")
- ),
-
- % Get the instance methods, and lookup
- % the pred for the corresponding method number.
- % (NB. We can't use ProofInstanceDefn,
- % because its MaybeInstanceMethods field
- % has not been updated (is still `no').)
- module_info_instances(ModuleInfo,
- InstanceTable),
- map__lookup(InstanceTable, ClassId,
- InstanceDefns),
- list__index1_det(InstanceDefns, InstanceNum,
- InstanceDefn),
- InstanceDefn = hlds_instance_defn(_, _, _, _,
- MaybeInstanceMethods, _, _),
- ( MaybeInstanceMethods = yes(InstanceMethods0)
- ->
- InstanceMethods = InstanceMethods0
- ;
- error("poly: no instance methods")
- ),
- list__index1_det(InstanceMethods, MethodNum,
- InstanceMethod),
- MaybePredProcId = yes(InstanceMethod),
- MaybeVar = no,
- ExtraGoals = ExtraGoals0,
- Info = Info0
+ InstanceSubst = InstanceSubst0
;
+ error("poly: wrong instance decl")
+ ),
- % 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, ExistQVars,
- 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, Subst, TypeSubst,
- ExistQVars, Context, no, _,
- [], InstanceExtraTypeClassInfoVars,
- ExtraGoals0, ExtraGoals1,
- [], _,
- Info1, Info2),
-
- polymorphism__construct_typeclass_info(
- InstanceExtraTypeInfoVars,
- InstanceExtraTypeClassInfoVars,
- ClassId, NewC, InstanceNum,
- ExistQVars,
- Var, NewGoals,
- Info2, Info),
-
- MaybeVar = yes(Var),
- MaybePredProcId = no,
-
- % Oh, yuck. The type_info goals have
- % already been reversed, so lets
- % reverse them back.
- list__reverse(TypeInfoGoals, RevTypeInfoGoals),
-
- list__append(ExtraGoals1, RevTypeInfoGoals,
- ExtraGoals2),
- list__append(NewGoals, ExtraGoals2, 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, 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, ExistQVars, 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,
+ [], InstanceExtraTypeClassInfoVars,
+ ExtraGoals0, ExtraGoals1,
+ Info1, Info2),
+
+ polymorphism__construct_typeclass_info(
+ InstanceExtraTypeInfoVars,
+ InstanceExtraTypeClassInfoVars,
+ ClassId, Constraint, InstanceNum,
+ ConstrainedTypes,
+ SuperClassProofs, ExistQVars, Var, NewGoals,
+ Info2, Info),
+
+ MaybeVar = yes(Var),
+
+ % Oh, yuck. The type_info goals have
+ % already been reversed, so lets
+ % reverse them back.
+ list__reverse(TypeInfoGoals, RevTypeInfoGoals),
+
+ list__append(ExtraGoals1, RevTypeInfoGoals,
+ ExtraGoals2),
+ list__append(NewGoals, ExtraGoals2, ExtraGoals)
;
% We have to extract the typeclass_info from
% another one
- Proof = superclass(SubClassConstraint0),
+ Proof = superclass(SubClassConstraint),
% First create a variable to hold the new
% typeclass_info
unqualify_name(ClassName, ClassNameString),
polymorphism__new_typeclass_info_var(VarSet0,
- VarTypes0, NewC, ClassNameString,
+ VarTypes0, Constraint, ClassNameString,
Var, VarSet1, VarTypes1),
MaybeVar = yes(Var),
- MaybePredProcId = no,
% Then work out where to extract it from
- SubClassConstraint0 =
- constraint(SubClassName, SubClassTypes0),
- term__apply_substitution_to_list(SubClassTypes0, Subst,
- SubClassTypes1),
- % we need to maintain the invariant that types in
- % class constraints do not contain any information
- % in their term__context fields
- strip_term_contexts(SubClassTypes1, SubClassTypes),
SubClassConstraint =
constraint(SubClassName, SubClassTypes),
list__length(SubClassTypes, SubClassArity),
SubClassId = class_id(SubClassName, SubClassArity),
- Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet0,
+ Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet,
TypeInfoMap0, TypeClassInfoMap0, Proofs,
PredName, ModuleInfo),
% Make the typeclass_info for the subclass
polymorphism__make_typeclass_info_var(
- SubClassConstraint, Subst, TypeSubst,
- ExistQVars, Context, no, _,
+ SubClassConstraint,
+ ExistQVars, Context,
ExtraGoals0, ExtraGoals1,
- [], _,
Info1, Info2,
MaybeSubClassVar),
( MaybeSubClassVar = yes(SubClassVar0) ->
@@ -1907,17 +1808,9 @@
% Work out which superclass typeclass_info to
% take
- term__var_list_to_term_list(SubClassVars,
- SubClassVarTerms),
- (
- type_list_subsumes(SubClassVarTerms,
- SubClassTypes, SubTypeSubst0)
- ->
- SubTypeSubst0 = SubTypeSubst
- ;
- error("polymorphism__make_typeclass_info_var")
- ),
- apply_rec_subst_to_constraint_list(SubTypeSubst,
+ map__from_corresponding_lists(SubClassVars,
+ SubClassTypes, SubTypeSubst),
+ apply_subst_to_constraint_list(SubTypeSubst,
SuperClasses0, SuperClasses),
(
list__nth_member_search(SuperClasses,
@@ -1983,23 +1876,19 @@
).
:- pred polymorphism__construct_typeclass_info(list(var), list(var), class_id,
- class_constraint, int, existq_tvars, var, list(hlds_goal),
- poly_info, poly_info).
-:- mode polymorphism__construct_typeclass_info(in, in, in, in, in, in,
+ class_constraint, int,
+ list(type), map(class_constraint, constraint_proof),
+ existq_tvars, var, list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__construct_typeclass_info(in, in, in, in, in, in, in, in,
out, out, in, out) is det.
polymorphism__construct_typeclass_info(ArgTypeInfoVars, ArgTypeClassInfoVars,
- ClassId, Constraint, InstanceNum, ExistQVars,
+ ClassId, Constraint, InstanceNum,
+ InstanceTypes, SuperClassProofs, ExistQVars,
NewVar, NewGoals, Info0, Info) :-
poly_info_get_module_info(Info0, ModuleInfo),
- module_info_instances(ModuleInfo, InstanceTable),
- map__lookup(InstanceTable, ClassId, InstanceList),
- list__index1_det(InstanceList, InstanceNum, InstanceDefn),
- InstanceDefn = hlds_instance_defn(_, _, InstanceTypes, _, _, _,
- SuperClassProofs),
-
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, ClassId, ClassDefn),
@@ -2109,35 +1998,43 @@
poly_info_get_proofs(Info0, Proofs),
- poly_info_get_varset(Info0, VarSet0),
- ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet, _),
- map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
+ poly_info_get_typevarset(Info0, VarSet0),
+ ClassDefn = hlds_class_defn(SuperClasses0, ClassVars0,
+ _, ClassVarSet, _),
varset__merge_subst(VarSet0, ClassVarSet, VarSet1, Subst),
- poly_info_set_varset(VarSet1, Info0, Info1),
+ poly_info_set_typevarset(VarSet1, Info0, Info1),
+
+ map__apply_to_list(ClassVars0, Subst, ClassVars1),
+ 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,
+ SuperClasses),
poly_info_set_proofs(SuperClassProofs, Info1, Info2),
- polymorphism__make_superclasses_from_proofs(SuperClasses, Subst,
- TypeSubst, ExistQVars, [], NewGoals, Info2, Info3,
+ polymorphism__make_superclasses_from_proofs(SuperClasses,
+ ExistQVars, [], NewGoals, Info2, Info3,
[], NewVars),
poly_info_set_proofs(Proofs, Info3, Info).
:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint),
- substitution, tsubst, existq_tvars, list(hlds_goal), list(hlds_goal),
+ existq_tvars, list(hlds_goal), list(hlds_goal),
poly_info, poly_info, list(var), list(var)).
-:- mode polymorphism__make_superclasses_from_proofs(in, in, in, in, in, out,
+:- mode polymorphism__make_superclasses_from_proofs(in, in, in, out,
in, out, in, out) is det.
-polymorphism__make_superclasses_from_proofs([], _, _, _,
+polymorphism__make_superclasses_from_proofs([], _,
Goals, Goals, Info, Info, Vars, Vars).
-polymorphism__make_superclasses_from_proofs([C|Cs], Subst, TypeSubst,
+polymorphism__make_superclasses_from_proofs([C|Cs],
ExistQVars, Goals0, Goals, Info0, Info, Vars0, Vars) :-
- polymorphism__make_superclasses_from_proofs(Cs, Subst, TypeSubst,
+ polymorphism__make_superclasses_from_proofs(Cs,
ExistQVars, Goals0, Goals1, Info0, Info1, Vars0, Vars1),
term__context_init(Context),
- polymorphism__make_typeclass_info_var(C, Subst, TypeSubst,
- ExistQVars, Context, no, _, Goals1, Goals, [], _, Info1, Info,
+ polymorphism__make_typeclass_info_var(C,
+ ExistQVars, Context, Goals1, Goals, Info1, Info,
MaybeVar),
maybe_insert_var(MaybeVar, Vars1, Vars).
Index: compiler//type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.58
diff -u -t -r1.58 type_util.m
--- type_util.m 1998/09/10 06:51:41 1.58
+++ type_util.m 1998/09/16 08:26:54
@@ -202,6 +202,16 @@
class_constraint).
:- mode apply_subst_to_constraint(in, in, out) is det.
+:- pred apply_subst_to_constraint_proofs(substitution,
+ map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof)).
+:- mode apply_subst_to_constraint_proofs(in, in, out) is det.
+
+:- pred apply_rec_subst_to_constraint_proofs(substitution,
+ map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof)).
+:- mode apply_rec_subst_to_constraint_proofs(in, in, out) is det.
+
:- pred apply_variable_renaming_to_constraints(map(var, var),
class_constraints, class_constraints).
:- mode apply_variable_renaming_to_constraints(in, in, out) is det.
@@ -835,6 +845,46 @@
Constraint0 = constraint(ClassName, Types0),
term__apply_substitution_to_list(Types0, Subst, Types),
Constraint = constraint(ClassName, Types).
+
+apply_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :-
+ map__init(Empty),
+ map__foldl(
+ lambda([Constraint0::in, Proof0::in, Map0::in, Map::out] is det,
+ (
+ apply_subst_to_constraint(Subst, Constraint0,
+ Constraint),
+ (
+ Proof0 = apply_instance(_),
+ Proof = Proof0
+ ;
+ Proof0 = superclass(Super0),
+ apply_subst_to_constraint(Subst, Super0,
+ Super),
+ Proof = superclass(Super)
+ ),
+ map__set(Map0, Constraint, Proof, Map)
+ )),
+ Proofs0, Empty, Proofs).
+
+apply_rec_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :-
+ map__init(Empty),
+ map__foldl(
+ lambda([Constraint0::in, Proof0::in, Map0::in, Map::out] is det,
+ (
+ apply_rec_subst_to_constraint(Subst, Constraint0,
+ Constraint),
+ (
+ Proof0 = apply_instance(_),
+ Proof = Proof0
+ ;
+ Proof0 = superclass(Super0),
+ apply_rec_subst_to_constraint(Subst, Super0,
+ Super),
+ Proof = superclass(Super)
+ ),
+ map__set(Map0, Constraint, Proof, Map)
+ )),
+ Proofs0, Empty, Proofs).
apply_variable_renaming_to_constraints(Renaming,
constraints(UniversalCs0, ExistentialCs0),
Index: compiler//typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.245
diff -u -t -r1.245 typecheck.m
--- typecheck.m 1998/08/06 04:58:01 1.245
+++ typecheck.m 1998/09/16 06:30:31
@@ -2959,8 +2959,8 @@
% apply a type variable renaming to a class constraint proof
-rename_constraint_proof(_TSubst, apply_instance(Instance, Num),
- apply_instance(Instance, Num)).
+rename_constraint_proof(_TSubst, apply_instance(Num),
+ apply_instance(Num)).
rename_constraint_proof(TSubst, superclass(ClassConstraint0),
superclass(ClassConstraint)) :-
apply_variable_renaming_to_constraint(TSubst, ClassConstraint0,
@@ -3394,23 +3394,22 @@
find_matching_instance_rule_2([I|Is], N0, ClassName, Types, TVarSet,
NewTVarSet, Proofs0, Proofs, NewConstraints) :-
- I = hlds_instance_defn(ModuleName, NewConstraints0, InstanceTypes0,
- Interface, PredProcIds, InstanceNames, SuperClassProofs),
+ I = hlds_instance_defn(_ModuleName, NewConstraints0, InstanceTypes0,
+ _Interface, _PredProcIds, InstanceNames, _SuperClassProofs),
(
varset__merge_subst(TVarSet, InstanceNames, NewTVarSet0,
RenameSubst),
- term__apply_rec_substitution_to_list(InstanceTypes0,
+ term__apply_substitution_to_list(InstanceTypes0,
RenameSubst, InstanceTypes),
type_list_subsumes(InstanceTypes, Types, Subst)
->
- apply_rec_subst_to_constraint_list(RenameSubst, NewConstraints0,
- NewConstraints1),
- apply_rec_subst_to_constraint_list(Subst, NewConstraints1,
- NewConstraints),
NewTVarSet = NewTVarSet0,
- NewProof = apply_instance(hlds_instance_defn(ModuleName,
- NewConstraints, InstanceTypes, Interface, PredProcIds,
- InstanceNames, SuperClassProofs), N0),
+ apply_subst_to_constraint_list(RenameSubst,
+ NewConstraints0, NewConstraints1),
+ apply_rec_subst_to_constraint_list(Subst,
+ NewConstraints1, NewConstraints),
+
+ NewProof = apply_instance(N0),
Constraint = constraint(ClassName, Types),
map__set(Proofs0, Constraint, NewProof, Proofs)
;
@@ -3658,8 +3657,8 @@
% or universal constraints on the declaration
% of the predicate we are analyzing.
map(class_constraint, % for each constraint
- constraint_proof) % constraint found to be
- % redundant, why is it so?
+ constraint_proof) % found to be redundant,
+ % why is it so?
).
%-----------------------------------------------------------------------------%
dgj
--
David Jeffery (dgj at cs.mu.oz.au) | Marge: Did you just call everyone "chicken"?
PhD student, | Homer: Noooo. I swear on this Bible!
Department of Computer Science | Marge: That's not a Bible; that's a book of
University of Melbourne | carpet samples!
Australia | Homer: Ooooh... Fuzzy.
More information about the developers
mailing list