[m-dev.] for review: fix bugs with inter-module optimization and type classes
Simon Taylor
stayl at cs.mu.OZ.AU
Thu Jul 6 12:26:48 AEST 2000
Estimated hours taken: 2
Fix a bug which caused intermod.m to abort when a type class
contained a predicate or function with more than one mode.
compiler/check_typeclass.m:
Reorder the method declarations in each instance so that they
match the order of the list of pred_proc_ids for the instance
implementation.
compiler/intermod.m:
Remove duplicate pred_ids from the list of methods in an
instance declaration when module qualifying the original
instance declaration before writing it to the `.opt' file.
Make sure that predicates referred to by an instance declaration
in a `.opt' file are made exported.
compiler/prog_data.m:
Simplify the code by replacing the `pred_instance' and
`func_instance' constructors of the `instance_method/0'
type with a single constructor with a `pred_or_func' argument.
compiler/mercury_to_mercury.m:
compiler/check_typeclass.m:
compiler/prog_io_typeclass.m:
compiler/intermod.m:
Handle the change to the `instance_method/0' type.
tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/intermod_typeclass_bug.m:
tests/hard_coded/typeclasses/intermod_typeclass_bug2.m:
tests/hard_coded/typeclasses/intermod_typeclass_bug.exp:
Test case.
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/check_typeclass.m,v
retrieving revision 1.30
diff -u -u -r1.30 check_typeclass.m
--- compiler/check_typeclass.m 2000/03/27 05:07:31 1.30
+++ compiler/check_typeclass.m 2000/07/05 00:11:36
@@ -143,17 +143,21 @@
Errors2 = Errors0
;
InstanceBody = concrete(InstanceMethods),
- list__foldl2(
+ InstanceCheckInfo0 = instance_check_info(InstanceDefn0,
+ [], Errors0, ModuleInfo0),
+ list__foldl(
check_instance_pred(ClassId, Vars, ClassInterface),
- PredIds, InstanceDefn0, InstanceDefn1,
- Errors0 - ModuleInfo0, Errors1 - ModuleInfo1),
+ PredIds, InstanceCheckInfo0, InstanceCheckInfo),
+ InstanceCheckInfo = instance_check_info(InstanceDefn1,
+ RevInstanceMethods, Errors1, ModuleInfo1),
+
%
% We need to make sure that the MaybePredProcs field is
% set to yes(_) after this pass. Normally that will be
% handled by check_instance_pred, but we also need to handle
% it below, in case the class has no methods.
%
- InstanceDefn1 = hlds_instance_defn(A, B, C, D, E,
+ InstanceDefn1 = hlds_instance_defn(A, B, C, D, _,
MaybePredProcs1, G, H),
(
MaybePredProcs1 = yes(_),
@@ -162,7 +166,25 @@
MaybePredProcs1 = no,
MaybePredProcs2 = yes([])
),
- InstanceDefn2 = hlds_instance_defn(A, B, C, D, E,
+
+ %
+ % Make sure the list of instance methods is in the same
+ % order as the methods in the class definition. intermod.m
+ % relies on this. If there were errors, don't change the
+ % list of methods.
+ %
+ (
+ list__length(RevInstanceMethods,
+ list__length(InstanceMethods))
+ ->
+ OrderedInstanceMethods =
+ list__reverse(RevInstanceMethods)
+ ;
+ OrderedInstanceMethods = InstanceMethods
+ ),
+
+ InstanceDefn2 = hlds_instance_defn(A, B, C, D,
+ concrete(OrderedInstanceMethods),
MaybePredProcs2, G, H),
%
% Check if there are any instance methods left over,
@@ -209,6 +231,16 @@
%----------------------------------------------------------------------------%
+:- type instance_check_info
+ ---> instance_check_info(
+ hlds_instance_defn,
+ instance_methods, % The instance methods in reverse
+ % order of the methods in the class
+ % declaration.
+ error_messages,
+ module_info
+ ).
+
% This structure holds the information about a particular instance
% method
:- type instance_method_info ---> instance_method_info(
@@ -240,13 +272,14 @@
% check one pred in one instance of one class
:- pred check_instance_pred(class_id, list(tvar), hlds_class_interface,
- pred_id, hlds_instance_defn, hlds_instance_defn,
- pair(error_messages, module_info), pair(error_messages, module_info)).
-:- mode check_instance_pred(in,in, in, in, in, out, in, out) is det.
+ pred_id, instance_check_info, instance_check_info).
+:- mode check_instance_pred(in,in, in, in, in, out) is det.
check_instance_pred(ClassId, ClassVars, ClassInterface, PredId,
- InstanceDefn0, InstanceDefn,
- Errors0 - ModuleInfo0, Errors - ModuleInfo):-
+ InstanceCheckInfo0, InstanceCheckInfo) :-
+
+ InstanceCheckInfo0 = instance_check_info(InstanceDefn0,
+ OrderedMethods0, Errors0, ModuleInfo0),
solutions(
lambda([ProcId::out] is nondet,
(
@@ -304,19 +337,26 @@
ArgTypeVars, Status, PredOrFunc),
check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
- InstanceDefn0, InstanceDefn, Info0, Info),
+ InstanceDefn0, InstanceDefn, OrderedMethods0, OrderedMethods,
+ Info0, Info),
Info = instance_method_info(ModuleInfo, _PredName, _PredArity,
_ExistQVars, _ArgTypes, _ClassContext, _ArgModes, Errors,
- _ArgTypeVars, _Status, _PredOrFunc).
+ _ArgTypeVars, _Status, _PredOrFunc),
+
+ InstanceCheckInfo = instance_check_info(InstanceDefn,
+ OrderedMethods, Errors, ModuleInfo).
:- pred check_instance_pred_procs(class_id, list(tvar), sym_name, pred_markers,
hlds_instance_defn, hlds_instance_defn,
+ instance_methods, instance_methods,
instance_method_info, instance_method_info).
-:- mode check_instance_pred_procs(in, in, in, in, in, out, in, out) is det.
+:- mode check_instance_pred_procs(in, in, in, in, in, out,
+ in, out, in, out) is det.
check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
- InstanceDefn0, InstanceDefn, Info0, Info) :-
+ InstanceDefn0, InstanceDefn, OrderedInstanceMethods0,
+ OrderedInstanceMethods, Info0, Info) :-
InstanceDefn0 = hlds_instance_defn(A, InstanceContext,
InstanceConstraints, InstanceTypes,
InstanceBody, MaybeInstancePredProcs,
@@ -325,10 +365,14 @@
ExistQVars, ArgTypes, ClassContext, ArgModes, Errors0,
ArgTypeVars, Status, PredOrFunc),
get_matching_instance_names(InstanceBody, PredOrFunc, MethodName,
- PredArity, InstanceNames),
+ PredArity, MatchingInstanceMethods),
(
- InstanceNames = [InstancePredName - Context]
+ MatchingInstanceMethods = [InstanceMethod]
->
+ OrderedInstanceMethods =
+ [InstanceMethod | OrderedInstanceMethods0],
+ InstanceMethod = instance_method(_, _, InstancePredName,
+ _, Context),
produce_auxiliary_procs(ClassVars, Markers,
InstanceTypes, InstanceConstraints,
InstanceVarSet,
@@ -354,9 +398,10 @@
InstanceConstraints, InstanceTypes, InstanceBody,
yes(InstancePredProcs), InstanceVarSet, H)
;
- InstanceNames = [I1, I2 | Is]
+ MatchingInstanceMethods = [I1, I2 | Is]
->
% one kind of error
+ OrderedInstanceMethods = OrderedInstanceMethods0,
InstanceDefn = InstanceDefn0,
ClassId = class_id(ClassName, _ClassArity),
prog_out__sym_name_to_string(MethodName, MethodNameString),
@@ -380,13 +425,13 @@
PredOrFuncString, " method `",
MethodNameString, "/", PredArityString, "'."],
ErrorHeader),
- I1 = _ - I1Context,
+ I1 = instance_method(_, _, _, _, I1Context),
Heading =
[I1Context - [words("First definition appears here.")],
InstanceContext - [words(ErrorHeader)]],
list__map(lambda([Definition::in, ContextAndError::out] is det,
(
- Definition = _ - TheContext,
+ Definition = instance_method(_, _, _, _, TheContext),
Error = [words("Subsequent definition appears here.")],
ContextAndError = TheContext - Error
)), [I2|Is], SubsequentErrors),
@@ -399,6 +444,7 @@
ArgTypeVars, Status, PredOrFunc)
;
% another kind of error
+ OrderedInstanceMethods = OrderedInstanceMethods0,
InstanceDefn = InstanceDefn0,
ClassId = class_id(ClassName, _ClassArity),
prog_out__sym_name_to_string(MethodName, MethodNameString),
@@ -429,42 +475,22 @@
).
:- pred get_matching_instance_names(instance_body, pred_or_func,
- sym_name, arity, list(pair(sym_name, prog_context))).
+ sym_name, arity, list(instance_method)).
:- mode get_matching_instance_names(in, in, in, in, out) is det.
-get_matching_instance_names(InstanceBody, PredOrFunc, PredName,
- PredArity, InstanceNames) :-
- (
- PredOrFunc = predicate,
- solutions(
- lambda([Pair::out] is nondet,
- (
- InstanceBody =
- concrete(InstanceMethods),
- list__member(Method, InstanceMethods),
- Method = pred_instance(PredName,
- SymName, PredArity,
- Context),
- Pair = SymName - Context
- )),
- InstanceNames)
- ;
- PredOrFunc = function,
- FuncArity is PredArity - 1,
- solutions(
- lambda([Pair::out] is nondet,
- (
- InstanceBody =
- concrete(InstanceMethods),
- list__member(Method, InstanceMethods),
- Method = func_instance(PredName,
- SymName, FuncArity,
- Context),
- Pair = SymName - Context
- )),
- InstanceNames)
- ).
-
+get_matching_instance_names(InstanceBody, PredOrFunc, MethodName,
+ MethodArity0, MatchingInstanceMethods) :-
+ adjust_func_arity(PredOrFunc, MethodArity, MethodArity0),
+ solutions(
+ (pred(Method::out) is nondet :-
+ InstanceBody = concrete(InstanceMethods),
+ list__member(Method, InstanceMethods),
+ Method = instance_method(PredOrFunc,
+ MethodName, _InstanceMethodName,
+ MethodArity, _Context)
+ ),
+ MatchingInstanceMethods).
+
% Just a bit simpler than using a pair of pairs
:- type triple(T1, T2, T3) ---> triple(T1, T2, T3).
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.78
diff -u -u -r1.78 intermod.m
--- compiler/intermod.m 2000/03/24 10:27:28 1.78
+++ compiler/intermod.m 2000/07/05 02:38:10
@@ -228,7 +228,7 @@
;
% Remove any items added for the clauses
% for this predicate.
- dcg_set(IntermodInfo0)
+ :=(IntermodInfo0)
)
;
[]
@@ -311,9 +311,6 @@
pred_info_get_goal_type(PredInfo, assertion)
).
-:- pred dcg_set(T::in, T::unused, T::out) is det.
-dcg_set(T, _, T).
-
:- pred intermod__traverse_clauses(list(clause)::in, list(clause)::out,
bool::out, intermod_info::in, intermod_info::out) is det.
@@ -826,10 +823,18 @@
=(IntermodInfo0),
(
{ Interface0 = concrete(Methods0) },
- { MaybePredProcIds = yes(PredProcIds) ->
+ { MaybePredProcIds = yes(ClassProcs) ->
+ GetPredId =
+ (pred(Proc::in, PredId::out) is det :-
+ Proc = hlds_class_proc(PredId, _)
+ ),
+ list__map(GetPredId, ClassProcs, ClassPreds0),
+
+ % The interface is sorted on pred_id.
+ list__remove_adjacent_dups(ClassPreds0,
+ ClassPreds),
assoc_list__from_corresponding_lists(
- PredProcIds, Methods0,
- MethodAL0)
+ ClassPreds, Methods0, MethodAL0)
;
error(
"intermod__gather_instances_3: method pred_proc_ids not filled in")
@@ -859,7 +864,7 @@
% Don't write declarations for any of the
% methods if one can't be written.
%
- dcg_set(IntermodInfo0)
+ :=(IntermodInfo0)
)
;
{ Interface0 = abstract },
@@ -892,43 +897,46 @@
% Resolve overloading of instance methods before writing them
% to the `.opt' file.
:- pred intermod__qualify_instance_method(module_info::in,
- pair(hlds_class_proc, instance_method)::in,
+ pair(pred_id, instance_method)::in,
pair(pred_id, instance_method)::out) is det.
-intermod__qualify_instance_method(ModuleInfo, ClassProcId - InstanceMethod0,
- PredId - InstanceMethod) :-
- ClassProcId = hlds_class_proc(MethodCallPredId, _),
+intermod__qualify_instance_method(ModuleInfo,
+ MethodCallPredId - InstanceMethod0, PredId - InstanceMethod) :-
module_info_pred_info(ModuleInfo, MethodCallPredId,
MethodCallPredInfo),
pred_info_arg_types(MethodCallPredInfo, MethodCallTVarSet, _,
MethodCallArgTypes),
- (
- InstanceMethod0 = func_instance(MethodName,
+ InstanceMethod0 = instance_method(PredOrFunc, MethodName,
InstanceMethodName0, MethodArity, MethodContext),
+ (
+ PredOrFunc = function,
module_info_get_predicate_table(ModuleInfo, PredicateTable),
(
predicate_table_search_func_sym_arity(PredicateTable,
InstanceMethodName0, MethodArity, PredIds),
typecheck__find_matching_pred_id(PredIds, ModuleInfo,
MethodCallTVarSet, MethodCallArgTypes,
- PredId0, InstanceMethodName)
+ PredId0, InstanceMethodName1)
->
PredId = PredId0,
- InstanceMethod = func_instance(MethodName,
- InstanceMethodName, MethodArity, MethodContext)
+ InstanceMethodName = InstanceMethodName1
;
- error(
- "intermod__qualify_instance_method: undefined function")
+ hlds_out__simple_call_id_to_string(
+ function - InstanceMethodName0/MethodArity,
+ MethodStr),
+ string__append(
+ "intermod__qualify_instance_method: undefined ",
+ MethodStr, Msg),
+ error(Msg)
)
;
- InstanceMethod0 = pred_instance(MethodName,
- InstanceMethodName0, MethodArity, MethodContext),
+ PredOrFunc = predicate,
typecheck__resolve_pred_overloading(ModuleInfo,
MethodCallArgTypes, MethodCallTVarSet,
- InstanceMethodName0, InstanceMethodName, PredId),
- InstanceMethod = pred_instance(MethodName,
- InstanceMethodName, MethodArity, MethodContext)
- ).
+ InstanceMethodName0, InstanceMethodName, PredId)
+ ),
+ InstanceMethod = instance_method(PredOrFunc, MethodName,
+ InstanceMethodName, MethodArity, MethodContext).
%-----------------------------------------------------------------------------%
@@ -1742,7 +1750,8 @@
HigherOrderSizeLimit),
intermod__gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
Deforestation, Info0, Info1),
- intermod__gather_types(Info1, Info),
+ intermod__gather_instances(Info1, Info2),
+ intermod__gather_types(Info2, Info),
do_adjust_pred_import_status(Info, Module0, Module),
maybe_write_string(VVerbose, " done\n", IO2, IO).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.168
diff -u -u -r1.168 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 2000/04/22 07:11:51 1.168
+++ compiler/mercury_to_mercury.m 2000/07/04 07:14:00
@@ -532,11 +532,12 @@
output_instance_method(Method) -->
io__write_char('\t'),
+ { Method = instance_method(PredOrFunc, Name1, Name2, Arity, _Context) },
(
- { Method = func_instance(Name1, Name2, Arity, _Context) },
+ { PredOrFunc = function },
io__write_string("func(")
;
- { Method = pred_instance(Name1, Name2, Arity, _Context) },
+ { PredOrFunc = predicate },
io__write_string("pred(")
),
mercury_output_bracketed_sym_name(Name1, next_to_graphic_token),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.55
diff -u -u -r1.55 module_qual.m
--- compiler/module_qual.m 2000/04/22 07:11:54 1.55
+++ compiler/module_qual.m 2000/07/04 07:18:42
@@ -1070,16 +1070,11 @@
Ms = M0s
;
sym_name_get_module_name(ClassName, unqualified(""), Module),
- Qualify = lambda([M0::in, M::out] is det,
- (
- M0 = pred_instance(Method0, A, B, C),
- add_module_qualifier(Module, Method0, Method),
- M = pred_instance(Method, A, B, C)
- ;
- M0 = func_instance(Method0, A, B, C),
- add_module_qualifier(Module, Method0, Method),
- M = func_instance(Method, A, B, C)
- )),
+ Qualify = lambda([M0::in, M::out] is det, (
+ M0 = instance_method(A, Method0, C, D, E),
+ add_module_qualifier(Module, Method0, Method),
+ M = instance_method(A, Method, C, D, E)
+ )),
list__map(Qualify, M0s, Ms)
).
Index: compiler/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.54
diff -u -u -r1.54 prog_data.m
--- compiler/prog_data.m 2000/04/22 07:11:56 1.54
+++ compiler/prog_data.m 2000/07/04 07:11:19
@@ -459,13 +459,10 @@
.
:- type instance_method
- ---> func_instance(sym_name, sym_name, arity, prog_context)
- % Method, Instance, Arity,
+ ---> instance_method(pred_or_func, sym_name,
+ sym_name, arity, prog_context).
+ % PredOrFunc, Method, Instance, Arity,
% Line number of declaration
- ; pred_instance(sym_name, sym_name, arity, prog_context)
- % Method, Instance, Arity,
- % Line number of declaration
- .
:- type instance_body
---> abstract
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.13
diff -u -u -r1.13 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 2000/03/27 05:07:48 1.13
+++ compiler/prog_io_typeclass.m 2000/07/04 07:37:37
@@ -530,9 +530,9 @@
InstanceMethod, "instance method",
ok(InstanceMethodName, []))
->
- Result = ok(pred_instance(ClassMethodName,
- InstanceMethodName, ArityInt,
- TermContext))
+ Result = ok(instance_method(predicate,
+ ClassMethodName, InstanceMethodName,
+ ArityInt, TermContext))
;
Result = error(
"expected `pred(<Name> / <Arity>) is <InstanceMethod>'",
@@ -556,9 +556,9 @@
InstanceMethod, "instance method",
ok(InstanceMethodName, []))
->
- Result = ok(func_instance(ClassMethodName,
- InstanceMethodName, ArityInt,
- TermContext))
+ Result = ok(instance_method(function,
+ ClassMethodName, InstanceMethodName,
+ ArityInt, TermContext))
;
Result = error(
"expected `func(<Name> / <Arity>) is <InstanceMethod>'",
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.29
diff -u -u -r1.29 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile 2000/05/09 10:48:55 1.29
+++ tests/hard_coded/typeclasses/Mmakefile 2000/07/05 01:15:06
@@ -26,6 +26,7 @@
instance_unconstrained_tvar \
inference_test \
inference_test_2 \
+ intermod_typeclass_bug \
lambda_multi_constraint_same_tvar \
mode_decl_order_bug \
multi_constraint_diff_tvar \
@@ -53,6 +54,8 @@
MCFLAGS-inference_test = --infer-all
MCFLAGS-inference_test_2 = --infer-all
MCFLAGS-existential_type_classes = --infer-all
+MCFLAGS-intermod_typeclass_bug = --intermodule-optimization
+MCFLAGS-intermod_typeclass_bug2 = --intermodule-optimization
MCFLAGS-lambda_multi_constraint_same_tvar = --infer-all
MCFLAGS-abstract_instance = --infer-all
MCFLAGS-unqualified_method = --intermodule-optimization
Index: tests/hard_coded/typeclasses/intermod_typeclass_bug.exp
===================================================================
RCS file: intermod_typeclass_bug.exp
diff -N intermod_typeclass_bug.exp
--- /dev/null Thu Jul 6 12:20:03 2000
+++ intermod_typeclass_bug.exp Thu Jul 6 10:20:15 2000
@@ -0,0 +1,3 @@
+Test 1 succeeded: a
+Test 2 succeeded: b
+Test 3 succeeded: C
Index: tests/hard_coded/typeclasses/intermod_typeclass_bug.m
===================================================================
RCS file: intermod_typeclass_bug.m
diff -N intermod_typeclass_bug.m
--- /dev/null Thu Jul 6 12:20:03 2000
+++ intermod_typeclass_bug.m Wed Jul 5 12:43:42 2000
@@ -0,0 +1,44 @@
+:- module intermod_typeclass_bug.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module intermod_typeclass_bug2.
+:- import_module char.
+
+main -->
+ { p('a', Int1) },
+ ( { char__to_int(Char1, Int1) } ->
+ io__write_string("Test 1 succeeded: "),
+ io__write_char(Char1),
+ io__nl
+ ;
+ io__write_string("Test 1 failed: "),
+ io__write_int(Int1),
+ io__nl
+ ),
+
+ ( { p(Char2, char__to_int('b')) } ->
+ io__write_string("Test 2 succeeded: "),
+ io__write_char(Char2),
+ io__nl
+ ;
+ io__write_string("Test 2 failed"),
+ io__nl
+ ),
+
+ ( { Int3 = q('c'), char__to_int(Char3, Int3) } ->
+ io__write_string("Test 3 succeeded: "),
+ io__write_char(Char3),
+ io__nl
+ ;
+ io__write_string("Test 3 failed"),
+ io__nl
+ ).
+
+
Index: tests/hard_coded/typeclasses/intermod_typeclass_bug2.m
===================================================================
RCS file: intermod_typeclass_bug2.m
diff -N intermod_typeclass_bug2.m
--- /dev/null Thu Jul 6 12:20:03 2000
+++ intermod_typeclass_bug2.m Wed Jul 5 12:43:38 2000
@@ -0,0 +1,38 @@
+:- module intermod_typeclass_bug2.
+
+:- interface.
+
+:- import_module char.
+
+:- typeclass c(T) where [
+ pred p(T, int),
+ mode p(in, out) is det,
+ mode p(out, in) is semidet,
+ func q(T) = int,
+ mode q(in) = out is semidet,
+ mode q(out) = in is semidet
+].
+
+:- instance c(char).
+
+:- implementation.
+
+:- instance c(char) where [
+ func(q/1) is bar,
+ pred(p/2) is foo
+].
+
+:- pred foo(char, int).
+:- mode foo(in, out) is det.
+:- mode foo(out, in) is semidet.
+
+foo(Char, Int) :-
+ char__to_int(Char, Int).
+
+:- func bar(char) = int.
+:- mode bar(in) = out is semidet.
+:- mode bar(out) = in is semidet.
+
+bar(Char) = Int :-
+ char__lower_upper(Char, Char1),
+ char__to_int(Char1, Int).
--------------------------------------------------------------------------
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