[m-dev.] for review: allow impurity on class methods
David Glen JEFFERY
dgj at ender.cs.mu.oz.au
Sat Mar 25 18:11:35 AEDT 2000
Hi,
This is for Tyson to review.
-----------------------------------------------------------------------------
Estimated hours taken: 6
Allow class methods to be impure or semipure. Previously any purity annotation
on a class method was ignored, and the method assumed to be pure. (We have
for some time caught the case of providing an impure implementation for
a (pure) class method, though).
compiler/prog_data.m:
Add purity to the information we store about each method.
compiler/prog_io_typeclass.m:
Record the declared purity of each method.
compiler/make_hlds.m:
For the predicate we generate corresponding to a method, add any
purity annotations that the method has.
compiler/check_typeclass.m:
Add the appropriate impurity marker to the predicate we generate for
each instance method.
compiler/purity.m:
Be careful not to spit out spurious purity warnings:
- Never warn about excessive impurity for a class methods.
(The body of the method is just class_method_call, which
never looks impure as far as it is concerned).
- Never warn about excessive impurity for class instance
method. The fact that a method is impure doesn't mean that
its instances need to be impure, and it would be excessive
to warn about it, seeing that there is no way for the user
to avoid it (other than actually making their implementation
impure...).
compiler/mercury_to_mercury.m:
Print out method purity in interface files.
compiler/module_qual.m:
compiler/equiv_type.m:
Handle the fact that we now store purity info for class methods.
tests/hard_coded/typeclasses/impure_methods.{m,exp}:
A test case for this change.
tests/hard_coded/typeclasses/Mmakefile:
Turn this change on.
-----------------------------------------------------------------------------
cvs diff: Diffing .
Index: check_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/check_typeclass.m,v
retrieving revision 1.29
diff -u -t -r1.29 check_typeclass.m
--- check_typeclass.m 1999/12/03 12:54:54 1.29
+++ check_typeclass.m 2000/03/24 05:58:21
@@ -257,6 +257,8 @@
module_info_pred_info(ModuleInfo0, PredId, PredInfo),
pred_info_arg_types(PredInfo, ArgTypeVars, ExistQVars, ArgTypes),
pred_info_get_class_context(PredInfo, ClassContext0),
+ pred_info_get_markers(PredInfo, Markers0),
+ remove_marker(Markers0, class_method, Markers),
% The first constraint in the class context of a class method
% is always the constraint for the class of which it is
% a member. Seeing that we are checking an instance
@@ -301,20 +303,20 @@
ExistQVars, ArgTypes, ClassContext, ArgModes, Errors0,
ArgTypeVars, Status, PredOrFunc),
- check_instance_pred_procs(ClassId, ClassVars, MethodName,
+ check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
InstanceDefn0, InstanceDefn, Info0, Info),
Info = instance_method_info(ModuleInfo, _PredName, _PredArity,
_ExistQVars, _ArgTypes, _ClassContext, _ArgModes, Errors,
_ArgTypeVars, _Status, _PredOrFunc).
-:- pred check_instance_pred_procs(class_id, list(tvar), sym_name,
+:- pred check_instance_pred_procs(class_id, list(tvar), sym_name, pred_markers,
hlds_instance_defn, hlds_instance_defn,
instance_method_info, instance_method_info).
-:- mode check_instance_pred_procs(in, in, in, in, out, in, out) is det.
+:- mode check_instance_pred_procs(in, in, in, in, in, out, in, out) is det.
-check_instance_pred_procs(ClassId, ClassVars, MethodName, InstanceDefn0,
- InstanceDefn, Info0, Info) :-
+check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
+ InstanceDefn0, InstanceDefn, Info0, Info) :-
InstanceDefn0 = hlds_instance_defn(A, InstanceContext,
InstanceConstraints, InstanceTypes,
InstanceBody, MaybeInstancePredProcs,
@@ -327,7 +329,7 @@
(
InstanceNames = [InstancePredName - Context]
->
- produce_auxiliary_procs(ClassVars,
+ produce_auxiliary_procs(ClassVars, Markers,
InstanceTypes, InstanceConstraints,
InstanceVarSet,
InstancePredName, Context,
@@ -466,13 +468,13 @@
% Just a bit simpler than using a pair of pairs
:- type triple(T1, T2, T3) ---> triple(T1, T2, T3).
-:- pred produce_auxiliary_procs(list(tvar),
+:- pred produce_auxiliary_procs(list(tvar), pred_markers,
list(type), list(class_constraint), tvarset, sym_name, prog_context,
pred_id, list(proc_id), instance_method_info, instance_method_info).
-:- mode produce_auxiliary_procs(in, in, in, in, in, in, out, out,
+:- mode produce_auxiliary_procs(in, in, in, in, in, in, in, out, out,
in, out) is det.
-produce_auxiliary_procs(ClassVars,
+produce_auxiliary_procs(ClassVars, Markers0,
InstanceTypes0, InstanceConstraints0, InstanceVarSet,
InstancePredName, Context, PredId,
InstanceProcIds, Info0, Info) :-
@@ -519,7 +521,6 @@
Cond = true,
map__init(Proofs),
- init_markers(Markers0),
add_marker(Markers0, class_instance_method, Markers),
module_info_globals(ModuleInfo0, Globals),
globals__lookup_string_option(Globals, aditi_user, User),
@@ -565,7 +566,18 @@
goal_info_init(GoalInfo0),
goal_info_set_context(GoalInfo0, Context, GoalInfo1),
set__list_to_set(HeadVars, NonLocals),
- goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo),
+ goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo2),
+ (
+ check_marker(Markers, (impure))
+ ->
+ goal_info_add_feature(GoalInfo2, (impure), GoalInfo)
+ ;
+ check_marker(Markers, (semipure))
+ ->
+ goal_info_add_feature(GoalInfo2, (semipure), GoalInfo)
+ ;
+ GoalInfo = GoalInfo2
+ ),
% Then the goal itself
invalid_pred_id(InvalidPredId),
Index: equiv_type.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/equiv_type.m,v
retrieving revision 1.21
diff -u -t -r1.21 equiv_type.m
--- equiv_type.m 1999/10/03 04:15:21 1.21
+++ equiv_type.m 2000/03/23 07:27:32
@@ -248,10 +248,11 @@
equiv_type__replace_in_class_method(EqvMap,
pred(TypeVarSet0, InstVarSet, ExistQVars, PredName,
- TypesAndModes0, Det, Cond, ClassContext0,
- Context),
+ TypesAndModes0, Det, Cond, Purity,
+ ClassContext0, Context),
pred(TypeVarSet, InstVarSet, ExistQVars, PredName,
- TypesAndModes, Det, Cond, ClassContext, Context)
+ TypesAndModes, Det, Cond, Purity,
+ ClassContext, Context)
) :-
equiv_type__replace_in_class_constraints(ClassContext0, TypeVarSet0,
EqvMap, ClassContext, TypeVarSet1),
@@ -261,10 +262,10 @@
equiv_type__replace_in_class_method(EqvMap,
func(TypeVarSet0, InstVarSet, ExistQVars, PredName,
TypesAndModes0, RetTypeAndMode0, Det, Cond,
- ClassContext0, Context),
+ Purity, ClassContext0, Context),
func(TypeVarSet, InstVarSet, ExistQVars, PredName,
TypesAndModes, RetTypeAndMode, Det, Cond,
- ClassContext, Context)
+ Purity, ClassContext, Context)
) :-
equiv_type__replace_in_class_constraints(ClassContext0, TypeVarSet0,
EqvMap, ClassContext, TypeVarSet1),
Index: make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.326
diff -u -t -r1.326 make_hlds.m
--- make_hlds.m 2000/03/14 11:21:25 1.326
+++ make_hlds.m 2000/03/23 07:34:30
@@ -2381,7 +2381,8 @@
Module0, Module) -->
(
{ Method = pred(TypeVarSet, InstVarSet, ExistQVars, PredName,
- TypesAndModes, MaybeDet, Cond, ClassContext, Context) },
+ TypesAndModes, MaybeDet, Cond, Purity,
+ ClassContext, Context) },
{ term__var_list_to_term_list(Vars, VarTerms) },
{ ClassContext = constraints(UnivCnstrs, ExistCnstrs) },
{ NewUnivCnstrs = [constraint(Name, VarTerms) | UnivCnstrs] },
@@ -2389,13 +2390,13 @@
{ init_markers(Markers0) },
{ add_marker(Markers0, class_method, Markers) },
module_add_pred(Module0, TypeVarSet, InstVarSet, ExistQVars,
- PredName, TypesAndModes, MaybeDet, Cond, pure,
+ PredName, TypesAndModes, MaybeDet, Cond, Purity,
NewClassContext, Markers, Context, Status,
MaybePredIdProcId, Module)
;
{ Method = func(TypeVarSet, InstVarSet, ExistQVars, FuncName,
TypesAndModes, RetTypeAndMode, MaybeDet, Cond,
- ClassContext, Context) },
+ Purity, ClassContext, Context) },
{ term__var_list_to_term_list(Vars, VarTerms) },
{ ClassContext = constraints(UnivCnstrs, ExistCnstrs) },
{ NewUnivCnstrs = [constraint(Name, VarTerms) | UnivCnstrs] },
@@ -2404,8 +2405,8 @@
{ add_marker(Markers0, class_method, Markers) },
module_add_func(Module0, TypeVarSet, InstVarSet, ExistQVars,
FuncName, TypesAndModes, RetTypeAndMode, MaybeDet,
- Cond, pure, NewClassContext, Markers, Context, Status,
- MaybePredIdProcId, Module)
+ Cond, Purity, NewClassContext, Markers, Context,
+ Status, MaybePredIdProcId, Module)
;
{ Method = pred_mode(VarSet, PredName, Modes, MaybeDet,
Cond, Context) },
@@ -2437,7 +2438,7 @@
add_default_class_method_func_modes([M|Ms], PredProcIds0, PredProcIds,
Module0, Module) :-
(
- M = func(_, _, _, FuncName, TypesAndModes, _, _, _, _, _)
+ M = func(_, _, _, FuncName, TypesAndModes, _, _, _, _, _, _)
->
( FuncName = qualified(ModuleName0, Func0) ->
ModuleName = ModuleName0,
Index: mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.166
diff -u -t -r1.166 mercury_to_mercury.m
--- mercury_to_mercury.m 2000/01/25 04:09:52 1.166
+++ mercury_to_mercury.m 2000/03/23 07:11:00
@@ -500,17 +500,17 @@
io__write_string("\t"),
(
{ Method = pred(TypeVarSet, InstVarSet, ExistQVars, Name,
- TypesAndModes, Detism, _Condition, ClassContext,
+ TypesAndModes, Detism, _Condition, Purity, ClassContext,
Context) },
mercury_output_pred_decl(TypeVarSet, InstVarSet, ExistQVars,
- Name, TypesAndModes, Detism, pure, ClassContext,
+ Name, TypesAndModes, Detism, Purity, ClassContext,
Context, "", ",\n\t", "")
;
{ Method = func(TypeVarSet, InstVarSet, ExistQVars, Name,
TypesAndModes, TypeAndMode, Detism, _Condition,
- ClassContext, Context) },
+ Purity, ClassContext, Context) },
mercury_output_func_decl(TypeVarSet, InstVarSet, ExistQVars,
- Name, TypesAndModes, TypeAndMode, Detism, pure,
+ Name, TypesAndModes, TypeAndMode, Detism, Purity,
ClassContext, Context, "", ",\n\t", "")
;
{ Method = pred_mode(VarSet, Name, Modes, Detism,
Index: module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.53
diff -u -t -r1.53 module_qual.m
--- module_qual.m 2000/01/13 04:29:40 1.53
+++ module_qual.m 2000/03/23 07:39:30
@@ -1022,9 +1022,9 @@
% done when the item is parsed.
qualify_class_method(
pred(TypeVarset, InstVarset, ExistQVars, Name, TypesAndModes0,
- MaybeDet, Cond, ClassContext0, Context),
+ MaybeDet, Cond, Purity, ClassContext0, Context),
pred(TypeVarset, InstVarset, ExistQVars, Name, TypesAndModes,
- MaybeDet, Cond, ClassContext, Context),
+ MaybeDet, Cond, Purity, ClassContext, Context),
MQInfo0, MQInfo
) -->
qualify_types_and_modes(TypesAndModes0, TypesAndModes,
@@ -1033,9 +1033,11 @@
MQInfo1, MQInfo).
qualify_class_method(
func(TypeVarset, InstVarset, ExistQVars, Name, TypesAndModes0,
- ReturnMode0, MaybeDet, Cond, ClassContext0, Context),
+ ReturnMode0, MaybeDet, Cond, Purity, ClassContext0,
+ Context),
func(TypeVarset, InstVarset, ExistQVars, Name, TypesAndModes,
- ReturnMode, MaybeDet, Cond, ClassContext, Context),
+ ReturnMode, MaybeDet, Cond, Purity, ClassContext,
+ Context),
MQInfo0, MQInfo
) -->
qualify_types_and_modes(TypesAndModes0, TypesAndModes,
Index: prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.52
diff -u -t -r1.52 prog_data.m
--- prog_data.m 2000/01/24 17:47:15 1.52
+++ prog_data.m 2000/03/23 07:01:48
@@ -426,21 +426,21 @@
:- type class_method
---> pred(tvarset, inst_varset, existq_tvars, sym_name,
list(type_and_mode), maybe(determinism), condition,
- class_constraints, prog_context)
+ purity, class_constraints, prog_context)
% TypeVarNames, InstVarNames,
% ExistentiallyQuantifiedTypeVars,
% PredName, ArgTypes, Determinism, Cond
- % ClassContext, Context
+ % Purity, ClassContext, Context
; func(tvarset, inst_varset, existq_tvars, sym_name,
list(type_and_mode), type_and_mode,
maybe(determinism), condition,
- class_constraints, prog_context)
+ purity, class_constraints, prog_context)
% TypeVarNames, InstVarNames,
% ExistentiallyQuantfiedTypeVars,
% PredName, ArgTypes, ReturnType,
% Determinism, Cond
- % ClassContext, Context
+ % Purity, ClassContext, Context
; pred_mode(inst_varset, sym_name, list(mode),
maybe(determinism), condition,
Index: prog_io_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.12
diff -u -t -r1.12 prog_io_typeclass.m
--- prog_io_typeclass.m 1999/10/30 09:22:50 1.12
+++ prog_io_typeclass.m 2000/03/23 07:01:11
@@ -198,15 +198,13 @@
item_to_class_method(error(String, Term), _, error(String, Term)).
item_to_class_method(ok(Item, Context), Term, Result) :-
(
- % XXX Purity is ignored
- Item = pred(A, B, C, D, E, F, G, _, I)
+ Item = pred(A, B, C, D, E, F, G, H, I)
->
- Result = ok(pred(A, B, C, D, E, F, G, I, Context))
+ Result = ok(pred(A, B, C, D, E, F, G, H, I, Context))
;
- % XXX Purity is ignored
- Item = func(A, B, C, D, E, F, G, H, _, J)
+ Item = func(A, B, C, D, E, F, G, H, I, J)
->
- Result = ok(func(A, B, C, D, E, F, G, H, J, Context))
+ Result = ok(func(A, B, C, D, E, F, G, H, I, J, Context))
;
Item = pred_mode(A, B, C, D, E)
->
Index: purity.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/purity.m,v
retrieving revision 1.22
diff -u -t -r1.22 purity.m
--- purity.m 2000/01/13 06:17:02 1.22
+++ purity.m 2000/03/25 06:47:17
@@ -455,7 +455,8 @@
ActualPurity),
{ NumErrors is NumErrors0 + 1 }
;
- warn_unnecessary_body_impurity_decl(ModuleInfo, CalleePredInfo,
+ warn_unnecessary_body_impurity_decl(ModuleInfo, PredInfo,
+ CalleePredInfo,
PredId, CallContext,
ActualPurity,
DeclaredPurity),
@@ -708,14 +709,28 @@
warn_exaggerated_impurity_decl(ModuleInfo, PredInfo, PredId,
DeclPurity, AcutalPurity) -->
- { pred_info_context(PredInfo, Context) },
- write_context_and_pred_id(ModuleInfo, PredInfo, PredId),
- prog_out__write_context(Context),
- report_warning(" warning: declared `"),
- write_purity(DeclPurity),
- io__write_string("' but actually "),
- write_purity(AcutalPurity),
- io__write_string(".\n").
+ (
+ % A class method can't have exaggerated impurity...
+ % the impurity means that implementations are *allowed*
+ % to be impure.
+ { pred_info_get_markers(PredInfo, Markers) },
+ {
+ check_marker(Markers, class_method)
+ ;
+ check_marker(Markers, class_instance_method)
+ }
+ ->
+ []
+ ;
+ { pred_info_context(PredInfo, Context) },
+ write_context_and_pred_id(ModuleInfo, PredInfo, PredId),
+ prog_out__write_context(Context),
+ report_warning(" warning: declared `"),
+ write_purity(DeclPurity),
+ io__write_string("' but actually "),
+ write_purity(AcutalPurity),
+ io__write_string(".\n")
+ ).
:- pred warn_unnecessary_promise_pure(module_info, pred_info, pred_id,
io__state, io__state).
@@ -786,28 +801,39 @@
io__write_string("' indicator.\n").
-:- pred warn_unnecessary_body_impurity_decl(module_info, pred_info, pred_id,
- prog_context, purity, purity, io__state, io__state).
-:- mode warn_unnecessary_body_impurity_decl(in, in, in, in, in, in, di, uo)
+:- pred warn_unnecessary_body_impurity_decl(module_info, pred_info, pred_info,
+ pred_id, prog_context, purity, purity, io__state, io__state).
+:- mode warn_unnecessary_body_impurity_decl(in, in, in, in, in, in, in, di, uo)
is det.
-warn_unnecessary_body_impurity_decl(ModuleInfo, _, PredId, Context,
- ActualPurity, DeclaredPurity) -->
- prog_out__write_context(Context),
- io__write_string("In call to "),
- hlds_out__write_pred_id(ModuleInfo, PredId),
- io__write_string(":\n"),
- prog_out__write_context(Context),
- io__write_string(" warning: unnecessary `"),
- write_purity(DeclaredPurity),
- io__write_string("' indicator.\n"),
- prog_out__write_context(Context),
- ( { ActualPurity = pure } ->
- io__write_string(" No purity indicator is necessary.\n")
+warn_unnecessary_body_impurity_decl(ModuleInfo, CallerPredInfo, _PredInfo,
+ PredId, Context, ActualPurity, DeclaredPurity) -->
+ (
+ % We don't warn about exaggerated impurity decls in
+ % instance methods --- it just means that the predicate
+ % provided as an implementation was more pure than
+ % necessary.
+ { pred_info_get_markers(CallerPredInfo, Markers) },
+ { check_marker(Markers, class_instance_method) }
+ ->
+ []
;
- io__write_string(" A purity indicator of `"),
- write_purity(ActualPurity),
- io__write_string("' is sufficient.\n")
+ prog_out__write_context(Context),
+ io__write_string("In call to "),
+ hlds_out__write_pred_id(ModuleInfo, PredId),
+ io__write_string(":\n"),
+ prog_out__write_context(Context),
+ io__write_string(" warning: unnecessary `"),
+ write_purity(DeclaredPurity),
+ io__write_string("' indicator.\n"),
+ prog_out__write_context(Context),
+ ( { ActualPurity = pure } ->
+ io__write_string(" No purity indicator is necessary.\n")
+ ;
+ io__write_string(" A purity indicator of `"),
+ write_purity(ActualPurity),
+ io__write_string("' is sufficient.\n")
+ )
).
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.25
diff -u -t -r1.25 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile 1999/12/26 11:13:39 1.25
+++ tests/hard_coded/typeclasses/Mmakefile 2000/03/25 06:48:23
@@ -19,6 +19,7 @@
implied_instance_multi_constraint \
implied_instance_missing_constraint \
implied_instance_poly \
+ impure_methods \
inference_test \
inference_test_2 \
lambda_multi_constraint_same_tvar \
cvs diff: tests/hard_coded/typeclasses/impure_methods.exp is a new entry, no comparison available
cvs diff: tests/hard_coded/typeclasses/impure_methods.m is a new entry, no comparison available
New file: impure_methods.m
===================================================================
:- module impure_methods.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.
:- typeclass c(T) where [
impure pred m1(T::in) is det,
impure pred m2(T::in, int::out) is det
].
:- type foo ---> foo.
% impure implementations of impure methods
:- instance c(foo) where [
pred(m1/1) is foo_m1,
pred(m2/2) is foo_m2
].
:- type goo ---> goo.
% pure implementations of impure methods
:- instance c(goo) where [
pred(m1/1) is goo_m1,
pred(m2/2) is goo_m2
].
:- impure pred foo_m1(foo::in) is det.
:- impure pred foo_m2(foo::in, int::out) is det.
:- pred goo_m1(goo::in) is det.
:- pred goo_m2(goo::in, int::out) is det.
:- implementation.
:- pragma promise_pure(main/2).
main -->
{ impure m1(foo) },
{ impure m1(foo) },
{ impure m1(foo) },
{ impure m1(foo) },
{ impure m2(foo, X) },
io__write_int(X),
io__nl,
{ impure m1(goo) },
{ impure m1(goo) },
{ impure m1(goo) },
{ impure m1(goo) },
{ impure m2(goo, Y) },
io__write_int(Y),
io__nl.
:- pragma c_header_code("int foo_counter = 0;").
:- pragma c_code(foo_m1(_F::in), "foo_counter++;").
:- pragma c_code(foo_m2(_F::in, Val::out), "Val = foo_counter;").
goo_m1(_).
goo_m2(_, 42).
New file: impure_methods.exp
===================================================================
4
42
-----------------------------------------------------------------------------
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