[m-dev.] for review: superclass bug fix
David Glen JEFFERY
dgj at students.cs.mu.oz.au
Mon Oct 30 21:33:51 AEDT 2000
Hi,
This one's for Fergus.
--------------------------------------------------------------------------
Estimated hours taken: 5
Fix a bug reported by petdr.
compiler/typecheck.m:
When searching the superclass relation trying to reduce a constraint C,
we were holding all the variables in C as constant and allowing any
others to be found. (The theory being that any other variables must be
variables introduced during the search eg. by a multiparameter
typeclass that uses less than all of its parameters in one of its
superclass constraint. These variables are effectively existentially
quantified).
However, this is not enough: variables from *other* assumed constraints
must also not be bound, otherwise you risk binding the variables from
another assumed constraint to the variables in C.
So... now we do not bind any of the head_type_params (which makes sense
given that these are the variables that are universally quantified from
the head or existentially quantified from the body).
This required passing the head_type_params down a couple of levels,
including typecheck__reduce_context_by_rule_application, which is
exported.
compiler/check_typeclass.m:
Add the new argument to the call to
typecheck__reduce_context_by_rule_application.
tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/superclass_bug.exp:
tests/hard_coded/typeclasses/superclass_bug.m:
A test case for this. This test case was giving an abort during
polymorphism because the constraint proof that had been recorded
was invalid. (The program was still type correct, but the type
checker had recorded a bogus proof).
--------------------------------------------------------------------------
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/check_typeclass.m,v
retrieving revision 1.34
diff -u -t -r1.34 check_typeclass.m
--- compiler/check_typeclass.m 2000/10/13 13:55:14 1.34
+++ compiler/check_typeclass.m 2000/10/30 06:57:45
@@ -791,11 +791,13 @@
module_info_instances(ModuleInfo, InstanceTable),
module_info_superclasses(ModuleInfo, SuperClassTable),
+ term__vars_list(InstanceTypes, UnivTvars),
+
% Try to reduce the superclass constraints,
% using the declared instance constraints
% and the usual context reduction rules.
typecheck__reduce_context_by_rule_application(InstanceTable,
- SuperClassTable, InstanceConstraints, TypeSubst,
+ SuperClassTable, InstanceConstraints, UnivTvars, TypeSubst,
InstanceVarSet1, InstanceVarSet2, Proofs0, Proofs1,
SuperClasses, UnprovenConstraints),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.288
diff -u -t -r1.288 typecheck.m
--- compiler/typecheck.m 2000/10/13 07:27:31 1.288
+++ compiler/typecheck.m 2000/10/30 08:51:36
@@ -146,12 +146,13 @@
% the instance rules or superclass rules, building up proofs for
% redundant constraints
:- pred typecheck__reduce_context_by_rule_application(instance_table,
- superclass_table, list(class_constraint), tsubst, tvarset, tvarset,
+ superclass_table, list(class_constraint), list(tvar),
+ tsubst, tvarset, tvarset,
map(class_constraint, constraint_proof),
map(class_constraint, constraint_proof),
list(class_constraint), list(class_constraint)).
-:- mode typecheck__reduce_context_by_rule_application(in, in, in, in, in, out,
- in, out, in, out) is det.
+:- mode typecheck__reduce_context_by_rule_application(in, in, in, in, in,
+ in, out, in, out, in, out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -3948,7 +3949,7 @@
Constraints0 = constraints(UnprovenConstraints0, AssumedConstraints),
typecheck__reduce_context_by_rule_application(InstanceTable,
- SuperClassTable, AssumedConstraints,
+ SuperClassTable, AssumedConstraints, HeadTypeParams,
Bindings, Tvarset0, Tvarset, Proofs0, Proofs,
UnprovenConstraints0, UnprovenConstraints),
@@ -3963,7 +3964,7 @@
typecheck__reduce_context_by_rule_application(InstanceTable, SuperClassTable,
- AssumedConstraints, Bindings, Tvarset0, Tvarset,
+ AssumedConstraints, HeadTypeParams, Bindings, Tvarset0, Tvarset,
Proofs0, Proofs, Constraints0, Constraints) :-
apply_rec_subst_to_constraint_list(Bindings, Constraints0,
Constraints1),
@@ -3971,8 +3972,9 @@
Constraints2, Changed1),
apply_instance_rules(Constraints2, InstanceTable,
Tvarset0, Tvarset1, Proofs0, Proofs1, Constraints3, Changed2),
- apply_class_rules(Constraints3, AssumedConstraints, SuperClassTable,
- Tvarset0, Proofs1, Proofs2, Constraints4, Changed3),
+ apply_class_rules(Constraints3, AssumedConstraints, HeadTypeParams,
+ SuperClassTable, Tvarset0, Proofs1, Proofs2, Constraints4,
+ Changed3),
(
Changed1 = no, Changed2 = no, Changed3 = no
->
@@ -3982,8 +3984,8 @@
Proofs = Proofs2
;
typecheck__reduce_context_by_rule_application(InstanceTable,
- SuperClassTable, AssumedConstraints, Bindings,
- Tvarset1, Tvarset, Proofs2, Proofs,
+ SuperClassTable, AssumedConstraints, HeadTypeParams,
+ Bindings, Tvarset1, Tvarset, Proofs2, Proofs,
Constraints4, Constraints)
).
@@ -4099,29 +4101,29 @@
% superclass relation to find a path from the inferred constraint to
% another (declared or inferred) constraint.
:- pred apply_class_rules(list(class_constraint), list(class_constraint),
- superclass_table, tvarset, map(class_constraint, constraint_proof),
+ list(tvar), superclass_table, tvarset,
+ map(class_constraint, constraint_proof),
map(class_constraint, constraint_proof), list(class_constraint), bool).
-:- mode apply_class_rules(in, in, in, in, in, out, out, out) is det.
+:- mode apply_class_rules(in, in, in, in, in, in, out, out, out) is det.
-apply_class_rules([], _, _, _, Proofs, Proofs, [], no).
-apply_class_rules([C|Constraints0], AssumedConstraints, SuperClassTable,
- TVarSet, Proofs0, Proofs, Constraints, Changed) :-
+apply_class_rules([], _, _, _, _, Proofs, Proofs, [], no).
+apply_class_rules([C|Constraints0], AssumedConstraints, HeadTypeParams,
+ SuperClassTable, TVarSet, Proofs0, Proofs,
+ Constraints, Changed) :-
(
Parents = [],
- C = constraint(_, CTypes),
- term__vars_list(CTypes, CVars),
- eliminate_constraint_by_class_rules(C, CVars,
+ eliminate_constraint_by_class_rules(C, HeadTypeParams,
AssumedConstraints,
SuperClassTable, TVarSet, Parents, Proofs0, Proofs1)
->
- apply_class_rules(Constraints0, AssumedConstraints,
- SuperClassTable, TVarSet, Proofs1, Proofs,
- Constraints, _),
+ apply_class_rules(Constraints0, AssumedConstraints,
+ HeadTypeParams, SuperClassTable, TVarSet,
+ Proofs1, Proofs, Constraints, _),
Changed = yes
;
apply_class_rules(Constraints0, AssumedConstraints,
- SuperClassTable, TVarSet, Proofs0, Proofs,
- Constraints1, Changed),
+ HeadTypeParams, SuperClassTable, TVarSet,
+ Proofs0, Proofs, Constraints1, Changed),
Constraints = [C|Constraints1]
).
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.39
diff -u -t -r1.39 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile 2000/10/13 08:24:25 1.39
+++ tests/hard_coded/typeclasses/Mmakefile 2000/10/30 10:22:35
@@ -41,6 +41,7 @@
nondet_class_method \
operator_classname \
record_syntax \
+ superclass_bug \
superclass_call \
test_default_func_mode \
tuple_instance \
New File: tests/hard_coded/typeclasses/superclass_bug.exp
===================================================================
Hello world.
New File: tests/hard_coded/typeclasses/superclass_bug.m
===================================================================
% $ mmc -e superclass_bug.m
% Uncaught exception:
% Software Error: polymorphism.m: constraint not in constraint list
%
%
:- module superclass_bug.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.
%
% Types
%
:- type interface_pointer ---> interface_pointer(int).
:- type comobj ---> comobj(int).
:- type gc_descriptor ---> gc_descriptor(int).
:- type hresult ---> hresult(int).
%------------------------------------------------------------------------------%
:- typeclass iunknown(T) where [
func get_interface_pointer(T) = interface_pointer,
pred is_null(T::in) is semidet,
pred release_instance(T::in) is det
].
:- typeclass idispatch(T) <= iunknown(T) where [
pred fake_method(T::in, T::out) is det
].
:- typeclass ixmldomnode(IT) <= (idispatch(IT)) where [
some [A, B, C] (func replacechild(T, A, U, B, C, IT, IT) =
hresult => (ixmldomnode(A), ixmldomnode(B), ixmldomnode(C)))
<= (ixmldomnode(T), ixmldomnode(U)),
mode replacechild(in, out, in, out, out, in, out) = out is det
].
:- some [A, B, C] (func ixmldomnode_replacechild(T, A, U, B, C, comobj, comobj) = hresult => (ixmldomnode(A), ixmldomnode(B), ixmldomnode(C))) <= (ixmldomnode(T), ixmldomnode(U)).
:- mode ixmldomnode_replacechild(in, out, in, out, out, in, out) = out is det.
%------------------------------------------------------------------------------%
:- implementation.
main -->
io__write_string("Hello world.\n").
%------------------------------------------------------------------------------%
:- instance iunknown(comobj) where [
get_interface_pointer(comobj(A)) = interface_pointer(A),
(is_null(comobj(A)) :- A = 1),
release_instance(comobj(_))
].
:- instance idispatch(comobj) where [
fake_method(T, T)
].
:- instance ixmldomnode(comobj) where [
func(replacechild/7) is ixmldomnode_replacechild
].
%------------------------------------------------------------------------------%
ixmldomnode_replacechild(T, A, U, B, C, InTypeVar, OutTypeVar) = HResult :-
InTypeVarPtr = comobj_get_interface_pointer(InTypeVar),
TPtr = get_interface_pointer(T),
% XXX This was this line which caused the problem.
UPtr = get_interface_pointer(U),
HResult = ixmldomnode_replacechild_c_code(TPtr, APtr, UPtr, BPtr, CPtr, InTypeVarPtr, OutTypeVarPtr),
A = comobj_create(APtr, gc_descriptor(0)),
B = comobj_create(BPtr, gc_descriptor(0)),
C = comobj_create(CPtr, gc_descriptor(0)),
OutTypeVar = comobj_duplicate(InTypeVar, OutTypeVarPtr).
%------------------------------------------------------------------------------%
:- func ixmldomnode_replacechild_c_code(interface_pointer, interface_pointer, interface_pointer, interface_pointer, interface_pointer, interface_pointer, interface_pointer) = hresult.
:- mode ixmldomnode_replacechild_c_code(in, out, in, out, out, in, out) = out is det.
:- pragma c_code(ixmldomnode_replacechild_c_code(IntroducedIdlBug_1InPtr::in,
IntroducedIdlBug_1OutPtr::out, IntroducedIdlBug_2InPtr::in,
IntroducedIdlBug_2OutPtr::out, OutOldChildPtr::out,
InTypeVarPtr::in, OutTypeVarPtr::out) = (HResult::out),
[will_not_call_mercury, thread_safe],
"
OutOldChildPtr = (Word)NULL;
HResult = (Word) NULL;
IntroducedIdlBug_1OutPtr = IntroducedIdlBug_1InPtr;
IntroducedIdlBug_2OutPtr = IntroducedIdlBug_2InPtr;
OutTypeVarPtr = InTypeVarPtr;
").
%------------------------------------------------------------------------------%
:- func comobj_get_interface_pointer(comobj::in) = (interface_pointer::out) is det.
:- func comobj_create(interface_pointer::in, gc_descriptor::in) = (comobj::out) is det.
:- func comobj_duplicate(comobj::in, interface_pointer::in) = (comobj::out) is det.
comobj_get_interface_pointer(comobj(A)) = interface_pointer(A).
comobj_create(interface_pointer(A), _) = comobj(A).
comobj_duplicate(A, _) = A.
%------------------------------------------------------------------------------%
--------------------------------------------------------------------------
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