[m-rev.] for review: impurity & higher-order
Fergus Henderson
fjh at cs.mu.OZ.AU
Sat Jan 25 03:46:23 AEDT 2003
Support for impurity in higher-order code is IMHO a useful feature;
it is needed to avoid the use of `very_unsafe_perform_io' in
library/exception.m, and has also been requested by the HAL developers.
Given that we support impurity at all, orthogonality suggests that
we should support it for higher-order code too.
Hence the following change.
----------
Estimated hours taken: 24
Branches: main
Support impurity declarations for higher-order code.
In particular, allow `impure' and `semipure' annotations on
higher-order types, higher-order calls, and lambda expresions.
doc/reference_manual.texi:
Document the new language feature.
compiler/hlds_goal.m:
compiler/hlds_pred.m:
Add `purity' field to
- the `higher_order' alternative of the hlds_goal.generic_call type
- the `higher_order' alternative of the hlds_pred.generic_call_id type
- the `lambda_goal' alternative of the hlds_goal.unify_rhs type
compiler/type_util.m:
Add a new `purity' argument to the procedures dealing with
higher-order types. Add code for parsing impure/semipure
higher-order types.
compiler/lambda.m:
compiler/make_hlds.m:
compiler/typecheck.m:
compiler/post_typecheck.m:
compiler/purity.m:
compiler/polymorphism.m:
Various minor changes to support impure/semipure higher-order lambda
expressions.
compiler/polymorphism.m:
compiler/pseudo_type_info.m:
XXX ought to change these to include purity in the RTTI for
higher-order function types.
compiler/simplify.m:
Don't try to optimize semipure/impure higher-order calls.
compiler/assertion.m:
compiler/bytecode_gen.m:
compiler/call_gen.m:
compiler/continuation_info.m:
compiler/cse_detection.m:
compiler/dead_proc_elim.m:
compiler/deep_profiling.m:
compiler/det_analysis.m:
compiler/det_util.m:
compiler/equiv_type.m:
compiler/goal_util.m:
compiler/higher_order.m:
compiler/hlds_out.m:
compiler/intermod.m:
compiler/magic.m:
compiler/magic_util.m:
compiler/ml_call_gen.m:
compiler/ml_closure_gen.m:
compiler/mode_util.m:
compiler/modecheck_call.m:
compiler/modecheck_unify.m:
compiler/modes.m:
compiler/module_qual.m:
compiler/pd_util.m:
compiler/prog_rep.m:
compiler/pseudo_type_info.m:
compiler/quantification.m:
compiler/recompilation.usage.m:
compiler/rl_gen.m:
compiler/stratify.m:
compiler/switch_detection.m:
compiler/term_traversal.m:
compiler/term_util.m:
compiler/unify_gen.m:
compiler/unique_modes.m:
Trivial changes to handle the new purity fields and/or arguments.
tests/hard_coded/purity/Mmakefile:
tests/hard_coded/purity/impure_func_t5_fixed2.m:
tests/hard_coded/purity/impure_func_t5_fixed2.exp:
tests/hard_coded/purity/impure_func_t5_fixed2.exp2:
tests/hard_coded/purity/impure_pred_t1_fixed3.m:
tests/hard_coded/purity/impure_pred_t1_fixed3.exp:
tests/invalid/purity/Mmakefile:
tests/invalid/purity/impure_func_t5_fixed.m:
tests/invalid/purity/impure_func_t5_fixed.err_exp:
tests/invalid/purity/impure_pred_t1_fixed.m:
tests/invalid/purity/impure_pred_t1_fixed.err_exp:
Add new test cases to test the new feature.
tests/invalid/purity/impure_func_t5.err_exp:
tests/invalid/purity/impure_pred_t1.err_exp:
tests/invalid/purity/impure_pred_t2.err_exp:
tests/invalid/purity/purity.err_exp:
tests/invalid/purity/purity_nonsense.err_exp:
Update the expected error messages for existing test cases.
tests/invalid/purity/.cvsignore:
New file, copied from tests/invalid/.cvsignore.
Workspace: /home/ceres/fjh/ws-ceres2/mercury
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.267
diff -u -d -r1.267 reference_manual.texi
--- doc/reference_manual.texi 17 Jan 2003 05:56:48 -0000 1.267
+++ doc/reference_manual.texi 24 Jan 2003 06:22:29 -0000
@@ -7366,13 +7366,14 @@
@strong{skip this section}.
@menu
-* Purity levels:: Choosing the right level of purity.
-* Purity ordering:: How purity levels are ordered
-* Impurity semantics:: What impure code means.
-* Declaring impurity:: Declaring predicates impure.
-* Impure calls:: Marking a call as impure.
-* Promising purity:: Promising that a predicate is pure.
-* Impurity Example:: A simple example using impurity.
+* Purity levels:: Choosing the right level of purity.
+* Purity ordering:: How purity levels are ordered
+* Impurity semantics:: What impure code means.
+* Declaring impurity:: Declaring predicates impure.
+* Impure calls:: Marking a call as impure.
+* Promising purity:: Promising that a predicate is pure.
+* Impurity Example:: A simple example using impurity.
+* Higher-order impurity:: Using impurity with higher-order code.
@end menu
@@ -7623,6 +7624,102 @@
fail
; semipure Max = get_max
).
+ at end example
+
+ at node Higher-order impurity
+ at section Using impurity with higher-order code
+
+Higher-order code can manipulate impure or semipure predicates and functions,
+provided that explicit purity annotations are used in three places:
+on the higher-order types, on lambda expressions, and on higher-order calls.
+(There are no purity annotations on higher-order insts and modes, however.)
+
+ at menu
+* Purity annotations on higher-order types::
+* Purity annotations on lambda expressions::
+* Purity annotations on higher-order calls::
+ at end menu
+
+ at node Purity annotations on higher-order types
+ at subsection Purity annotations on higher-order types
+
+Ordinary higher-order types, such as @samp{pred(T1, T2)} and
+ at samp{func(T1, T2) = T}, represent only pure predicates or pure functions.
+But for each ordinary higher-order type @var{Foo}, there are two corresponding
+types @samp{semipure @var{Foo}} and @samp{impure @var{Foo}}. These types
+can be used for higher-order code that needs to manipulate impure or
+semipure procedures. For example the type @samp{impure func(int) = int}
+represents impure functions from @samp{int} to @samp{int}.
+
+There are no implicit conversions and no subtyping relationship between
+ordinary higher-order types and the corresponding impure or semipure
+higher-order types. However, a value of an ordinary higher-order
+type can be explicit ``converted'' to a value of an impure (or semipure)
+higher-order type by wrapping it in an impure (or semipure)
+lambda expression that just calls the pure higher-order term.
+
+ at node Purity annotations on lambda expressions
+ at subsection Purity annotations on lambda expressions
+
+Purity annotations are required on lambda expressions that call
+semipure or impure code.
+Lambda expressions can be declared as @samp{semipure} or @samp{impure}
+by including such an annotation before the @samp{pred} or @samp{func}
+identifier in the lambda expression. Such lambda expressions have
+the corresponding @samp{semipure} or @samp{impure} higher-order type.
+For example, the expression
+
+ at example
+ (impure func(X) = Y :- semipure get_max(Y), impure set_max(X))
+ at end example
+
+ at noindent
+is an example of an impure function lambda expression with type
+ at samp{(impure func(int) = int)}, and the expression
+
+ at example
+ (impure pred(X::in, Y::out) is det :-
+ semipure get_max(Y),
+ impure set_max(X))
+ at end example
+is an example of an impure predicate lambda expression
+with type @samp{impure pred(int, int)}.
+
+ at node Purity annotations on higher-order calls
+ at subsection Purity annotations on higher-order calls
+
+Any calls to impure or semipure higher-order terms must be explicitly
+annotated as such. For impure or semipure higher-order predicates,
+the annotation is indicated by putting @samp{impure} or @samp{semipure}
+before the call. For example:
+
+ at example
+ :- func foo(impure pred(int)) = int.
+ :- mode foo(in(pred(out) is det)) = out is det.
+
+ foo(ImpurePred) = X1 + X2 :-
+ % using higher-order syntax
+ impure ImpurePred(X1),
+ % using the call/N syntax
+ impure call(ImpurePred, X2).
+ at end example
+
+For calling impure or semipure higher-order functions, the notation is
+different than what you might expect. In addition to using an @samp{impure}
+or @samp{semipure} operator on the unification which invokes the higher-order
+function application, you must also use @samp{impure_apply}
+or @samp{semipure_apply} rather than using @samp{apply} or higher-order syntax.
+ at c XXX it would be nicer to change the implementation to support
+ at c nice syntax, rather than documenting this hack
+For example:
+
+ at example
+ :- func map(impure func(T1) = T2, list(T1)) = list(T2).
+
+ map(_ImpureFunc, []) = [].
+ map(ImpureFunc, [X|Xs]) = [Y|Ys] :-
+ impure Y = impure_apply(ImpureFunc, X),
+ impure Ys = map(ImpureFunc, Ys).
@end example
@node Pragmas
Index: compiler/assertion.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/assertion.m,v
retrieving revision 1.20
diff -u -d -r1.20 assertion.m
--- compiler/assertion.m 24 Oct 2002 04:36:39 -0000 1.20
+++ compiler/assertion.m 22 Jan 2003 07:36:37 -0000
@@ -602,10 +602,10 @@
equal_unification(functor(ConsId, E, VarsA), functor(ConsId, E, VarsB),
Subst0, Subst) :-
equal_vars(VarsA, VarsB, Subst0, Subst).
-equal_unification(lambda_goal(PredOrFunc, EvalMethod, FixModes, NLVarsA, LVarsA,
- Modes, Det, GoalA),
- lambda_goal(PredOrFunc, EvalMethod, FixModes, NLVarsB, LVarsB,
- Modes, Det, GoalB),
+equal_unification(lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ NLVarsA, LVarsA, Modes, Det, GoalA),
+ lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ NLVarsB, LVarsB, Modes, Det, GoalB),
Subst0, Subst) :-
equal_vars(NLVarsA, NLVarsB, Subst0, Subst1),
equal_vars(LVarsA, LVarsB, Subst1, Subst2),
@@ -835,7 +835,7 @@
;
{ error("assertion__in_interface_check_unify_rhs: type_to_ctor_and_args failed.") }
).
-assertion__in_interface_check_unify_rhs(lambda_goal(_,_,_,_,_,_,_,Goal),
+assertion__in_interface_check_unify_rhs(lambda_goal(_,_,_,_,_,_,_,_,Goal),
_Var, _Context, PredInfo, Module0, Module) -->
assertion__in_interface_check(Goal, PredInfo, Module0, Module).
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.69
diff -u -d -r1.69 bytecode_gen.m
--- compiler/bytecode_gen.m 28 Mar 2002 03:42:41 -0000 1.69
+++ compiler/bytecode_gen.m 22 Jan 2003 15:29:20 -0000
@@ -183,7 +183,7 @@
(
GoalExpr = generic_call(GenericCallType,
ArgVars, ArgModes, Detism),
- ( GenericCallType = higher_order(PredVar, _, _) ->
+ ( GenericCallType = higher_order(PredVar, _, _, _) ->
bytecode_gen__higher_order_call(PredVar, ArgVars,
ArgModes, Detism, ByteInfo0, Code),
ByteInfo = ByteInfo0
Index: compiler/call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/call_gen.m,v
retrieving revision 1.151
diff -u -d -r1.151 call_gen.m
--- compiler/call_gen.m 28 Mar 2002 03:42:42 -0000 1.151
+++ compiler/call_gen.m 22 Jan 2003 16:08:53 -0000
@@ -268,7 +268,7 @@
ExtraLiveVals = []
).
-call_gen__generic_call_info(_, higher_order(PredVar, _, _),
+call_gen__generic_call_info(_, higher_order(PredVar, _, _, _),
do_call_closure, [PredVar - arg_info(1, top_in)], 4).
call_gen__generic_call_info(_, class_method(TCVar, _, _, _),
do_call_class_method, [TCVar - arg_info(1, top_in)], 5).
@@ -325,7 +325,7 @@
list(prog_var)::in, list(prog_var)::in, code_tree::out,
code_info::in, code_info::out) is det.
-call_gen__generic_call_nonvar_setup(higher_order(_, _, _),
+call_gen__generic_call_nonvar_setup(higher_order(_, _, _, _),
InVars, OutVars, Code) -->
code_info__clobber_regs([reg(r, 2), reg(r, 3)]),
{ list__length(InVars, NInVars) },
Index: compiler/continuation_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/continuation_info.m,v
retrieving revision 1.45
diff -u -d -r1.45 continuation_info.m
--- compiler/continuation_info.m 15 Nov 2002 04:50:20 -0000 1.45
+++ compiler/continuation_info.m 22 Jan 2003 16:09:17 -0000
@@ -522,7 +522,7 @@
pred_info_arg_types(PredInfo, ArgTypes),
some([Type], (
list__member(Type, ArgTypes),
- type_is_higher_order(Type, _, _, _)
+ type_is_higher_order(Type, _, _, _, _)
)).
%-----------------------------------------------------------------------------%
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/cse_detection.m,v
retrieving revision 1.73
diff -u -d -r1.73 cse_detection.m
--- compiler/cse_detection.m 22 Jul 2002 06:29:26 -0000 1.73
+++ compiler/cse_detection.m 22 Jan 2003 07:36:48 -0000
@@ -228,7 +228,7 @@
detect_cse_in_goal_2(unify(A,B0,C,D,E), _, InstMap0, CseInfo0, CseInfo, Redo,
unify(A,B,C,D,E)) :-
(
- B0 = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ B0 = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
NonLocalVars, Vars, Modes, Det, Goal0)
->
ModuleInfo = CseInfo0 ^ module_info,
@@ -236,7 +236,7 @@
Vars, Modes, InstMap0, InstMap),
detect_cse_in_goal(Goal0, InstMap, CseInfo0, CseInfo, Redo,
Goal),
- B = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ B = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
NonLocalVars, Vars, Modes, Det, Goal)
;
B = B0,
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.73
diff -u -d -r1.73 dead_proc_elim.m
--- compiler/dead_proc_elim.m 1 Aug 2002 11:52:17 -0000 1.73
+++ compiler/dead_proc_elim.m 22 Jan 2003 07:36:57 -0000
@@ -888,7 +888,7 @@
;
[]
).
-pre_modecheck_examine_unify_rhs(lambda_goal(_, _, _, _, _, _, _, Goal)) -->
+pre_modecheck_examine_unify_rhs(lambda_goal(_, _, _, _, _, _, _, _, Goal)) -->
pre_modecheck_examine_goal(Goal).
:- pred dead_pred_info_add_pred_name(sym_name::in, dead_pred_info::in,
Index: compiler/deep_profiling.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/deep_profiling.m,v
retrieving revision 1.12
diff -u -d -r1.12 deep_profiling.m
--- compiler/deep_profiling.m 8 Nov 2002 00:40:45 -0000 1.12
+++ compiler/deep_profiling.m 22 Jan 2003 16:09:32 -0000
@@ -1145,7 +1145,7 @@
;
CallKind = generic(Generic),
(
- Generic = higher_order(ClosureVar, _, _),
+ Generic = higher_order(ClosureVar, _, _, _),
generate_call(ModuleInfo, "prepare_for_ho_call", 2,
[SiteNumVar, ClosureVar], [], PrepareGoal),
CallSite = higher_order_call(FileName, LineNumber,
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.158
diff -u -d -r1.158 det_analysis.m
--- compiler/det_analysis.m 14 Aug 2002 06:41:27 -0000 1.158
+++ compiler/det_analysis.m 22 Jan 2003 07:37:15 -0000
@@ -594,7 +594,7 @@
det_infer_goal_2(unify(LT, RT0, M, U, C), GoalInfo, InstMap0, SolnContext,
DetInfo, _, _, unify(LT, RT, M, U, C), UnifyDet, Msgs) :-
(
- RT0 = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ RT0 = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
NonLocalVars, Vars, Modes, LambdaDeclaredDet, Goal0)
->
(
@@ -613,7 +613,7 @@
det_check_lambda(LambdaDeclaredDet, LambdaInferredDet,
Goal, GoalInfo, DetInfo, Msgs2),
list__append(Msgs1, Msgs2, Msgs3),
- RT = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ RT = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
NonLocalVars, Vars, Modes, LambdaDeclaredDet, Goal)
;
RT = RT0,
Index: compiler/det_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_util.m,v
retrieving revision 1.23
diff -u -d -r1.23 det_util.m
--- compiler/det_util.m 22 Jul 2002 06:29:28 -0000 1.23
+++ compiler/det_util.m 22 Jan 2003 07:37:22 -0000
@@ -125,7 +125,7 @@
term__var_list_to_term_list(ArgVars, ArgTerms),
cons_id_and_args_to_term(ConsId, ArgTerms, RhsTerm),
term__unify(term__variable(X), RhsTerm, Subst0, Subst).
-interpret_unify(_X, lambda_goal(_POrF, _Method, _Fix, _NonLocals,
+interpret_unify(_X, lambda_goal(_Purity, _POrF, _Method, _Fix, _NonLocals,
_Vars, _Modes, _Det, _Goal), Subst0, Subst) :-
% For ease of implementation we just ignore unifications with
% lambda terms. This is a safe approximation, it just
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/equiv_type.m,v
retrieving revision 1.30
diff -u -d -r1.30 equiv_type.m
--- compiler/equiv_type.m 20 Mar 2002 12:36:08 -0000 1.30
+++ compiler/equiv_type.m 22 Jan 2003 07:03:28 -0000
@@ -707,7 +707,10 @@
equiv_type__replace_in_type(WithType0, TypeVarSet2,
EqvMap, WithType, TypeVarSet,
Info2, Info3),
- ( type_is_higher_order(WithType, PredOrFunc, _, ExtraTypes0) ->
+ (
+ type_is_higher_order(WithType, _Purity, PredOrFunc,
+ _EvalMethod, ExtraTypes0)
+ ->
ExtraTypes = ExtraTypes0,
Errors0 = []
;
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.78
diff -u -d -r1.78 goal_util.m
--- compiler/goal_util.m 1 Nov 2002 07:06:56 -0000 1.78
+++ compiler/goal_util.m 22 Jan 2003 16:01:23 -0000
@@ -451,10 +451,10 @@
functor(Functor, E, ArgVars)) :-
goal_util__rename_var_list(ArgVars0, Must, Subn, ArgVars).
goal_util__rename_unify_rhs(
- lambda_goal(PredOrFunc, EvalMethod, FixModes, NonLocals0,
+ lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes, NonLocals0,
Vars0, Modes, Det, Goal0),
Must, Subn,
- lambda_goal(PredOrFunc, EvalMethod, FixModes, NonLocals,
+ lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes, NonLocals,
Vars, Modes, Det, Goal)) :-
goal_util__rename_var_list(NonLocals0, Must, Subn, NonLocals),
goal_util__rename_var_list(Vars0, Must, Subn, Vars),
@@ -502,8 +502,8 @@
map(prog_var, prog_var), generic_call).
:- mode goal_util__rename_generic_call(in, in, in, out) is det.
-goal_util__rename_generic_call(higher_order(Var0, PredOrFunc, Arity),
- Must, Subn, higher_order(Var, PredOrFunc, Arity)) :-
+goal_util__rename_generic_call(higher_order(Var0, Purity, PredOrFunc, Arity),
+ Must, Subn, higher_order(Var, Purity, PredOrFunc, Arity)) :-
goal_util__rename_var(Var0, Must, Subn, Var).
goal_util__rename_generic_call(class_method(Var0, Method, ClassId, MethodId),
Must, Subn, class_method(Var, Method, ClassId, MethodId)) :-
@@ -671,13 +671,13 @@
goal_util__rhs_goal_vars(functor(_Functor, _, ArgVars), Set0, Set) :-
set__insert_list(Set0, ArgVars, Set).
goal_util__rhs_goal_vars(
- lambda_goal(_, _, _, NonLocals, LambdaVars, _M, _D, Goal - _),
- Set0, Set) :-
+ lambda_goal(_, _, _, _, NonLocals, LambdaVars, _M, _D, Goal - _),
+ Set0, Set) :-
set__insert_list(Set0, NonLocals, Set1),
set__insert_list(Set1, LambdaVars, Set2),
goal_util__goal_vars_2(Goal, Set2, Set).
-goal_util__generic_call_vars(higher_order(Var, _, _), [Var]).
+goal_util__generic_call_vars(higher_order(Var, _, _, _), [Var]).
goal_util__generic_call_vars(class_method(Var, _, _, _), [Var]).
goal_util__generic_call_vars(aditi_builtin(_, _), []).
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.98
diff -u -d -r1.98 higher_order.m
--- compiler/higher_order.m 14 Jan 2003 13:47:43 -0000 1.98
+++ compiler/higher_order.m 22 Jan 2003 16:10:06 -0000
@@ -445,7 +445,7 @@
{ Goal0 = generic_call(GenericCall, Args, _, _) - GoalInfo },
(
{
- GenericCall = higher_order(Var, _, _),
+ GenericCall = higher_order(Var, _, _, _),
MaybeMethod = no
;
GenericCall = class_method(Var, Method, _, _),
@@ -1088,7 +1088,7 @@
{ map__contains(NewPreds, proc(PredId, ProcId)) },
{ proc_info_vartypes(ProcInfo0, VarTypes0) },
{ map__lookup(VarTypes0, LVar, LVarType) },
- { type_is_higher_order(LVarType, _, _, ArgTypes) }
+ { type_is_higher_order(LVarType, _, _, _, ArgTypes) }
->
% Create variables to represent
{ proc_info_create_vars_from_types(ProcInfo0,
@@ -1326,7 +1326,7 @@
% able to do user guided type specialization.
CalleeStatus \= imported(_),
CalleeStatus \= external(_),
- type_is_higher_order(CalleeArgType, _, _, _)
+ type_is_higher_order(CalleeArgType, _, _, _, _)
;
true
)
@@ -2078,7 +2078,7 @@
HaveSpecialPreds = yes,
find_special_proc(SpecialPredType, SpecialId,
SymName, SpecialPredId, SpecialProcId, Info0, Info),
- ( type_is_higher_order(SpecialPredType, _, _, _) ->
+ ( type_is_higher_order(SpecialPredType, _, _, _, _) ->
% builtin_*_pred are special cases which
% doesn't need the type-info arguments.
CallArgs = SpecialPredArgs
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.99
diff -u -d -r1.99 hlds_goal.m
--- compiler/hlds_goal.m 9 Sep 2002 07:48:12 -0000 1.99
+++ compiler/hlds_goal.m 23 Jan 2003 06:13:49 -0000
@@ -219,6 +219,7 @@
:- type generic_call
---> higher_order(
prog_var,
+ purity,
pred_or_func, % call/N (pred) or apply/N (func)
arity % number of arguments (including the
% higher-order term)
@@ -302,6 +303,7 @@
list(prog_var)
)
; lambda_goal(
+ purity,
pred_or_func,
lambda_eval_method,
% should be `normal' except for
@@ -1106,15 +1108,15 @@
% Predicates dealing with generic_calls
%
-hlds_goal__generic_call_id(higher_order(_, PorF, Arity),
- generic_call(higher_order(PorF, Arity))).
+hlds_goal__generic_call_id(higher_order(_, Purity, PorF, Arity),
+ generic_call(higher_order(Purity, PorF, Arity))).
hlds_goal__generic_call_id(
class_method(_, _, ClassId, MethodId),
generic_call(class_method(ClassId, MethodId))).
hlds_goal__generic_call_id(aditi_builtin(Builtin, Name),
generic_call(aditi_builtin(Builtin, Name))).
-generic_call_pred_or_func(higher_order(_, PredOrFunc, _)) = PredOrFunc.
+generic_call_pred_or_func(higher_order(_, _, PredOrFunc, _)) = PredOrFunc.
generic_call_pred_or_func(class_method(_, _, _, CallId)) =
simple_call_id_pred_or_func(CallId).
generic_call_pred_or_func(aditi_builtin(_, CallId)) =
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.293
diff -u -d -r1.293 hlds_out.m
--- compiler/hlds_out.m 17 Jan 2003 05:56:46 -0000 1.293
+++ compiler/hlds_out.m 24 Jan 2003 06:45:35 -0000
@@ -462,7 +462,8 @@
:- pred hlds_out__write_generic_call_id(generic_call_id, io__state, io__state).
:- mode hlds_out__write_generic_call_id(in, di, uo) is det.
-hlds_out__write_generic_call_id(higher_order(PredOrFunc, _)) -->
+hlds_out__write_generic_call_id(higher_order(Purity, PredOrFunc, _)) -->
+ write_purity_prefix(Purity),
io__write_string("higher-order "),
hlds_out__write_pred_or_func(PredOrFunc),
io__write_string(" call").
@@ -528,8 +529,8 @@
io__write_string("argument "),
io__write_int(ArgNum)
).
-hlds_out__write_arg_number(generic_call(higher_order(PredOrFunc, Arity)),
- ArgNum) -->
+hlds_out__write_arg_number(generic_call(
+ higher_order(_Purity, PredOrFunc, Arity)), ArgNum) -->
( { PredOrFunc = function, ArgNum = Arity } ->
io__write_string("the return value")
;
@@ -1493,7 +1494,7 @@
ModuleInfo, VarSet, AppendVarnums, Indent, Follow, _) -->
% XXX we should print more info here
(
- { GenericCall = higher_order(PredVar, PredOrFunc, _) },
+ { GenericCall = higher_order(PredVar, Purity, PredOrFunc, _) },
globals__io_lookup_string_option(dump_hlds_options, Verbose),
hlds_out__write_indent(Indent),
(
@@ -1504,6 +1505,7 @@
;
[]
),
+ write_purity_prefix(Purity),
hlds_out__write_functor(term__atom("call"),
[PredVar|ArgVars], VarSet, AppendVarnums)
;
@@ -1517,6 +1519,7 @@
),
{ pred_args_to_func_args([PredVar | ArgVars],
FuncArgVars, FuncRetVar) },
+ write_purity_prefix(Purity),
mercury_output_var(FuncRetVar, VarSet, AppendVarnums),
io__write_string(" = "),
hlds_out__write_functor(term__atom("apply"), FuncArgVars,
@@ -2229,12 +2232,13 @@
).
hlds_out__write_unify_rhs_3(
- lambda_goal(PredOrFunc, EvalMethod, _, NonLocals, Vars, Modes,
- Det, Goal),
+ lambda_goal(Purity, PredOrFunc, EvalMethod, _, NonLocals, Vars,
+ Modes, Det, Goal),
ModuleInfo, VarSet, InstVarSet, AppendVarnums, Indent,
MaybeType, TypeQual)
-->
{ Indent1 is Indent + 1 },
+ write_purity_prefix(Purity),
{
EvalMethod = normal,
EvalStr = ""
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.113
diff -u -d -r1.113 hlds_pred.m
--- compiler/hlds_pred.m 15 Nov 2002 04:50:21 -0000 1.113
+++ compiler/hlds_pred.m 22 Jan 2003 11:18:18 -0000
@@ -94,7 +94,7 @@
.
:- type generic_call_id
- ---> higher_order(pred_or_func, arity)
+ ---> higher_order(purity, pred_or_func, arity)
; class_method(class_id, simple_call_id)
; aditi_builtin(aditi_builtin, simple_call_id)
.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.126
diff -u -d -r1.126 intermod.m
--- compiler/intermod.m 14 Jan 2003 16:42:26 -0000 1.126
+++ compiler/intermod.m 22 Jan 2003 07:41:24 -0000
@@ -691,8 +691,8 @@
intermod__module_qualify_unify_rhs(_, var(Var), var(Var), yes) --> [].
intermod__module_qualify_unify_rhs(_LVar,
- lambda_goal(A,EvalMethod,C,D,E,Modes,G,Goal0),
- lambda_goal(A,EvalMethod,C,D,E,Modes,G,Goal), DoWrite) -->
+ lambda_goal(A,B,EvalMethod,C,D,E,Modes,G,Goal0),
+ lambda_goal(A,B,EvalMethod,C,D,E,Modes,G,Goal), DoWrite) -->
( { EvalMethod = (aditi_top_down) } ->
% XXX Predicates which build this type of lambda expression
% can't be exported because the importing modules have
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.78
diff -u -d -r1.78 lambda.m
--- compiler/lambda.m 22 Jul 2002 06:29:35 -0000 1.78
+++ compiler/lambda.m 22 Jan 2003 17:02:49 -0000
@@ -232,14 +232,14 @@
lambda__process_goal_2(unify(XVar, Y, Mode, Unification, Context), GoalInfo,
Unify - GoalInfo) -->
- ( { Y = lambda_goal(PredOrFunc, EvalMethod, _, NonLocalVars, Vars,
- Modes, Det, LambdaGoal0) } ->
+ ( { Y = lambda_goal(Purity, PredOrFunc, EvalMethod, _, NonLocalVars,
+ Vars, Modes, Det, LambdaGoal0) } ->
% first, process the lambda goal recursively, in case it
% contains some nested lambda expressions.
lambda__process_goal(LambdaGoal0, LambdaGoal1),
% then, convert the lambda expression into a new predicate
- lambda__process_lambda(PredOrFunc, EvalMethod, Vars,
+ lambda__process_lambda(Purity, PredOrFunc, EvalMethod, Vars,
Modes, Det, NonLocalVars, LambdaGoal1,
Unification, Y1, Unification1),
{ Unify = unify(XVar, Y1, Mode, Unification1, Context) }
@@ -303,14 +303,14 @@
lambda__process_goal(Goal0, Goal),
lambda__process_cases(Cases0, Cases).
-:- pred lambda__process_lambda(pred_or_func, lambda_eval_method,
+:- pred lambda__process_lambda(purity, pred_or_func, lambda_eval_method,
list(prog_var), list(mode), determinism, list(prog_var),
hlds_goal, unification, unify_rhs, unification,
lambda_info, lambda_info).
-:- mode lambda__process_lambda(in, in, in, in, in, in, in, in, out, out,
+:- mode lambda__process_lambda(in, in, in, in, in, in, in, in, in, out, out,
in, out) is det.
-lambda__process_lambda(PredOrFunc, EvalMethod, Vars, Modes, Detism,
+lambda__process_lambda(Purity, PredOrFunc, EvalMethod, Vars, Modes, Detism,
OrigNonLocals0, LambdaGoal, Unification0, Functor,
Unification, LambdaInfo0, LambdaInfo) :-
LambdaInfo0 = lambda_info(VarSet, VarTypes, _PredConstraints, TVarSet,
@@ -501,6 +501,7 @@
list__append(ArgModes1, Modes, AllArgModes),
map__apply_to_list(AllArgVars, VarTypes, ArgTypes),
+ purity_to_markers(Purity, LambdaMarkers0),
(
% Pass through the aditi markers for
% aggregate query closures.
@@ -530,18 +531,20 @@
; Marker = aditi_no_memo
)),
MarkerList0, MarkerList),
- marker_list_to_markers(MarkerList, LambdaMarkers)
+ LambdaMarkers = list__foldl((func(LMs0, Mrk) = LMs :-
+ add_marker(Mrk, LMs0, LMs)),
+ MarkerList, LambdaMarkers0)
;
EvalMethod = (aditi_bottom_up)
->
- marker_list_to_markers([aditi], LambdaMarkers)
+ add_marker(LambdaMarkers0, aditi, LambdaMarkers)
;
EvalMethod = (aditi_top_down)
->
- marker_list_to_markers([(aditi_top_down)],
+ add_marker(LambdaMarkers0, aditi_top_down,
LambdaMarkers)
;
- init_markers(LambdaMarkers)
+ LambdaMarkers = LambdaMarkers0
),
% Now construct the proc_info and pred_info for the new
@@ -562,7 +565,7 @@
set__init(Assertions),
pred_info_create(ModuleName, PredName, TVarSet, ExistQVars,
- ArgTypes, true, LambdaContext, local, LambdaMarkers,
+ ArgTypes, true, LambdaContext, local, LambdaMarkers,
PredOrFunc, Constraints, Owner, Assertions, ProcInfo,
ProcId, PredInfo),
Index: compiler/magic.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic.m,v
retrieving revision 1.31
diff -u -d -r1.31 magic.m
--- compiler/magic.m 22 Jul 2002 06:29:36 -0000 1.31
+++ compiler/magic.m 22 Jan 2003 15:05:31 -0000
@@ -570,7 +570,7 @@
{ type_util__remove_aditi_state(ArgTypes0, ArgModes0, ArgModes) },
{ partition_args(ModuleInfo, ArgModes, ArgModes, InputModes, _) },
{ partition_args(ModuleInfo, ArgModes, ArgTypes, InputTypes, _) },
- { construct_higher_order_type(predicate, (aditi_bottom_up),
+ { construct_higher_order_type((pure), predicate, (aditi_bottom_up),
InputTypes, Type) },
{ GetOutputMode = lambda([ArgMode::in, OutputMode::out] is det, (
mode_get_insts(ModuleInfo, ArgMode, _, OutputInst),
@@ -947,7 +947,7 @@
%
{ list__index1_det(MagicTypes, CurrVar, MagicType) },
{
- type_is_higher_order(MagicType, predicate,
+ type_is_higher_order(MagicType, (pure), predicate,
(aditi_bottom_up), ArgTypes1)
->
ArgTypes = ArgTypes1
@@ -1050,7 +1050,7 @@
map__apply_to_list(InputArgs, VarTypes0, InputVarTypes),
- construct_higher_order_type(predicate, (aditi_bottom_up),
+ construct_higher_order_type((pure), predicate, (aditi_bottom_up),
InputVarTypes, ClosureVarType),
list__map(magic_util__mode_to_output_mode(ModuleInfo0),
InputArgModes, MagicArgModes),
@@ -1072,7 +1072,7 @@
InputGoalInfo),
list__length(InputArgs, Arity),
InputGoal = generic_call(
- higher_order(ClosureVar, predicate, Arity),
+ higher_order(ClosureVar, (pure), predicate, Arity),
InputArgs, MagicArgModes, nondet) - InputGoalInfo,
ClosureInst = ground(shared,
@@ -1357,7 +1357,7 @@
nondet, GoalInfo0) },
{ list__length(InputArgs0, Arity) },
{ Goal0 = generic_call(
- higher_order(CurrPredVar, predicate, Arity),
+ higher_order(CurrPredVar, (pure), predicate, Arity),
InputArgs0, OutputModes0, nondet) - GoalInfo0 },
( { IsContext = yes(ArgsAL) } ->
% Create assignments to assign to the extra arguments.
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.24
diff -u -d -r1.24 magic_util.m
--- compiler/magic_util.m 14 Jan 2003 16:42:27 -0000 1.24
+++ compiler/magic_util.m 22 Jan 2003 15:25:16 -0000
@@ -737,12 +737,12 @@
ProcInfo0, ProcInfo) :-
list__index1_det(MagicTypes, CurrVar, MagicType),
(
- type_is_higher_order(MagicType, predicate,
+ type_is_higher_order(MagicType, (pure), predicate,
(aditi_bottom_up), ArgTypes1)
->
ArgTypes = ArgTypes1,
- construct_higher_order_type(predicate, (aditi_bottom_up),
- ArgTypes, ClosureType),
+ construct_higher_order_type((pure), predicate,
+ (aditi_bottom_up), ArgTypes, ClosureType),
proc_info_create_var_from_type(ProcInfo0, ClosureType, no,
InputVar, ProcInfo)
;
@@ -1310,7 +1310,7 @@
magic_info_get_module_info(ModuleInfo),
( { type_is_atomic(ArgType, ModuleInfo) } ->
{ Errors = Errors0 }
- ; { type_is_higher_order(ArgType, _, _, _) } ->
+ ; { type_is_higher_order(ArgType, _, _, _, _) } ->
% Higher-order types are not allowed.
{ set__insert(Errors0, higher_order, Errors) }
; { type_is_tuple(ArgType, TupleArgTypes) } ->
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.430
diff -u -d -r1.430 make_hlds.m
--- compiler/make_hlds.m 14 Jan 2003 16:42:27 -0000 1.430
+++ compiler/make_hlds.m 23 Jan 2003 05:02:10 -0000
@@ -5471,8 +5471,8 @@
warn_singletons([X | Vars], NonLocals, QuantVars, VarSet,
Context, CallPredId).
-warn_singletons_in_unify(X, lambda_goal(_PredOrFunc, _Eval, _Fix, _NonLocals,
- LambdaVars, _Modes, _Det, LambdaGoal),
+warn_singletons_in_unify(X, lambda_goal(_Purity, _PredOrFunc, _Eval, _Fix,
+ _NonLocals, LambdaVars, _Modes, _Det, LambdaGoal),
GoalInfo, QuantVars, VarSet, CallPredId, MI) -->
%
% warn if any lambda-quantified variables occur only in the quantifier
@@ -6395,26 +6395,13 @@
Modes = [],
Det = erroneous,
- GenericCall = higher_order(PredVar,
+ GenericCall = higher_order(PredVar, Purity,
predicate, Arity),
Call = generic_call(GenericCall,
RealHeadVars, Modes, Det),
- hlds_goal__generic_call_id(GenericCall, CallId),
- Purity1 = pure
- },
- (
- { Purity = pure }
- ->
- []
- ;
- prog_out__write_context(Context),
- io__write_string("Warning: unnecessary `"),
- write_purity(Purity),
- io__write_string("' marker.\n"),
- prog_out__write_context(Context),
- io__write_string(" Higher-order goals are always pure.\n")
- )
+ hlds_goal__generic_call_id(GenericCall, CallId)
+ }
;
{
% initialize some fields to junk
@@ -6424,13 +6411,12 @@
MaybeUnifyContext = no,
Call = call(PredId, ModeId, HeadVars, not_builtin,
MaybeUnifyContext, Name),
- CallId = call(predicate - Name/Arity),
- Purity1 = Purity
+ CallId = call(predicate - Name/Arity)
}
),
{ goal_info_init(Context, GoalInfo0) },
{ add_goal_info_purity_feature(GoalInfo0,
- Purity1, GoalInfo) },
+ Purity, GoalInfo) },
{ Goal0 = Call - GoalInfo },
{ record_called_pred_or_func(predicate, Name, Arity,
@@ -7196,7 +7182,7 @@
% Build the lambda expression for the modification condition.
{ make_atomic_unification(LambdaVar,
- lambda_goal(LambdaPredOrFunc, EvalMethod,
+ lambda_goal((pure), LambdaPredOrFunc, EvalMethod,
FixModes, LambdaNonLocals,
HeadArgs, LambdaModes, Detism, PredGoal),
Context, MainContext, [], LambdaConstruct,
@@ -7888,6 +7874,7 @@
parse_lambda_expression(LambdaExpressionTerm,
Vars0, Modes0, Det0)
->
+ LambdaPurity = (pure),
PredOrFunc = predicate,
EvalMethod = EvalMethod0, Vars1 = Vars0,
Modes1 = Modes0, Det1 = Det0, GoalTerm1 = GoalTerm0
@@ -7896,7 +7883,8 @@
% same semantics as lambda expressions, different syntax
% (the original lambda expression syntax is now deprecated)
parse_rule_term(Context, RHS, HeadTerm0, GoalTerm1),
- term__coerce(HeadTerm0, HeadTerm),
+ term__coerce(HeadTerm0, HeadTerm1),
+ parse_purity_annotation(HeadTerm1, LambdaPurity, HeadTerm),
(
parse_pred_expression(HeadTerm, EvalMethod0,
Vars0, Modes0, Det0)
@@ -7917,8 +7905,8 @@
{ Det = Det1 },
{ term__coerce(GoalTerm1, GoalTerm) },
{ parse_goal(GoalTerm, VarSet1, ParsedGoal, VarSet2) },
- build_lambda_expression(X, PredOrFunc, EvalMethod, Vars1,
- Modes, Det, ParsedGoal, VarSet2,
+ build_lambda_expression(X, LambdaPurity, PredOrFunc,
+ EvalMethod, Vars1, Modes, Det, ParsedGoal, VarSet2,
Context, MainContext, SubContext, Goal, VarSet,
Info2, Info, SInfo1),
{ SInfo = SInfo1 }
@@ -7930,7 +7918,8 @@
% as a DCG goal.
F = term__atom("-->"),
Args = [PredTerm0, GoalTerm0],
- term__coerce(PredTerm0, PredTerm),
+ term__coerce(PredTerm0, PredTerm1),
+ parse_purity_annotation(PredTerm1, DCGLambdaPurity, PredTerm),
parse_dcg_pred_expression(PredTerm, EvalMethod,
Vars0, Modes0, Det)
}
@@ -7942,8 +7931,8 @@
ParsedGoal, DCG0, DCGn, VarSet2) },
{ list__append(Vars0, [term__variable(DCG0),
term__variable(DCGn)], Vars1) },
- build_lambda_expression(X, predicate, EvalMethod, Vars1,
- Modes, Det, ParsedGoal, VarSet2,
+ build_lambda_expression(X, DCGLambdaPurity, predicate,
+ EvalMethod, Vars1, Modes, Det, ParsedGoal, VarSet2,
Context, MainContext, SubContext, Goal0, VarSet,
Info1, Info, SInfo1),
{ SInfo = SInfo1 },
@@ -8101,6 +8090,19 @@
)
).
+:- pred parse_purity_annotation(term(T), purity, term(T)).
+:- mode parse_purity_annotation(in, out, out) is det.
+parse_purity_annotation(Term0, Purity, Term) :-
+ (
+ Term0 = term__functor(term__atom(PurityName), [Term1], _),
+ purity_name(Purity0, PurityName)
+ ->
+ Purity = Purity0,
+ Term = Term1
+ ;
+ Purity = (pure),
+ Term = Term0
+ ).
% Handle `f(...) = X' in the same way as `X = f(...)'.
@@ -8165,14 +8167,15 @@
transform_info, io__state, io__state).
:- mode check_expr_purity(in, in, in, out, di, uo) is det.
check_expr_purity(Purity, Context, Info0, Info) -->
- ( { Purity \= pure } ->
- impure_unification_expr_error(Context, Purity),
- { module_info_incr_errors(Info0 ^ module_info,
- ModuleInfo) },
- { Info = Info0 ^ module_info := ModuleInfo }
- ;
- { Info = Info0 }
- ).
+ ( { Purity \= pure } ->
+ impure_unification_expr_error(Context, Purity),
+ { module_info_incr_errors(Info0 ^ module_info,
+ ModuleInfo) },
+ { Info = Info0 ^ module_info := ModuleInfo }
+ ;
+ { Info = Info0 }
+ ).
+
%-----------------------------------------------------------------------------%
% Parse a term of the form `Head :- Body', treating
@@ -8194,15 +8197,16 @@
%-----------------------------------------------------------------------------%
-:- pred build_lambda_expression(prog_var, pred_or_func, lambda_eval_method,
- list(prog_term), list(mode), determinism, goal, prog_varset,
+:- pred build_lambda_expression(prog_var, purity, pred_or_func,
+ lambda_eval_method, list(prog_term), list(mode), determinism,
+ goal, prog_varset,
prog_context, unify_main_context, unify_sub_contexts,
hlds_goal, prog_varset, transform_info, transform_info,
svar_info, io__state, io__state).
-:- mode build_lambda_expression(in, in, in, in, in, in, in, in,
+:- mode build_lambda_expression(in, in, in, in, in, in, in, in, in,
in, in, in, out, out, in, out, in, di, uo) is det.
-build_lambda_expression(X, PredOrFunc, EvalMethod, Args0, Modes, Det,
+build_lambda_expression(X, Purity, PredOrFunc, EvalMethod, Args0, Modes, Det,
ParsedGoal, VarSet0, Context, MainContext, SubContext,
Goal, VarSet, Info1, Info, SInfo0) -->
%
@@ -8310,9 +8314,9 @@
{ set__to_sorted_list(LambdaGoalVars2, LambdaNonLocals) },
{ make_atomic_unification(X,
- lambda_goal(PredOrFunc, EvalMethod, modes_are_ok,
- LambdaNonLocals, LambdaVars, Modes, Det,
- HLDS_Goal),
+ lambda_goal(Purity, PredOrFunc, EvalMethod,
+ modes_are_ok, LambdaNonLocals, LambdaVars,
+ Modes, Det, HLDS_Goal),
Context, MainContext, SubContext, Goal, Info3, Info) }
).
@@ -8366,7 +8370,7 @@
Rhs = var(_),
Info = Info0
;
- Rhs = lambda_goal(_, _, _, _, _, _, _, _),
+ Rhs = lambda_goal(_, _, _, _, _, _, _, _, _),
Info = Info0
;
Rhs = functor(ConsId, _, _),
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.35
diff -u -d -r1.35 ml_call_gen.m
--- compiler/ml_call_gen.m 4 Jun 2002 14:56:02 -0000 1.35
+++ compiler/ml_call_gen.m 22 Jan 2003 16:21:28 -0000
@@ -178,7 +178,7 @@
% compute the function address
%
(
- { GenericCall = higher_order(ClosureVar, _PredOrFunc,
+ { GenericCall = higher_order(ClosureVar, _Purity, _PredOrFunc,
_Arity) },
ml_gen_var(ClosureVar, ClosureLval),
{ FieldId = offset(const(int_const(1))) },
Index: compiler/ml_closure_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_closure_gen.m,v
retrieving revision 1.13
diff -u -d -r1.13 ml_closure_gen.m
--- compiler/ml_closure_gen.m 5 Sep 2002 21:26:37 -0000 1.13
+++ compiler/ml_closure_gen.m 22 Jan 2003 16:39:04 -0000
@@ -685,6 +685,7 @@
{ ml_gen_info_get_module_info(Info, ModuleInfo) },
{ module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
PredInfo, ProcInfo) },
+ { pred_info_get_purity(PredInfo, Purity) },
{ pred_info_arg_types(PredInfo, ProcArgTypes) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
{ proc_info_headvars(ProcInfo, ProcHeadVars) },
@@ -752,7 +753,7 @@
{ HigherOrderArgTypes = list__duplicate(list__length(WrapperArgTypes),
c_pointer_type) },
{ LambdaEvalMethod = normal },
- { construct_higher_order_type(PredOrFunc, LambdaEvalMethod,
+ { construct_higher_order_type(Purity, PredOrFunc, LambdaEvalMethod,
HigherOrderArgTypes, ClosureActualType) },
ml_gen_maybe_gc_trace_code(ClosureArgName, ClosureArgDeclType,
ClosureActualType, Context, ClosureArgGCTraceCode),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.147
diff -u -d -r1.147 mode_util.m
--- compiler/mode_util.m 14 Jan 2003 16:42:28 -0000 1.147
+++ compiler/mode_util.m 22 Jan 2003 08:02:44 -0000
@@ -698,7 +698,7 @@
).
propagate_ctor_info(ground(Uniq, none), Type, Constructors, ModuleInfo, Inst)
:-
- ( type_is_higher_order(Type, function, _, ArgTypes) ->
+ ( type_is_higher_order(Type, _Purity, function, _, ArgTypes) ->
default_higher_order_func_inst(ArgTypes, ModuleInfo,
HigherOrderInstInfo),
Inst = ground(Uniq, higher_order(HigherOrderInstInfo))
@@ -713,7 +713,7 @@
PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, Det),
PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
(
- type_is_higher_order(Type, PredOrFunc, _, ArgTypes),
+ type_is_higher_order(Type, _Purity, PredOrFunc, _, ArgTypes),
list__same_length(ArgTypes, Modes0)
->
propagate_types_into_mode_list(ArgTypes, ModuleInfo,
@@ -762,7 +762,7 @@
propagate_ctor_info_lazily(ground(Uniq, none), Type0, Subst, ModuleInfo, Inst)
:-
apply_type_subst(Type0, Subst, Type),
- ( type_is_higher_order(Type, function, _, ArgTypes) ->
+ ( type_is_higher_order(Type, _Purity, function, _, ArgTypes) ->
default_higher_order_func_inst(ArgTypes, ModuleInfo,
HigherOrderInstInfo),
Inst = ground(Uniq, higher_order(HigherOrderInstInfo))
@@ -782,7 +782,7 @@
PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
apply_type_subst(Type0, Subst, Type),
(
- type_is_higher_order(Type, PredOrFunc, _, ArgTypes),
+ type_is_higher_order(Type, _Purity, PredOrFunc, _, ArgTypes),
list__same_length(ArgTypes, Modes0)
->
propagate_types_into_mode_list(ArgTypes, ModuleInfo,
@@ -1274,7 +1274,7 @@
(
RecomputeAtomic = no,
goal_is_atomic(Goal0),
- Goal0 \= unify(_,lambda_goal(_,_,_,_,_,_,_,_),_,_,_)
+ Goal0 \= unify(_,lambda_goal(_,_,_,_,_,_,_,_,_),_,_,_)
% Lambda expressions always need to be processed.
->
Goal = Goal0,
@@ -1390,16 +1390,16 @@
unify(A, Rhs, UniMode, Uni, E), VarTypes, InstMap0,
InstMapDelta) -->
(
- { Rhs0 = lambda_goal(PorF, EvalMethod, FixModes, NonLocals,
- LambdaVars, Modes, Det, Goal0) }
+ { Rhs0 = lambda_goal(Purity, PorF, EvalMethod, FixModes,
+ NonLocals, LambdaVars, Modes, Det, Goal0) }
->
ModuleInfo0 =^ module_info,
{ instmap__pre_lambda_update(ModuleInfo0, LambdaVars, Modes,
InstMap0, InstMap) },
recompute_instmap_delta_1(Atomic, Goal0, Goal, VarTypes,
InstMap, _),
- { Rhs = lambda_goal(PorF, EvalMethod, FixModes, NonLocals,
- LambdaVars, Modes, Det, Goal) }
+ { Rhs = lambda_goal(Purity, PorF, EvalMethod, FixModes,
+ NonLocals, LambdaVars, Modes, Det, Goal) }
;
{ Rhs = Rhs0 }
),
@@ -1794,8 +1794,8 @@
strip_builtin_qualifiers_from_ground_inst_info(none, none).
strip_builtin_qualifiers_from_ground_inst_info(higher_order(Pred0),
higher_order(Pred)) :-
- Pred0 = pred_inst_info(Uniq, Modes0, Det),
- Pred = pred_inst_info(Uniq, Modes, Det),
+ Pred0 = pred_inst_info(PorF, Modes0, Det),
+ Pred = pred_inst_info(PorF, Modes, Det),
strip_builtin_qualifiers_from_mode_list(Modes0, Modes).
%-----------------------------------------------------------------------------%
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.40
diff -u -d -r1.40 modecheck_call.m
--- compiler/modecheck_call.m 20 Mar 2002 12:36:55 -0000 1.40
+++ compiler/modecheck_call.m 22 Jan 2003 07:12:35 -0000
@@ -102,7 +102,7 @@
GroundInstInfo = none,
mode_info_get_var_types(ModeInfo0, VarTypes),
map__lookup(VarTypes, PredVar, Type),
- type_is_higher_order(Type, function, _, ArgTypes),
+ type_is_higher_order(Type, _Purity, function, _, ArgTypes),
PredInstInfo = pred_inst_info_standard_func_mode(
list__length(ArgTypes))
),
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.52
diff -u -d -r1.52 modecheck_unify.m
--- compiler/modecheck_unify.m 22 Jul 2002 06:29:42 -0000 1.52
+++ compiler/modecheck_unify.m 22 Jan 2003 08:04:23 -0000
@@ -133,7 +133,7 @@
%
(
% check if variable has a higher-order type
- type_is_higher_order(TypeOfX, _, EvalMethod, PredArgTypes),
+ type_is_higher_order(TypeOfX, Purity, _, EvalMethod, PredArgTypes),
ConsId0 = pred_const(PredId, ProcId, _)
->
%
@@ -141,7 +141,7 @@
%
mode_info_get_varset(ModeInfo0, VarSet0),
mode_info_get_context(ModeInfo0, Context),
- convert_pred_to_lambda_goal(EvalMethod,
+ convert_pred_to_lambda_goal(Purity, EvalMethod,
X0, PredId, ProcId, ArgVars0, PredArgTypes,
UnifyContext, GoalInfo0, Context,
ModuleInfo0, VarSet0, VarTypes0,
@@ -164,7 +164,7 @@
).
modecheck_unification(X,
- lambda_goal(PredOrFunc, EvalMethod, _, ArgVars,
+ lambda_goal(Purity, PredOrFunc, EvalMethod, _, ArgVars,
Vars, Modes0, Det, Goal0),
Unification0, UnifyContext, _GoalInfo,
unify(X, RHS, Mode, Unification, UnifyContext),
@@ -313,8 +313,8 @@
% Now modecheck the unification of X with the lambda-expression.
%
- RHS0 = lambda_goal(PredOrFunc, EvalMethod, modes_are_ok,
- ArgVars, Vars, Modes, Det, Goal),
+ RHS0 = lambda_goal(Purity, PredOrFunc, EvalMethod,
+ modes_are_ok, ArgVars, Vars, Modes, Det, Goal),
modecheck_unify_lambda(X, PredOrFunc, ArgVars, Modes,
Det, RHS0, Unification0, Mode,
RHS, Unification, ModeInfo12, ModeInfo)
@@ -335,7 +335,7 @@
error("modecheck_unification(lambda): very strange var")
),
% return any old garbage
- RHS = lambda_goal(PredOrFunc, EvalMethod, modes_are_ok,
+ RHS = lambda_goal(Purity, PredOrFunc, EvalMethod, modes_are_ok,
ArgVars, Vars, Modes0, Det, Goal0),
Mode = (free -> free) - (free -> free),
Unification = Unification0
@@ -959,7 +959,7 @@
%
% check that we're not trying to do a higher-order unification
%
- type_is_higher_order(Type, PredOrFunc, _, _)
+ type_is_higher_order(Type, _, PredOrFunc, _, _)
->
% We do not want to report this as an error
% if it occurs in a compiler-generated
@@ -1057,7 +1057,7 @@
instmap__is_reachable(InstMap)
->
(
- RHS0 = lambda_goal(_, EvalMethod, _,
+ RHS0 = lambda_goal(_, _, EvalMethod, _,
_, _, _, _, Goal),
Goal = call(PredId, ProcId, _, _, _, _) - _
->
@@ -1173,7 +1173,7 @@
CanFail = can_fail,
mode_info_get_instmap(ModeInfo0, InstMap0),
(
- type_is_higher_order(TypeOfX, PredOrFunc,
+ type_is_higher_order(TypeOfX, _, PredOrFunc,
_, _),
instmap__is_reachable(InstMap0)
->
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.261
diff -u -d -r1.261 modes.m
--- compiler/modes.m 26 Jul 2002 04:18:24 -0000 1.261
+++ compiler/modes.m 22 Jan 2003 15:29:59 -0000
@@ -1159,7 +1159,7 @@
{ hlds_goal__generic_call_id(GenericCall, CallId) },
mode_info_set_call_context(call(CallId)),
(
- { GenericCall = higher_order(PredVar, PredOrFunc, _) },
+ { GenericCall = higher_order(PredVar, _, PredOrFunc, _) },
modecheck_higher_order_call(PredOrFunc, PredVar,
Args0, Modes, Det, Args, ExtraGoals),
{ AllArgs0 = [PredVar | Args0] },
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.82
diff -u -d -r1.82 module_qual.m
--- compiler/module_qual.m 14 Jan 2003 16:42:28 -0000 1.82
+++ compiler/module_qual.m 22 Jan 2003 07:21:05 -0000
@@ -839,7 +839,7 @@
( { is_builtin_atomic_type(TypeCtor0) } ->
{ TypeCtor = TypeCtor0 },
{ Info1 = Info0 }
- ; { type_ctor_is_higher_order(TypeCtor0, _, _) } ->
+ ; { type_ctor_is_higher_order(TypeCtor0, _, _, _) } ->
{ TypeCtor = TypeCtor0 },
{ Info1 = Info0 }
; { type_ctor_is_tuple(TypeCtor0) } ->
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.20
diff -u -d -r1.20 pd_util.m
--- compiler/pd_util.m 28 Mar 2002 03:43:30 -0000 1.20
+++ compiler/pd_util.m 22 Jan 2003 16:24:26 -0000
@@ -1111,8 +1111,8 @@
% Check that two `generic_call' goals are equivalent.
:- pred match_generic_call(generic_call::in, generic_call::in) is semidet.
-match_generic_call(higher_order(_, PredOrFunc, Arity),
- higher_order(_, PredOrFunc, Arity)).
+match_generic_call(higher_order(_, Purity, PredOrFunc, Arity),
+ higher_order(_, Purity, PredOrFunc, Arity)).
match_generic_call(class_method(_, MethodNum, ClassId, CallId),
class_method(_, MethodNum, ClassId, CallId)).
match_generic_call(aditi_builtin(Builtin1, CallId),
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.229
diff -u -d -r1.229 polymorphism.m
--- compiler/polymorphism.m 25 Sep 2002 06:49:11 -0000 1.229
+++ compiler/polymorphism.m 24 Jan 2003 07:01:49 -0000
@@ -284,12 +284,12 @@
:- mode polymorphism__get_special_proc(in, in, in, out, out, out) is semidet.
% convert a higher-order pred term to a lambda goal
-:- pred convert_pred_to_lambda_goal(lambda_eval_method,
+:- pred convert_pred_to_lambda_goal(purity, lambda_eval_method,
prog_var, pred_id, proc_id, list(prog_var), list(type),
unify_context, hlds_goal_info, context,
module_info, prog_varset, map(prog_var, type),
unify_rhs, prog_varset, map(prog_var, type)).
-:- mode convert_pred_to_lambda_goal(in, in, in, in, in, in, in,
+:- mode convert_pred_to_lambda_goal(in, in, in, in, in, in, in, in,
in, in, in, in, in, out, out, out) is det.
%-----------------------------------------------------------------------------%
@@ -300,6 +300,7 @@
:- import_module hlds__hlds_data, check_hlds__typecheck, ll_backend__llds.
:- import_module parse_tree__prog_io.
:- import_module check_hlds__type_util, check_hlds__mode_util.
+:- import_module check_hlds__purity.
:- import_module hlds__quantification, hlds__instmap, parse_tree__prog_out.
:- import_module ll_backend__code_util, check_hlds__unify_proc.
:- import_module parse_tree__prog_util.
@@ -1208,7 +1209,7 @@
polymorphism__process_unify_functor(XVar, ConsId, Args, Mode,
Unification0, UnifyContext, GoalInfo0, Goal)
;
- { Y = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ { Y = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
ArgVars0, LambdaVars, Modes, Det, LambdaGoal0) },
%
% for lambda expressions, we must recursively traverse the
@@ -1224,7 +1225,7 @@
{ set__to_sorted_list(NonLocalTypeInfos,
NonLocalTypeInfosList) },
{ list__append(NonLocalTypeInfosList, ArgVars0, ArgVars) },
- { Y1 = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ { Y1 = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
ArgVars, LambdaVars, Modes, Det, LambdaGoal) },
{ goal_info_get_nonlocals(GoalInfo0, NonLocals0) },
{ set__union(NonLocals0, NonLocalTypeInfos, NonLocals) },
@@ -1344,7 +1345,7 @@
%
% check if variable has a higher-order type
- type_is_higher_order(TypeOfX, _,
+ type_is_higher_order(TypeOfX, Purity, _PredOrFunc,
EvalMethod, PredArgTypes),
ConsId0 = pred_const(PredId, ProcId, _)
->
@@ -1353,7 +1354,7 @@
%
poly_info_get_varset(PolyInfo0, VarSet0),
goal_info_get_context(GoalInfo0, Context),
- convert_pred_to_lambda_goal(EvalMethod,
+ convert_pred_to_lambda_goal(Purity, EvalMethod,
X0, PredId, ProcId, ArgVars0, PredArgTypes,
UnifyContext, GoalInfo0, Context,
ModuleInfo0, VarSet0, VarTypes0,
@@ -1432,7 +1433,7 @@
Unification, UnifyContext) - GoalInfo
).
-convert_pred_to_lambda_goal(EvalMethod, X0, PredId, ProcId,
+convert_pred_to_lambda_goal(Purity, EvalMethod, X0, PredId, ProcId,
ArgVars0, PredArgTypes, UnifyContext, GoalInfo0, Context,
ModuleInfo0, VarSet0, VarTypes0,
Functor, VarSet, VarTypes) :-
@@ -1473,6 +1474,8 @@
goal_info_set_context(LambdaGoalInfo0, Context,
LambdaGoalInfo1),
goal_info_set_nonlocals(LambdaGoalInfo1, LambdaNonLocals,
+ LambdaGoalInfo2),
+ add_goal_info_purity_feature(LambdaGoalInfo2, Purity,
LambdaGoalInfo),
LambdaGoal = LambdaGoalExpr - LambdaGoalInfo,
@@ -1499,7 +1502,7 @@
% construct the lambda expression
%
pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
- Functor = lambda_goal(PredOrFunc, EvalMethod, modes_are_ok,
+ Functor = lambda_goal(Purity, PredOrFunc, EvalMethod, modes_are_ok,
ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
:- pred make_fresh_vars(list(type), prog_varset, map(prog_var, type),
@@ -2689,7 +2692,13 @@
% (i.e. types which are not type variables)
%
(
- ( type_is_higher_order(Type, PredOrFunc, _, TypeArgs0) ->
+ (
+ % XXX (RTTI for higher-order impure code)
+ % we should not ignore Purity here;
+ % it should get included in the RTTI.
+ type_is_higher_order(Type, _Purity, PredOrFunc, _,
+ TypeArgs0)
+ ->
TypeArgs = TypeArgs0,
hlds_out__pred_or_func_to_str(PredOrFunc,
PredOrFuncStr),
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.43
diff -u -d -r1.43 post_typecheck.m
--- compiler/post_typecheck.m 17 Jan 2003 03:58:24 -0000 1.43
+++ compiler/post_typecheck.m 23 Jan 2003 05:52:11 -0000
@@ -623,7 +623,7 @@
pred_info_clauses_info(CallerPredInfo, ClausesInfo),
clauses_info_vartypes(ClausesInfo, VarTypes),
map__lookup(VarTypes, HOArg, HOArgType),
- type_is_higher_order(HOArgType,
+ type_is_higher_order(HOArgType, _Purity,
_, EvalMethod, ArgTypes0),
EvalMethod \= normal
->
@@ -1173,9 +1173,16 @@
%
% Is the function symbol apply/N or ''/N,
% representing a higher-order function call?
+ % Or the impure/semipure equivalents impure_apply/N
+ % and semipure_apply/N?
+ % (XXX We should use nicer syntax for impure apply/N.)
%
ConsId0 = cons(unqualified(ApplyName), _),
- ( ApplyName = "apply" ; ApplyName = "" ),
+ ( ApplyName = "apply", Purity = (pure)
+ ; ApplyName = "", Purity = (pure)
+ ; ApplyName = "impure_apply", Purity = (impure)
+ ; ApplyName = "semipure_apply", Purity = (semipure)
+ ),
Arity >= 1,
ArgVars0 = [FuncVar | FuncArgVars]
->
@@ -1190,7 +1197,7 @@
Det = erroneous,
adjust_func_arity(function, Arity, FullArity),
HOCall = generic_call(
- higher_order(FuncVar, function, FullArity),
+ higher_order(FuncVar, Purity, function, FullArity),
ArgVars, Modes, Det),
PredInfo = PredInfo0,
@@ -1264,7 +1271,7 @@
% or function constant?
%
ConsId0 = cons(Name, _),
- type_is_higher_order(TypeOfX, PredOrFunc,
+ type_is_higher_order(TypeOfX, _Purity, PredOrFunc,
EvalMethod, HOArgTypes),
%
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.14
diff -u -d -r1.14 prog_rep.m
--- compiler/prog_rep.m 23 Apr 2002 08:52:38 -0000 1.14
+++ compiler/prog_rep.m 22 Jan 2003 16:24:42 -0000
@@ -192,7 +192,7 @@
GoalInfo, InstMap0, Info, Rep) :-
list__map(term__var_to_int, Args, ArgsRep),
(
- GenericCall = higher_order(PredVar, _, _),
+ GenericCall = higher_order(PredVar, _, _, _),
term__var_to_int(PredVar, PredVarRep),
AtomicGoalRep = higher_order_call_rep(PredVarRep, ArgsRep)
;
Index: compiler/pseudo_type_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pseudo_type_info.m,v
retrieving revision 1.9
diff -u -d -r1.9 pseudo_type_info.m
--- compiler/pseudo_type_info.m 1 Aug 2002 11:52:21 -0000 1.9
+++ compiler/pseudo_type_info.m 22 Jan 2003 07:29:43 -0000
@@ -261,11 +261,12 @@
%
% All variable arity type constructors are builtins.
% At the moment, we have three: pred, func, and tuple.
+ % XXX we should also encode purity in the RTTI!
:- pred type_is_var_arity((type)::in, var_arity_ctor_id::out) is semidet.
type_is_var_arity(Type, VarArityCtorId) :-
- ( type_is_higher_order(Type, PredOrFunc, _, _) ->
+ ( type_is_higher_order(Type, _Purity, PredOrFunc, _, _) ->
(
PredOrFunc = predicate,
VarArityCtorId = pred_type_info
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.48
diff -u -d -r1.48 purity.m
--- compiler/purity.m 22 Jul 2002 06:29:46 -0000 1.48
+++ compiler/purity.m 24 Jan 2003 06:56:37 -0000
@@ -107,6 +107,8 @@
% although we should be careful to pinpoint these as the source of
% the error (no impurity allowed in closures) rather than as
% errors to be corrected.
+% (XXX is the above comment still correct now that we support
+% impure closures?)
%
% It might be nice to allow
% X = impure some_impure_fuc(Arg1, Arg2, ...)
@@ -176,6 +178,7 @@
% Get a purity name as a string.
:- pred purity_name(purity, string).
:- mode purity_name(in, out) is det.
+:- mode purity_name(out, in) is semidet.
% Update a goal info to reflect the specified purity
:- pred add_goal_info_purity_feature(hlds_goal_info, purity, hlds_goal_info).
@@ -606,12 +609,11 @@
compute_expr_purity(generic_call(GenericCall0, Args, Modes0, Det),
GoalExpr, GoalInfo, _InClosure, Purity) -->
(
- { GenericCall0 = higher_order(_, _, _) },
- { Purity = pure },
+ { GenericCall0 = higher_order(_, Purity, _, _) },
{ GoalExpr = generic_call(GenericCall0, Args, Modes0, Det) }
;
{ GenericCall0 = class_method(_, _, _, _) },
- { Purity = pure },
+ { Purity = pure }, % XXX this is wrong!
{ GoalExpr = generic_call(GenericCall0, Args, Modes0, Det) }
;
{ GenericCall0 = aditi_builtin(Builtin0, CallId0) },
@@ -648,13 +650,13 @@
ActualPurity) -->
{ Unif0 = unify(Var, RHS0, Mode, Unification, UnifyContext) },
(
- { RHS0 = lambda_goal(F, EvalMethod, FixModes, H, Vars,
- Modes0, K, Goal0 - Info0) }
+ { RHS0 = lambda_goal(LambdaPurity, F, EvalMethod,
+ FixModes, H, Vars, Modes0, K, Goal0 - Info0) }
->
- { RHS = lambda_goal(F, EvalMethod, modes_are_ok, H, Vars,
- Modes, K, Goal - Info0) },
- compute_expr_purity(Goal0, Goal, Info0, yes, Purity),
- error_if_closure_impure(GoalInfo, Purity),
+ { RHS = lambda_goal(LambdaPurity, F, EvalMethod,
+ modes_are_ok, H, Vars, Modes, K, Goal - Info0) },
+ compute_expr_purity(Goal0, Goal, Info0, yes, GoalPurity),
+ check_closure_purity(GoalInfo, LambdaPurity, GoalPurity),
VarTypes =^ vartypes,
@@ -689,7 +691,9 @@
LambdaVarTypes, Modes0, Modes)
},
{ GoalExpr = unify(Var, RHS, Mode, Unification, UnifyContext) },
- { ActualPurity = pure }
+ % the unification itself is always pure,
+ % even if the lambda expression body is impure
+ { ActualPurity = (pure) }
;
{ RHS0 = functor(ConsId, _, Args) }
->
@@ -712,14 +716,14 @@
{ Goal1 = Unif0 - GoalInfo }
),
(
- { Goal1 \= unify(_, _, _, _, _) - _ }
+ { Goal1 = unify(_, _, _, _, _) - _ }
->
- compute_goal_purity(Goal1, Goal,
- InClosure, ActualPurity)
- ;
check_higher_order_purity(GoalInfo, ConsId,
Var, Args, ActualPurity),
{ Goal = Goal1 }
+ ;
+ compute_goal_purity(Goal1, Goal,
+ InClosure, ActualPurity)
),
{ Goal = GoalExpr - _ }
;
@@ -780,11 +784,15 @@
list(prog_var), purity, purity_info, purity_info).
:- mode check_higher_order_purity(in, in, in, in, out, in, out) is det.
check_higher_order_purity(GoalInfo, ConsId, Var, Args, ActualPurity) -->
+ %
+ % Check that the purity of the ConsId matches the purity of the
+ % variable's type.
+ %
VarTypes =^ vartypes,
{ map__lookup(VarTypes, Var, TypeOfVar) },
(
{ ConsId = cons(PName, _) },
- { type_is_higher_order(TypeOfVar, PredOrFunc,
+ { type_is_higher_order(TypeOfVar, TypePurity, PredOrFunc,
_EvalMethod, VarArgTypes) }
->
PredInfo =^ pred_info,
@@ -798,35 +806,33 @@
->
{ module_info_pred_info(ModuleInfo,
CalleePredId, CalleePredInfo) },
- { pred_info_get_purity(CalleePredInfo, Purity) },
- ( { Purity = pure } ->
- []
- ;
- { goal_info_get_context(GoalInfo,
- CallContext) },
- { Message = missing_body_impurity_error(
- CallContext, CalleePredId) },
- purity_info_add_message(error(Message))
- )
+ { pred_info_get_purity(CalleePredInfo, CalleePurity) },
+ check_closure_purity(GoalInfo, TypePurity,
+ CalleePurity)
;
% If we can't find the type of the function,
% it's because typecheck couldn't give it one.
% Typechecking gives an error in this case, we
% just keep silent.
- { Purity = pure }
- ),
- { ActualPurity = Purity }
- ;
- { infer_goal_info_purity(GoalInfo, DeclaredPurity) },
- ( { DeclaredPurity \= pure } ->
- { goal_info_get_context(GoalInfo, Context) },
- { Message = impure_unification_expr_error(Context,
- DeclaredPurity) },
- purity_info_add_message(error(Message))
- ;
[]
- ),
- { ActualPurity = pure }
+ )
+ ;
+ []
+ ),
+
+ % The unification itself is always pure,
+ % even if it is a unification with an impure higher-order term.
+ { ActualPurity = pure },
+
+ % Check for a bogus purity annotation on the unification
+ { infer_goal_info_purity(GoalInfo, DeclaredPurity) },
+ ( { DeclaredPurity \= pure } ->
+ { goal_info_get_context(GoalInfo, Context) },
+ { Message = impure_unification_expr_error(Context,
+ DeclaredPurity) },
+ purity_info_add_message(error(Message))
+ ;
+ []
).
% the possible results of a purity check
@@ -923,7 +929,8 @@
{ module_info_pred_info(ModuleInfo, PredId, CalleePredInfo) },
{ pred_info_get_purity(CalleePredInfo, ActualPurity) },
(
- % The purity should match the declaration
+ % The purity of the callee should match the
+ % purity declared at the call
{ ActualPurity = DeclaredPurity }
->
[]
@@ -943,11 +950,8 @@
% class methods or instance methods --- it just
% means that the predicate provided as an
% implementation was more pure than necessary.
- %
- % We don't warn about exaggerated impurity
- % decls in c_code -- this is just because we
- % assume they are pure, but you can declare them
- % to be impure.
+ % Likewise, we don't warn about exaggerated
+ % impurity decls on closures.
{ pred_info_get_markers(PredInfo, Markers) },
{
check_marker(Markers, class_method)
@@ -1156,7 +1160,8 @@
:- type post_typecheck_error
---> missing_body_impurity_error(prog_context, pred_id)
- ; impure_closure(prog_context, purity)
+ ; closure_purity_error(prog_context, purity, purity)
+ % closure_purity_error(Context, DeclaredPurity, ActualPurity)
; impure_unification_expr_error(prog_context, purity)
; aditi_builtin_error(aditi_builtin_error)
.
@@ -1174,8 +1179,10 @@
{ Message = missing_body_impurity_error(Context, PredId) },
error_missing_body_impurity_decl(ModuleInfo, PredId, Context)
;
- { Message = impure_closure(Context, Purity) },
- report_error_impure_closure(Context, Purity)
+ { Message = closure_purity_error(Context, DeclaredPurity,
+ ActualPurity) },
+ report_error_closure_purity(Context, DeclaredPurity,
+ ActualPurity)
;
{ Message = impure_unification_expr_error(Context, Purity) },
impure_unification_expr_error(Context, Purity)
@@ -1251,35 +1258,35 @@
io__write_string("' is sufficient.\n")
).
-:- pred error_if_closure_impure(hlds_goal_info, purity,
+:- pred check_closure_purity(hlds_goal_info, purity, purity,
purity_info, purity_info).
-:- mode error_if_closure_impure(in, in, in, out) is det.
+:- mode check_closure_purity(in, in, in, in, out) is det.
-error_if_closure_impure(GoalInfo, Purity) -->
- ( { Purity = pure } ->
- []
- ;
+check_closure_purity(GoalInfo, DeclaredPurity, ActualPurity) -->
+ ( { ActualPurity `less_pure` DeclaredPurity } ->
{ goal_info_get_context(GoalInfo, Context) },
- purity_info_add_message(
- error(impure_closure(Context, Purity)))
+ purity_info_add_message(error(closure_purity_error(Context,
+ DeclaredPurity, ActualPurity)))
+ ;
+ % we don't bother to warn if the DeclaredPurity is less
+ % pure than the ActualPurity; that would lead to too many
+ % spurious warnings.
+ []
).
-:- pred report_error_impure_closure(prog_context, purity,
+:- pred report_error_closure_purity(prog_context, purity, purity,
io__state, io__state).
-:- mode report_error_impure_closure(in, in, di, uo) is det.
+:- mode report_error_closure_purity(in, in, in, di, uo) is det.
-report_error_impure_closure(Context, Purity) -->
+report_error_closure_purity(Context, _DeclaredPurity, ActualPurity) -->
prog_out__write_context(Context),
- io__write_string("Purity error in closure: closure is "),
- write_purity(Purity),
- io__write_string(".\n"),
- globals__io_lookup_bool_option(verbose_errors, VerboseErrors),
- ( { VerboseErrors = yes } ->
- prog_out__write_context(Context),
- io__write_string(" All closures must be pure.\n")
- ;
- []
- ).
+ io__write_string("Purity error in closure: closure body is "),
+ write_purity(ActualPurity),
+ io__write_string(",\n"),
+ prog_out__write_context(Context),
+ io__write_string(" but closure was not declared `"),
+ write_purity(ActualPurity),
+ io__write_string(".'\n").
:- pred write_context_and_pred_id(module_info, pred_info, pred_id,
io__state, io__state).
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.83
diff -u -d -r1.83 quantification.m
--- compiler/quantification.m 22 Jul 2002 06:29:47 -0000 1.83
+++ compiler/quantification.m 22 Jan 2003 08:05:04 -0000
@@ -621,12 +621,12 @@
},
quantification__set_nonlocals(Vars).
implicitly_quantify_unify_rhs(
- lambda_goal(PredOrFunc, EvalMethod, FixModes, LambdaNonLocals0,
- LambdaVars0, Modes, Det, Goal0),
+ lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ LambdaNonLocals0, LambdaVars0, Modes, Det, Goal0),
_, Unification0,
Context,
- lambda_goal(PredOrFunc, EvalMethod, FixModes, LambdaNonLocals,
- LambdaVars, Modes, Det, Goal),
+ lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ LambdaNonLocals, LambdaVars, Modes, Det, Goal),
Unification
) -->
%
@@ -1043,7 +1043,7 @@
insert_list(Set0, ArgVars, Set)
).
quantification__unify_rhs_vars(NonLocalsToRecompute,
- lambda_goal(_POrF, _E, _F, _N, LambdaVars, _M, _D, Goal),
+ lambda_goal(_P, _POrF, _E, _F, _N, LambdaVars, _M, _D, Goal),
_, Set, LambdaSet0, Set, LambdaSet) :-
% Note that the NonLocals list is not counted, since all the
% variables in that list must occur in the goal.
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.4
diff -u -d -r1.4 recompilation.usage.m
--- compiler/recompilation.usage.m 14 Jan 2003 16:42:29 -0000 1.4
+++ compiler/recompilation.usage.m 22 Jan 2003 07:33:21 -0000
@@ -1237,7 +1237,7 @@
(
% Unqualified type-ids are builtin types.
{ TypeCtor = qualified(_, _) - _ },
- \+ { type_ctor_is_higher_order(TypeCtor, _, _) }
+ \+ { type_ctor_is_higher_order(TypeCtor, _, _, _) }
->
recompilation__usage__maybe_record_item_to_process(
(type), TypeCtor)
Index: compiler/rl_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_gen.m,v
retrieving revision 1.8
diff -u -d -r1.8 rl_gen.m
--- compiler/rl_gen.m 17 Jan 2003 05:56:48 -0000 1.8
+++ compiler/rl_gen.m 22 Jan 2003 15:28:31 -0000
@@ -206,7 +206,7 @@
rl_info_get_module_info(ModuleInfo),
( { mode_is_input(ModuleInfo, Mode) } ->
(
- { type_is_higher_order(Type, predicate,
+ { type_is_higher_order(Type, (pure), predicate,
(aditi_bottom_up), PredArgTypes) }
->
rl_info_get_new_temporary(schema(PredArgTypes),
@@ -926,7 +926,7 @@
MaybeNegGoals = no
;
% XXX check that the var is an input relation variable.
- Goal = generic_call(higher_order(_, predicate, _),
+ Goal = generic_call(higher_order(_, (pure), predicate, _),
_, _, _) - _,
CallGoal = Goal,
MaybeNegGoals = no
@@ -967,7 +967,8 @@
{ DBCall = db_call(called_pred(PredProcId), MaybeNegGoals,
InputArgs, OutputArgs, GoalInfo) }
;
- { CallGoal = generic_call(higher_order(Var, predicate, _),
+ { CallGoal = generic_call(
+ higher_order(Var, (pure), predicate, _),
Args, ArgModes, _) - GoalInfo }
->
{ CallId = ho_called_var(Var) },
@@ -1717,7 +1718,7 @@
% for the UpdateAcc and ComputeInitial parameters
% is `aditi_top_down', and the InputRelationArg
% is `aditi_bottom_up'.
- { type_is_higher_order(ComputeInitialType,
+ { type_is_higher_order(ComputeInitialType, (pure),
predicate, _, ComputeInitialArgTypes) },
{ ComputeInitialArgTypes = [GrpByType, _NGrpByType, AccType] }
->
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.106
diff -u -d -r1.106 simplify.m
--- compiler/simplify.m 1 Nov 2002 07:06:57 -0000 1.106
+++ compiler/simplify.m 22 Jan 2003 16:28:38 -0000
@@ -726,13 +726,17 @@
simplify_do_calls(Info0),
% XXX We should do duplicate call elimination for
% class method calls here.
- GenericCall = higher_order(Closure, _, _)
+ GenericCall = higher_order(Closure, Purity, _, _),
+ % XXX Should we handle impure/semipure higher-order calls too?
+ Purity = (pure)
->
common__optimise_higher_order_call(Closure, Args, Modes, Det,
Goal0, GoalInfo, Goal, Info0, Info)
;
simplify_do_warn_calls(Info0),
- GenericCall = higher_order(Closure, _, _)
+ GenericCall = higher_order(Closure, Purity, _, _),
+ % XXX Should we handle impure/semipure higher-order calls too?
+ Purity = (pure)
->
% We need to do the pass, for the warnings, but we ignore
% the optimized goal and instead use the original one.
@@ -782,7 +786,7 @@
true_goal(Context, Goal - GoalInfo),
Info = Info0
;
- RT0 = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ RT0 = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
NonLocals, Vars, Modes, LambdaDeclaredDet, LambdaGoal0)
->
simplify_info_enter_lambda(Info0, Info1),
@@ -803,8 +807,8 @@
simplify__goal(LambdaGoal0, LambdaGoal, Info3, Info4),
simplify_info_set_common_info(Info4, Common1, Info5),
simplify_info_set_instmap(Info5, InstMap1, Info6),
- RT = lambda_goal(PredOrFunc, EvalMethod, FixModes, NonLocals,
- Vars, Modes, LambdaDeclaredDet, LambdaGoal),
+ RT = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ NonLocals, Vars, Modes, LambdaDeclaredDet, LambdaGoal),
simplify_info_leave_lambda(Info6, Info),
Goal = unify(LT0, RT, M, U0, C),
GoalInfo = GoalInfo0
@@ -1359,7 +1363,7 @@
{ simplify__call_generic_unify(TypeInfoVar, XVar, YVar,
ModuleInfo, Context, GoalInfo0, Call) }
- ; { type_is_higher_order(Type, _, _, _) } ->
+ ; { type_is_higher_order(Type, _, _, _, _) } ->
%
% convert higher-order unifications into calls to
% builtin_unify_pred (which calls error/1)
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.27
diff -u -d -r1.27 stratify.m
--- compiler/stratify.m 28 Mar 2002 03:43:38 -0000 1.27
+++ compiler/stratify.m 22 Jan 2003 15:33:59 -0000
@@ -371,7 +371,7 @@
(
{ Negated = yes },
{ HighOrderLoops = yes },
- { GenericCall = higher_order(_, _, _), Msg = "higher order"
+ { GenericCall = higher_order(_, _, _, _), Msg = "higher order"
; GenericCall = class_method(_, _, _, _), Msg = "class method"
}
->
@@ -719,7 +719,7 @@
% XXX : will have to use a more general check for higher
% order constants in parameters user could hide higher
% order consts in a data structure etc..
- type_is_higher_order(Type, _, _, _)
+ type_is_higher_order(Type, _, _, _, _)
->
(
mode_is_input(Module, Mode)
@@ -764,8 +764,9 @@
% lambda goal have addresses taken. this is not
% always to case, but should be a suitable approximation for
% the stratification analysis
- RHS = lambda_goal(_PredOrFunc, _EvalMethod, _Fix, _NonLocals,
- _Vars, _Modes, _Determinism, Goal - _GoalInfo)
+ RHS = lambda_goal(_Purity, _PredOrFunc, _EvalMethod, _Fix,
+ _NonLocals, _Vars, _Modes, _Determinism,
+ Goal - _GoalInfo)
->
get_called_procs(Goal, [], CalledProcs),
set__insert_list(HasAT0, CalledProcs, HasAT)
@@ -866,8 +867,9 @@
% lambda goal have addresses taken. this is not
% always to case, but should be a suitable approximation for
% the stratification analysis
- RHS = lambda_goal(_PredOrFunc, _EvalMethod, _Fix, _NonLocals,
- _Vars, _Modes, _Determinism, Goal - _GoalInfo)
+ RHS = lambda_goal(_Purity, _PredOrFunc, _EvalMethod, _Fix,
+ _NonLocals, _Vars, _Modes, _Determinism,
+ Goal - _GoalInfo)
->
get_called_procs(Goal, Calls0, Calls)
;
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.98
diff -u -d -r1.98 switch_detection.m
--- compiler/switch_detection.m 28 Mar 2002 03:43:39 -0000 1.98
+++ compiler/switch_detection.m 22 Jan 2003 08:06:31 -0000
@@ -198,7 +198,7 @@
detect_switches_in_goal_2(unify(A,RHS0,C,D,E), __GoalInfo, InstMap0,
VarTypes, ModuleInfo, unify(A,RHS,C,D,E)) :-
(
- RHS0 = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ RHS0 = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
NonLocals, Vars, Modes, Det, Goal0)
->
% we need to insert the initial insts for the lambda
@@ -207,7 +207,7 @@
Vars, Modes, InstMap0, InstMap1),
detect_switches_in_goal(Goal0, InstMap1, VarTypes, ModuleInfo,
Goal),
- RHS = lambda_goal(PredOrFunc, EvalMethod, FixModes,
+ RHS = lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
NonLocals, Vars, Modes, Det, Goal)
;
RHS = RHS0
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.20
diff -u -d -r1.20 term_traversal.m
--- compiler/term_traversal.m 28 Mar 2002 03:43:41 -0000 1.20
+++ compiler/term_traversal.m 22 Jan 2003 07:34:43 -0000
@@ -443,7 +443,7 @@
params_get_functor_info(Params, FunctorInfo),
params_get_var_types(Params, VarTypes),
map__lookup(VarTypes, OutVar, Type),
- \+ type_is_higher_order(Type, _, _, _),
+ \+ type_is_higher_order(Type, _, _, _, _),
( type_to_ctor_and_args(Type, TypeCtor, _) ->
params_get_module_info(Params, Module),
functor_norm(FunctorInfo, TypeCtor, ConsId, Module,
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.22
diff -u -d -r1.22 term_util.m
--- compiler/term_util.m 14 Jan 2003 16:42:30 -0000 1.22
+++ compiler/term_util.m 22 Jan 2003 07:34:56 -0000
@@ -577,7 +577,7 @@
horder_vars([Arg | Args], VarType) :-
(
map__lookup(VarType, Arg, Type),
- type_is_higher_order(Type, _, _, _)
+ type_is_higher_order(Type, _, _, _, _)
;
horder_vars(Args, VarType)
).
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.113
diff -u -d -r1.113 type_util.m
--- compiler/type_util.m 14 Jan 2003 16:42:30 -0000 1.113
+++ compiler/type_util.m 23 Jan 2003 05:00:35 -0000
@@ -35,14 +35,14 @@
:- pred type_ctor_is_atomic(type_ctor, module_info).
:- mode type_ctor_is_atomic(in, in) is semidet.
- % type_is_higher_order(Type, PredOrFunc, ArgTypes) succeeds iff
- % Type is a higher-order predicate or function type with the specified
+ % type_is_higher_order(Type, Purity, PredOrFunc, ArgTypes, EvalMeth) succeeds
+ % iff Type is a higher-order predicate or function type with the specified
% argument types (for functions, the return type is appended to the
- % end of the argument types).
+ % end of the argument types), purity, and evaluation method.
-:- pred type_is_higher_order(type, pred_or_func,
+:- pred type_is_higher_order(type, purity, pred_or_func,
lambda_eval_method, list(type)).
-:- mode type_is_higher_order(in, out, out, out) is semidet.
+:- mode type_is_higher_order(in, out, out, out, out) is semidet.
% Succeed if the given type is a tuple type, returning
% the argument types.
@@ -51,8 +51,9 @@
% type_ctor_is_higher_order(TypeCtor, PredOrFunc) succeeds iff
% TypeCtor is a higher-order predicate or function type.
-:- pred type_ctor_is_higher_order(type_ctor, pred_or_func, lambda_eval_method).
-:- mode type_ctor_is_higher_order(in, out, out) is semidet.
+:- pred type_ctor_is_higher_order(type_ctor, purity, pred_or_func,
+ lambda_eval_method).
+:- mode type_ctor_is_higher_order(in, out, out, out) is semidet.
% type_ctor_is_tuple(TypeCtor) succeeds iff TypeCtor is a tuple type.
:- pred type_ctor_is_tuple(type_ctor).
@@ -157,17 +158,17 @@
:- pred construct_type(type_ctor, list(type), (type)).
:- mode construct_type(in, in, out) is det.
-:- pred construct_higher_order_type(pred_or_func, lambda_eval_method,
+:- pred construct_higher_order_type(purity, pred_or_func, lambda_eval_method,
list(type), (type)).
-:- mode construct_higher_order_type(in, in, in, out) is det.
+:- mode construct_higher_order_type(in, in, in, in, out) is det.
-:- pred construct_higher_order_pred_type(lambda_eval_method,
+:- pred construct_higher_order_pred_type(purity, lambda_eval_method,
list(type), (type)).
-:- mode construct_higher_order_pred_type(in, in, out) is det.
+:- mode construct_higher_order_pred_type(in, in, in, out) is det.
-:- pred construct_higher_order_func_type(lambda_eval_method,
+:- pred construct_higher_order_func_type(purity, lambda_eval_method,
list(type), (type), (type)).
-:- mode construct_higher_order_func_type(in, in, in, out) is det.
+:- mode construct_higher_order_func_type(in, in, in, in, out) is det.
% Construct builtin types.
:- func int_type = (type).
@@ -493,7 +494,10 @@
:- implementation.
:- import_module parse_tree__prog_io, parse_tree__prog_io_goal.
-:- import_module parse_tree__prog_util, libs__options, libs__globals.
+:- import_module parse_tree__prog_util.
+:- import_module check_hlds__purity.
+:- import_module libs__options, libs__globals.
+
:- import_module char, int, string.
:- import_module assoc_list, require, varset.
@@ -571,7 +575,7 @@
Type = float_type
; TypeCtor = unqualified("string") - 0 ->
Type = str_type
- ; type_ctor_is_higher_order(TypeCtor, _, _) ->
+ ; type_ctor_is_higher_order(TypeCtor, _, _, _) ->
Type = pred_type
; type_ctor_is_tuple(TypeCtor) ->
Type = tuple_type
@@ -581,7 +585,28 @@
Type = user_type
).
-type_is_higher_order(Type, PredOrFunc, EvalMethod, PredArgTypes) :-
+type_is_higher_order(Type, Purity, PredOrFunc, EvalMethod, PredArgTypes) :-
+ (
+ Type = term__functor(term__atom(PurityName), [BaseType], _),
+ purity_name(Purity0, PurityName),
+ type_is_higher_order_2(BaseType,
+ PredOrFunc0, EvalMethod0, PredArgTypes0)
+ ->
+ Purity = Purity0,
+ PredOrFunc = PredOrFunc0,
+ EvalMethod = EvalMethod0,
+ PredArgTypes = PredArgTypes0
+ ;
+ Purity = (pure),
+ type_is_higher_order_2(Type,
+ PredOrFunc, EvalMethod, PredArgTypes)
+ ).
+
+% This parses a higher-order type without any purity indicator.
+:- pred type_is_higher_order_2(type, pred_or_func,
+ lambda_eval_method, list(type)).
+:- mode type_is_higher_order_2(in, out, out, out) is semidet.
+type_is_higher_order_2(Type, PredOrFunc, EvalMethod, PredArgTypes) :-
(
Type = term__functor(term__atom("="),
[FuncEvalAndArgs, FuncRetType], _)
@@ -596,10 +621,6 @@
PredOrFunc = predicate
).
-type_is_tuple(Type, ArgTypes) :-
- type_to_ctor_and_args(Type, TypeCtor, ArgTypes),
- type_ctor_is_tuple(TypeCtor).
-
% From the type of a lambda expression, work out how it should
% be evaluated and extract the argument types.
:- pred get_lambda_eval_method_and_args(string, (type),
@@ -622,20 +643,8 @@
)
).
-type_ctor_is_higher_order(SymName - _Arity, PredOrFunc, EvalMethod) :-
- (
- SymName = qualified(unqualified(EvalMethodStr), PorFStr),
- (
- EvalMethodStr = "aditi_bottom_up",
- EvalMethod = (aditi_bottom_up)
- ;
- EvalMethodStr = "aditi_top_down",
- EvalMethod = (aditi_top_down)
- )
- ;
- SymName = unqualified(PorFStr),
- EvalMethod = normal
- ),
+type_ctor_is_higher_order(SymName - _Arity, Purity, PredOrFunc, EvalMethod) :-
+ get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr),
(
PorFStr = "pred",
PredOrFunc = predicate
@@ -644,6 +653,39 @@
PredOrFunc = function
).
+:- pred get_purity_and_eval_method(sym_name::in, purity::out,
+ lambda_eval_method::out,
+ string::out) is semidet.
+get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr) :-
+ (
+ SymName = qualified(unqualified(Qualifier), PorFStr),
+ (
+ Qualifier = "aditi_bottom_up",
+ EvalMethod = (aditi_bottom_up),
+ Purity = (pure)
+ ;
+ Qualifier = "aditi_top_down",
+ EvalMethod = (aditi_top_down),
+ Purity = (pure)
+ ;
+ Qualifier = "impure",
+ Purity = (impure),
+ EvalMethod = normal
+ ;
+ Qualifier = "semipure",
+ Purity = (semipure),
+ EvalMethod = normal
+ )
+ ;
+ SymName = unqualified(PorFStr),
+ EvalMethod = normal,
+ Purity = (pure)
+ ).
+
+type_is_tuple(Type, ArgTypes) :-
+ type_to_ctor_and_args(Type, TypeCtor, ArgTypes),
+ type_ctor_is_tuple(TypeCtor).
+
type_ctor_is_tuple(unqualified("{}") - _).
type_has_user_defined_equality_pred(ModuleInfo, Type, SymName) :-
@@ -718,7 +760,7 @@
% their arguments don't directly correspond to the
% arguments of the term.
(
- type_is_higher_order(Type, PredOrFunc,
+ type_is_higher_order(Type, Purity, PredOrFunc,
EvalMethod, PredArgTypes)
->
Args = PredArgTypes,
@@ -731,17 +773,28 @@
PredOrFunc = function,
PorFStr = "func"
),
+ SymName0 = unqualified(PorFStr),
(
EvalMethod = (aditi_bottom_up),
- SymName = qualified(unqualified("aditi_bottom_up"),
- PorFStr)
+ insert_module_qualifier("aditi_bottom_up", SymName0,
+ SymName1)
;
EvalMethod = (aditi_top_down),
- SymName = qualified(unqualified("aditi_top_down"),
- PorFStr)
+ insert_module_qualifier("aditi_top_down", SymName0,
+ SymName1)
;
EvalMethod = normal,
- SymName = unqualified(PorFStr)
+ SymName1 = SymName0
+ ),
+ (
+ Purity = (pure),
+ SymName = SymName1
+ ;
+ Purity = (semipure),
+ insert_module_qualifier("semipure", SymName1, SymName)
+ ;
+ Purity = (impure),
+ insert_module_qualifier("impure", SymName1, SymName)
)
;
sym_name_and_args(Type, SymName, Args),
@@ -762,34 +815,56 @@
).
construct_type(TypeCtor, Args, Type) :-
- ( type_ctor_is_higher_order(TypeCtor, PredOrFunc, EvalMethod) ->
- construct_higher_order_type(PredOrFunc, EvalMethod, Args, Type)
+ (
+ type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc,
+ EvalMethod)
+ ->
+ construct_higher_order_type(Purity, PredOrFunc, EvalMethod,
+ Args, Type)
;
TypeCtor = SymName - _,
construct_qualified_term(SymName, Args, Type)
).
-construct_higher_order_type(PredOrFunc, EvalMethod, ArgTypes, Type) :-
+construct_higher_order_type(Purity, PredOrFunc, EvalMethod, ArgTypes, Type) :-
(
PredOrFunc = predicate,
- construct_higher_order_pred_type(EvalMethod, ArgTypes, Type)
+ construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes,
+ Type)
;
PredOrFunc = function,
pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType),
- construct_higher_order_func_type(EvalMethod, FuncArgTypes,
- FuncRetType, Type)
+ construct_higher_order_func_type(Purity, EvalMethod,
+ FuncArgTypes, FuncRetType, Type)
).
-construct_higher_order_pred_type(EvalMethod, ArgTypes, Type) :-
+construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, Type) :-
construct_qualified_term(unqualified("pred"),
ArgTypes, Type0),
- qualify_higher_order_type(EvalMethod, Type0, Type).
+ qualify_higher_order_type(EvalMethod, Type0, Type1),
+ Type = add_purity_annotation(Purity, Type1).
-construct_higher_order_func_type(EvalMethod, ArgTypes, RetType, Type) :-
+construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType, Type) :-
construct_qualified_term(unqualified("func"), ArgTypes, Type0),
qualify_higher_order_type(EvalMethod, Type0, Type1),
- Type = term__functor(term__atom("="), [Type1, RetType],
- term__context_init).
+ Type2 = term__functor(term__atom("="), [Type1, RetType],
+ term__context_init),
+ Type = add_purity_annotation(Purity, Type2).
+
+:- func add_purity_annotation(purity, (type)) = (type).
+add_purity_annotation(Purity, Type0) = Type :-
+ (
+ Purity = (pure),
+ Type = Type0
+ ;
+ Purity = (semipure),
+ Type = term__functor(term__atom("semipure"), [Type0],
+ term__context_init)
+ ;
+ Purity = (impure),
+ Type = term__functor(term__atom("impure"), [Type0],
+ term__context_init)
+ ).
:- pred qualify_higher_order_type(lambda_eval_method, (type), (type)).
:- mode qualify_higher_order_type(in, in, out) is det.
@@ -1743,7 +1818,7 @@
maybe_get_higher_order_arg_types(MaybeType, Arity, MaybeTypes) :-
(
MaybeType = yes(Type),
- type_is_higher_order(Type, _, _, Types)
+ type_is_higher_order(Type, _, _, _, Types)
->
MaybeTypes = list__map(func(T) = yes(T), Types)
;
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.325
diff -u -d -r1.325 typecheck.m
--- compiler/typecheck.m 25 Sep 2002 06:49:13 -0000 1.325
+++ compiler/typecheck.m 23 Jan 2003 05:03:32 -0000
@@ -1302,10 +1302,10 @@
{ hlds_goal__generic_call_id(GenericCall0, CallId) },
typecheck_info_set_called_predid(CallId),
(
- { GenericCall0 = higher_order(PredVar, _, _) },
+ { GenericCall0 = higher_order(PredVar, Purity, _, _) },
{ GenericCall = GenericCall0 },
checkpoint("higher-order call"),
- typecheck_higher_order_call(PredVar, Args)
+ typecheck_higher_order_call(PredVar, Purity, Args)
;
{ GenericCall0 = class_method(_, _, _, _) },
{ error("typecheck_goal_2: unexpected class method call") }
@@ -1390,14 +1390,14 @@
%-----------------------------------------------------------------------------%
-:- pred typecheck_higher_order_call(prog_var, list(prog_var),
+:- pred typecheck_higher_order_call(prog_var, purity, list(prog_var),
typecheck_info, typecheck_info).
-:- mode typecheck_higher_order_call(in, in, typecheck_info_di,
+:- mode typecheck_higher_order_call(in, in, in, typecheck_info_di,
typecheck_info_uo) is det.
-typecheck_higher_order_call(PredVar, Args) -->
+typecheck_higher_order_call(PredVar, Purity, Args) -->
{ list__length(Args, Arity) },
- { higher_order_pred_type(Arity, normal,
+ { higher_order_pred_type(Purity, Arity, normal,
TypeVarSet, PredVarType, ArgTypes) },
% The class context is empty because higher-order predicates
% are always monomorphic. Similarly for ExistQVars.
@@ -1406,41 +1406,43 @@
typecheck_var_has_polymorphic_type_list([PredVar|Args], TypeVarSet,
ExistQVars, [PredVarType|ArgTypes], ClassContext).
-:- pred higher_order_pred_type(int, lambda_eval_method,
+:- pred higher_order_pred_type(purity, int, lambda_eval_method,
tvarset, type, list(type)).
-:- mode higher_order_pred_type(in, in, out, out, out) is det.
+:- mode higher_order_pred_type(in, in, in, out, out, out) is det.
- % higher_order_pred_type(N, EvalMethod,
+ % higher_order_pred_type(Purity, N, EvalMethod,
% TypeVarSet, PredType, ArgTypes):
% Given an arity N, let TypeVarSet = {T1, T2, ..., TN},
- % PredType = `EvalMethod pred(T1, T2, ..., TN)', and
+ % PredType = `Purity EvalMethod pred(T1, T2, ..., TN)', and
% ArgTypes = [T1, T2, ..., TN].
-higher_order_pred_type(Arity, EvalMethod, TypeVarSet, PredType, ArgTypes) :-
+higher_order_pred_type(Purity, Arity, EvalMethod, TypeVarSet, PredType,
+ ArgTypes) :-
varset__init(TypeVarSet0),
varset__new_vars(TypeVarSet0, Arity, ArgTypeVars, TypeVarSet),
term__var_list_to_term_list(ArgTypeVars, ArgTypes),
- construct_higher_order_type(predicate, EvalMethod, ArgTypes, PredType).
+ construct_higher_order_type(Purity, predicate, EvalMethod, ArgTypes,
+ PredType).
-:- pred higher_order_func_type(int, lambda_eval_method,
+:- pred higher_order_func_type(purity, int, lambda_eval_method,
tvarset, type, list(type), type).
-:- mode higher_order_func_type(in, in, out, out, out, out) is det.
+:- mode higher_order_func_type(in, in, in, out, out, out, out) is det.
- % higher_order_func_type(N, EvalMethod, TypeVarSet,
+ % higher_order_func_type(Purity, N, EvalMethod, TypeVarSet,
% FuncType, ArgTypes, RetType):
% Given an arity N, let TypeVarSet = {T0, T1, T2, ..., TN},
- % FuncType = `EvalMethod func(T1, T2, ..., TN) = T0',
+ % FuncType = `Purity EvalMethod func(T1, T2, ..., TN) = T0',
% ArgTypes = [T1, T2, ..., TN], and
% RetType = T0.
-higher_order_func_type(Arity, EvalMethod, TypeVarSet,
+higher_order_func_type(Purity, Arity, EvalMethod, TypeVarSet,
FuncType, ArgTypes, RetType) :-
varset__init(TypeVarSet0),
varset__new_vars(TypeVarSet0, Arity, ArgTypeVars, TypeVarSet1),
varset__new_var(TypeVarSet1, RetTypeVar, TypeVarSet),
term__var_list_to_term_list(ArgTypeVars, ArgTypes),
RetType = term__variable(RetTypeVar),
- construct_higher_order_func_type(EvalMethod,
+ construct_higher_order_func_type(Purity, EvalMethod,
ArgTypes, RetType, FuncType).
%-----------------------------------------------------------------------------%
@@ -1487,7 +1489,7 @@
{ CallId = PredOrFunc - _ },
{ InsertDeleteAdjustArgTypes =
lambda([RelationArgTypes::in, UpdateArgTypes::out] is det, (
- construct_higher_order_type(PredOrFunc,
+ construct_higher_order_type((pure), PredOrFunc,
EvalMethod, RelationArgTypes, ClosureType),
UpdateArgTypes = [ClosureType]
)) },
@@ -1499,7 +1501,7 @@
lambda([RelationArgTypes::in, AditiModifyTypes::out] is det, (
list__append(RelationArgTypes, RelationArgTypes,
ClosureArgTypes),
- construct_higher_order_pred_type(EvalMethod,
+ construct_higher_order_pred_type((pure), EvalMethod,
ClosureArgTypes, ClosureType),
AditiModifyTypes = [ClosureType]
)) },
@@ -2391,11 +2393,11 @@
typecheck_unify_var_functor(X, F, As),
perform_context_reduction(OrigTypeAssignSet).
typecheck_unification(X,
- lambda_goal(PredOrFunc, EvalMethod, FixModes, NonLocals, Vars,
- Modes, Det, Goal0),
- lambda_goal(PredOrFunc, EvalMethod, FixModes, NonLocals, Vars,
- Modes, Det, Goal)) -->
- typecheck_lambda_var_has_type(PredOrFunc, EvalMethod, X, Vars),
+ lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ NonLocals, Vars, Modes, Det, Goal0),
+ lambda_goal(Purity, PredOrFunc, EvalMethod, FixModes,
+ NonLocals, Vars, Modes, Det, Goal)) -->
+ typecheck_lambda_var_has_type(Purity, PredOrFunc, EvalMethod, X, Vars),
typecheck_goal(Goal0, Goal).
:- pred typecheck_unify_var_var(prog_var, prog_var,
@@ -2835,15 +2837,15 @@
% checks that `Var' has type `pred(T1, T2, ...)' where
% T1, T2, ... are the types of the `ArgVars'.
-:- pred typecheck_lambda_var_has_type(pred_or_func, lambda_eval_method,
+:- pred typecheck_lambda_var_has_type(purity, pred_or_func, lambda_eval_method,
prog_var, list(prog_var), typecheck_info, typecheck_info).
-:- mode typecheck_lambda_var_has_type(in, in, in, in, typecheck_info_di,
+:- mode typecheck_lambda_var_has_type(in, in, in, in, in, typecheck_info_di,
typecheck_info_uo) is det.
-typecheck_lambda_var_has_type(PredOrFunc, EvalMethod, Var,
+typecheck_lambda_var_has_type(Purity, PredOrFunc, EvalMethod, Var,
ArgVars, TypeCheckInfo0, TypeCheckInfo) :-
typecheck_info_get_type_assign_set(TypeCheckInfo0, TypeAssignSet0),
- typecheck_lambda_var_has_type_2(TypeAssignSet0,
+ typecheck_lambda_var_has_type_2(TypeAssignSet0, Purity,
PredOrFunc, EvalMethod, Var, ArgVars, [], TypeAssignSet),
(
TypeAssignSet = [],
@@ -2861,21 +2863,21 @@
TypeAssignSet, TypeCheckInfo)
).
-:- pred typecheck_lambda_var_has_type_2(type_assign_set,
+:- pred typecheck_lambda_var_has_type_2(type_assign_set, purity,
pred_or_func, lambda_eval_method, prog_var, list(prog_var),
type_assign_set, type_assign_set).
-:- mode typecheck_lambda_var_has_type_2(in, in, in, in, in, in, out) is det.
+:- mode typecheck_lambda_var_has_type_2(in, in, in, in, in, in, in, out) is det.
-typecheck_lambda_var_has_type_2([], _, _, _, _) --> [].
-typecheck_lambda_var_has_type_2([TypeAssign0 | TypeAssignSet0],
+typecheck_lambda_var_has_type_2([], _, _, _, _, _) --> [].
+typecheck_lambda_var_has_type_2([TypeAssign0 | TypeAssignSet0], Purity,
PredOrFunc, EvalMethod, Var, ArgVars) -->
{ type_assign_get_types_of_vars(ArgVars, TypeAssign0, ArgVarTypes,
TypeAssign1) },
- { construct_higher_order_type(PredOrFunc,
+ { construct_higher_order_type(Purity, PredOrFunc,
EvalMethod, ArgVarTypes, LambdaType) },
type_assign_var_has_type(TypeAssign1, Var, LambdaType),
typecheck_lambda_var_has_type_2(TypeAssignSet0,
- PredOrFunc, EvalMethod, Var, ArgVars).
+ Purity, PredOrFunc, EvalMethod, Var, ArgVars).
:- pred type_assign_get_types_of_vars(list(prog_var), type_assign, list(type),
type_assign).
@@ -3001,6 +3003,7 @@
pred_info_get_class_context(PredInfo, ClassContext),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
CompleteArgTypes),
+ pred_info_get_purity(PredInfo, Purity),
(
IsPredOrFunc = predicate,
PredArity >= FuncArity,
@@ -3013,7 +3016,7 @@
list__split_list(FuncArity, CompleteArgTypes,
ArgTypes, PredTypeParams)
->
- construct_higher_order_pred_type(normal,
+ construct_higher_order_pred_type(Purity, normal,
PredTypeParams, PredType),
ConsInfo = cons_type_info(PredTypeVarSet,
PredExistQVars,
@@ -3026,7 +3029,7 @@
% operations and also to Aditi aggregates.
pred_info_get_markers(PredInfo, Markers),
( check_marker(Markers, aditi) ->
- construct_higher_order_pred_type(
+ construct_higher_order_pred_type(Purity,
(aditi_bottom_up), PredTypeParams,
PredType2),
ConsInfo2 = cons_type_info(PredTypeVarSet,
@@ -3058,9 +3061,9 @@
( FuncArgTypeParams = [] ->
FuncType = FuncReturnTypeParam
;
- construct_higher_order_func_type(normal,
- FuncArgTypeParams, FuncReturnTypeParam,
- FuncType)
+ construct_higher_order_func_type(Purity,
+ normal, FuncArgTypeParams,
+ FuncReturnTypeParam, FuncType)
),
ConsInfo = cons_type_info(PredTypeVarSet,
PredExistQVars,
@@ -3084,10 +3087,15 @@
builtin_apply_type(_TypeCheckInfo, Functor, Arity, ConsTypeInfos) :-
Functor = cons(unqualified(ApplyName), _),
- ( ApplyName = "apply" ; ApplyName = "" ),
+ ( ApplyName = "apply", Purity = (pure)
+ ; ApplyName = "", Purity = (pure)
+ % XXX handle impure apply/N more elegantly (e.g. nicer syntax)
+ ; ApplyName = "impure_apply", Purity = (impure)
+ ; ApplyName = "semipure_apply", Purity = (semipure)
+ ),
Arity >= 1,
Arity1 is Arity - 1,
- higher_order_func_type(Arity1, normal, TypeVarSet,
+ higher_order_func_type(Purity, Arity1, normal, TypeVarSet,
FuncType, ArgTypes, RetType),
ExistQVars = [],
Constraints = constraints([], []),
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.122
diff -u -d -r1.122 unify_gen.m
--- compiler/unify_gen.m 14 Jan 2003 16:42:30 -0000 1.122
+++ compiler/unify_gen.m 22 Jan 2003 16:31:12 -0000
@@ -505,7 +505,7 @@
{ EvalMethod = normal },
{ Args = [CallPred | CallArgs] },
{ ProcHeadVars = [ProcPred | ProcArgs] },
- { ProcInfoGoal = generic_call(higher_order(ProcPred, _, _),
+ { ProcInfoGoal = generic_call(higher_order(ProcPred, _, _, _),
ProcArgs, _, CallDeterminism) - _GoalInfo },
{ determinism_to_code_model(CallDeterminism, CallCodeModel) },
% Check that the code models are compatible.
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.74
diff -u -d -r1.74 unique_modes.m
--- compiler/unique_modes.m 28 Mar 2002 03:43:46 -0000 1.74
+++ compiler/unique_modes.m 22 Jan 2003 15:53:33 -0000
@@ -444,7 +444,7 @@
},
{
- GenericCall = higher_order(_, _, _),
+ GenericCall = higher_order(_, _, _, _),
ArgOffset = 1
;
% Class method calls are introduced by the compiler
Index: tests/hard_coded/purity/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/purity/Mmakefile,v
retrieving revision 1.3
diff -u -d -r1.3 Mmakefile
--- tests/hard_coded/purity/Mmakefile 12 Jan 2003 22:33:24 -0000 1.3
+++ tests/hard_coded/purity/Mmakefile 24 Jan 2003 07:22:08 -0000
@@ -7,7 +7,9 @@
PURITY_PROGS= \
purity \
impure_func_t1 \
- impure_func_t6
+ impure_func_t5_fixed2 \
+ impure_func_t6 \
+ impure_pred_t1_fixed3
# We currently don't do any testing in grade java on this directory.
ifneq "$(findstring java,$(GRADE))" ""
Index: tests/hard_coded/purity/impure_func_t5_fixed2.exp
===================================================================
RCS file: tests/hard_coded/purity/impure_func_t5_fixed2.exp
diff -N tests/hard_coded/purity/impure_func_t5_fixed2.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/purity/impure_func_t5_fixed2.exp 24 Jan 2003 07:18:05 -0000
@@ -0,0 +1,2 @@
+X(4) = 46
+X(4) = 47
Index: tests/hard_coded/purity/impure_func_t5_fixed2.exp2
===================================================================
RCS file: tests/hard_coded/purity/impure_func_t5_fixed2.exp2
diff -N tests/hard_coded/purity/impure_func_t5_fixed2.exp2
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/purity/impure_func_t5_fixed2.exp2 24 Jan 2003 05:01:52 -0000
@@ -0,0 +1,2 @@
+X(4) = 4
+X(4) = 4
Index: tests/hard_coded/purity/impure_func_t5_fixed2.m
===================================================================
RCS file: tests/hard_coded/purity/impure_func_t5_fixed2.m
diff -N tests/hard_coded/purity/impure_func_t5_fixed2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/purity/impure_func_t5_fixed2.m 24 Jan 2003 07:21:01 -0000
@@ -0,0 +1,31 @@
+:- module impure_func_t5_fixed2.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(state::di, state::uo) is det.
+
+:- implementation.
+:- import_module int, require, list.
+
+:- type foo ---> foo(impure func(int) = int).
+
+:- pragma promise_pure(main/2).
+
+main -->
+ { X = get_counter },
+ print("X(4) = "),
+ { impure X4 = impure_apply(X,4) },
+ print(X4), nl,
+ print("X(4) = "),
+ { impure X4b = impure_apply(X,4) },
+ print(X4b), nl.
+
+:- impure func get_counter(int) = int is det.
+
+:- pragma c_header_code("extern Integer counter;").
+:- pragma c_code("Integer counter = 42;").
+:- pragma c_code(get_counter(Y::in) = (X::out), will_not_call_mercury,
+ "X = counter + Y; counter++;").
+get_counter(X) = X.
Index: tests/hard_coded/purity/impure_pred_t1_fixed3.exp
===================================================================
RCS file: tests/hard_coded/purity/impure_pred_t1_fixed3.exp
diff -N tests/hard_coded/purity/impure_pred_t1_fixed3.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/purity/impure_pred_t1_fixed3.exp 24 Jan 2003 07:19:55 -0000
@@ -0,0 +1 @@
+X = 4
Index: tests/hard_coded/purity/impure_pred_t1_fixed3.m
===================================================================
RCS file: tests/hard_coded/purity/impure_pred_t1_fixed3.m
diff -N tests/hard_coded/purity/impure_pred_t1_fixed3.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/purity/impure_pred_t1_fixed3.m 24 Jan 2003 07:20:44 -0000
@@ -0,0 +1,33 @@
+
+:- module impure_pred_t1_fixed3.
+
+:- interface.
+
+:- import_module io.
+
+:- impure pred main(state::di, state::uo) is det.
+
+:- implementation.
+:- import_module int, require, list.
+
+:- type foo ---> foo(impure pred(int,int)).
+
+main -->
+ { Y = foo(get_counter) },
+ impure main2(Y).
+
+:- impure pred main2(foo::in(bound(foo(pred(in,out) is det))),
+ state::di, state::uo) is det.
+main2(Y) -->
+ { Y = foo(X) },
+ { impure X(4, Z) },
+ print("X = "),
+ print(Z),
+ nl.
+
+:- impure pred get_counter(int::in, int::out) is det.
+
+:- pragma c_header_code("extern Integer counter;").
+:- pragma c_code("Integer counter = 0;").
+:- pragma c_code(get_counter(Y::in, X::out), will_not_call_mercury, "X = counter + Y;").
+get_counter(X, X).
Index: tests/invalid/purity/.cvsignore
===================================================================
RCS file: tests/invalid/purity/.cvsignore
diff -N tests/invalid/purity/.cvsignore
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/purity/.cvsignore 24 Jan 2003 16:37:35 -0000
@@ -0,0 +1,16 @@
+*.d
+*.date
+*.date0
+*.date3
+*.dep
+*.err_res*
+*.int
+*.int0
+*.int2
+*.int3
+*.dv
+*.c
+.allres
+CLEAN
+FAILED_TESTS
+runtests.errs
Index: tests/invalid/purity/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/purity/Mmakefile,v
retrieving revision 1.6
diff -u -d -r1.6 Mmakefile
--- tests/invalid/purity/Mmakefile 8 Nov 2002 03:12:54 -0000 1.6
+++ tests/invalid/purity/Mmakefile 24 Jan 2003 16:31:49 -0000
@@ -7,8 +7,10 @@
impure_func_t3 \
impure_func_t4 \
impure_func_t5 \
+ impure_func_t5_fixed \
impure_func_t7 \
impure_pred_t1 \
+ impure_pred_t1_fixed \
impure_pred_t2 \
purity \
purity_nonsense \
Index: tests/invalid/purity/impure_func_t5.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/purity/impure_func_t5.err_exp,v
retrieving revision 1.2
diff -u -d -r1.2 impure_func_t5.err_exp
--- tests/invalid/purity/impure_func_t5.err_exp 17 Jan 2003 05:57:14 -0000 1.2
+++ tests/invalid/purity/impure_func_t5.err_exp 24 Jan 2003 04:59:29 -0000
@@ -1,9 +1,7 @@
-impure_func_t5.m:018: In call to impure function `impure_func_t5.get_counter/1':
-impure_func_t5.m:018: purity error: call must be in an explicit unification
-impure_func_t5.m:018: which is preceded by `impure' indicator.
-impure_func_t5.m:019: In clause for `main(di, uo)':
-impure_func_t5.m:019: mode error in unification of `Y' and `impure_func_t5.foo(X)'.
-impure_func_t5.m:019: Variable `Y' has instantiatedness `free',
-impure_func_t5.m:019: term `impure_func_t5.foo(X)'
-impure_func_t5.m:019: has instantiatedness `impure_func_t5.foo(free)'.
+impure_func_t5.m:018: In clause for predicate `impure_func_t5.main/2':
+impure_func_t5.m:018: in argument 1 of functor `foo/1':
+impure_func_t5.m:018: type error in unification of argument
+impure_func_t5.m:018: and constant `get_counter'.
+impure_func_t5.m:018: argument has type `((func int) = int)',
+impure_func_t5.m:018: constant `get_counter' has type `(impure ((func int) = int))'.
For more information, try recompiling with `-E'.
Index: tests/invalid/purity/impure_func_t5_fixed.err_exp
===================================================================
RCS file: tests/invalid/purity/impure_func_t5_fixed.err_exp
diff -N tests/invalid/purity/impure_func_t5_fixed.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/purity/impure_func_t5_fixed.err_exp 24 Jan 2003 16:27:47 -0000
@@ -0,0 +1,6 @@
+impure_func_t5_fixed.m:022: In clause for `main(di, uo)':
+impure_func_t5_fixed.m:022: in argument 2 (i.e. argument 1 of the called function) of impure higher-order function call:
+impure_func_t5_fixed.m:022: mode error: variable `V_12' has instantiatedness `free',
+impure_func_t5_fixed.m:022: expected instantiatedness was `ground'.
+impure_func_t5_fixed.m:022: The goal could not be reordered, because it was impure.
+For more information, try recompiling with `-E'.
Index: tests/invalid/purity/impure_func_t5_fixed.m
===================================================================
RCS file: tests/invalid/purity/impure_func_t5_fixed.m
diff -N tests/invalid/purity/impure_func_t5_fixed.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/purity/impure_func_t5_fixed.m 24 Jan 2003 16:27:28 -0000
@@ -0,0 +1,31 @@
+% XXX we issue a poor error message for this example
+
+:- module impure_func_t5_fixed.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(state::di, state::uo) is det.
+
+:- implementation.
+:- import_module int, require, list.
+
+:- type foo ---> foo(impure func(int) = int).
+
+:- pragma promise_pure(main/2).
+
+main -->
+ { Y = foo(get_counter) },
+ { Y = foo(X) },
+ print("X(4) = "),
+ { X4 = impure_apply(X,4) }, % missing `impure'
+ print(X4),
+ nl.
+
+:- impure func get_counter(int) = int is det.
+
+:- pragma c_header_code("extern Integer counter;").
+:- pragma c_code("Integer counter = 0;").
+:- pragma c_code(get_counter(Y::in) = (X::out), will_not_call_mercury, "X = counter + Y;").
+get_counter(X) = X.
Index: tests/invalid/purity/impure_pred_t1.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/purity/impure_pred_t1.err_exp,v
retrieving revision 1.2
diff -u -d -r1.2 impure_pred_t1.err_exp
--- tests/invalid/purity/impure_pred_t1.err_exp 17 Jan 2003 05:57:15 -0000 1.2
+++ tests/invalid/purity/impure_pred_t1.err_exp 24 Jan 2003 06:24:43 -0000
@@ -1,11 +1,7 @@
-impure_pred_t1.m:020: In call to impure predicate `impure_pred_t1.get_counter/2':
-impure_pred_t1.m:020: purity error: call must be preceded by `impure' indicator.
-impure_pred_t1.m:012: In predicate `impure_pred_t1.main/2':
-impure_pred_t1.m:012: purity error: predicate is impure.
-impure_pred_t1.m:012: It must be declared `impure' or promised pure.
-impure_pred_t1.m:021: In clause for `main(di, uo)':
-impure_pred_t1.m:021: mode error in unification of `Y' and `impure_pred_t1.foo(X)'.
-impure_pred_t1.m:021: Variable `Y' has instantiatedness `free',
-impure_pred_t1.m:021: term `impure_pred_t1.foo(X)'
-impure_pred_t1.m:021: has instantiatedness `impure_pred_t1.foo(free)'.
+impure_pred_t1.m:020: In clause for predicate `impure_pred_t1.main/2':
+impure_pred_t1.m:020: in argument 1 of functor `foo/1':
+impure_pred_t1.m:020: type error in unification of argument
+impure_pred_t1.m:020: and constant `get_counter'.
+impure_pred_t1.m:020: argument has type `pred(int, int)',
+impure_pred_t1.m:020: constant `get_counter' has type `(impure pred(int, int))'.
For more information, try recompiling with `-E'.
Index: tests/invalid/purity/impure_pred_t1_fixed.err_exp
===================================================================
RCS file: tests/invalid/purity/impure_pred_t1_fixed.err_exp
diff -N tests/invalid/purity/impure_pred_t1_fixed.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/purity/impure_pred_t1_fixed.err_exp 24 Jan 2003 06:25:43 -0000
@@ -0,0 +1,5 @@
+impure_pred_t1_fixed.m:022: In clause for predicate `impure_pred_t1_fixed.main/2':
+impure_pred_t1_fixed.m:022: in argument 1 (i.e. the predicate term) of higher-order predicate call:
+impure_pred_t1_fixed.m:022: type error: variable `X' has type `(impure pred(int, int))',
+impure_pred_t1_fixed.m:022: expected type was `pred(V_2, V_1)'.
+For more information, try recompiling with `-E'.
Index: tests/invalid/purity/impure_pred_t1_fixed.m
===================================================================
RCS file: tests/invalid/purity/impure_pred_t1_fixed.m
diff -N tests/invalid/purity/impure_pred_t1_fixed.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/purity/impure_pred_t1_fixed.m 24 Jan 2003 06:25:22 -0000
@@ -0,0 +1,32 @@
+
+% Subverting the Mercury purity system.
+
+% This should not be possible.
+
+:- module impure_pred_t1_fixed.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(state::di, state::uo) is det.
+
+:- implementation.
+:- import_module int, require, list.
+
+:- type foo ---> foo(impure pred(int,int)).
+
+main -->
+ { Y = foo(get_counter) },
+ { Y = foo(X) },
+ { X(4, Z) },
+ print("X = "),
+ print(Z),
+ nl.
+
+:- impure pred get_counter(int::in, int::out) is det.
+
+:- pragma c_header_code("extern Integer counter;").
+:- pragma c_code("Integer counter = 0;").
+:- pragma c_code(get_counter(Y::in, X::out), will_not_call_mercury, "X = counter + Y;").
+get_counter(X, X).
Index: tests/invalid/purity/impure_pred_t2.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/purity/impure_pred_t2.err_exp,v
retrieving revision 1.2
diff -u -d -r1.2 impure_pred_t2.err_exp
--- tests/invalid/purity/impure_pred_t2.err_exp 17 Jan 2003 05:57:15 -0000 1.2
+++ tests/invalid/purity/impure_pred_t2.err_exp 24 Jan 2003 16:35:04 -0000
@@ -1,6 +1,5 @@
-impure_pred_t2.m:018: In call to impure predicate `impure_pred_t2.get_counter/2':
-impure_pred_t2.m:018: purity error: call must be preceded by `impure' indicator.
-impure_pred_t2.m:012: In predicate `impure_pred_t2.main/2':
-impure_pred_t2.m:012: purity error: predicate is impure.
-impure_pred_t2.m:012: It must be declared `impure' or promised pure.
+impure_pred_t2.m:019: In clause for predicate `impure_pred_t2.main/2':
+impure_pred_t2.m:019: in argument 1 (i.e. the predicate term) of higher-order predicate call:
+impure_pred_t2.m:019: type error: variable `Y' has type `(impure pred(int, int))',
+impure_pred_t2.m:019: expected type was `pred(V_2, V_1)'.
For more information, try recompiling with `-E'.
Index: tests/invalid/purity/purity.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/purity/purity.err_exp,v
retrieving revision 1.3
diff -u -d -r1.3 purity.err_exp
--- tests/invalid/purity/purity.err_exp 17 Jan 2003 05:57:15 -0000 1.3
+++ tests/invalid/purity/purity.err_exp 24 Jan 2003 16:33:31 -0000
@@ -25,10 +25,12 @@
purity.m:078: purity error: call must be preceded by `semipure' indicator.
purity.m:112: In call to impure predicate `purity.imp1/1':
purity.m:112: purity error: call must be preceded by `impure' indicator.
-purity.m:112: Purity error in closure: closure is impure.
+purity.m:112: Purity error in closure: closure body is impure,
+purity.m:112: but closure was not declared `impure.'
purity.m:118: In call to semipure predicate `purity.semi/0':
purity.m:118: purity error: call must be preceded by `semipure' indicator.
-purity.m:118: Purity error in closure: closure is semipure.
+purity.m:118: Purity error in closure: closure body is semipure,
+purity.m:118: but closure was not declared `semipure.'
purity.m:093: In unification predicate for type (purity.e8):
purity.m:093: purity error: predicate is impure.
purity.m:093: It must be pure.
Index: tests/invalid/purity/purity_nonsense.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/purity/purity_nonsense.err_exp,v
retrieving revision 1.2
diff -u -d -r1.2 purity_nonsense.err_exp
--- tests/invalid/purity/purity_nonsense.err_exp 17 Jan 2003 05:57:15 -0000 1.2
+++ tests/invalid/purity/purity_nonsense.err_exp 24 Jan 2003 16:34:01 -0000
@@ -6,10 +6,12 @@
purity_nonsense.m:012: without preceding `pred' declaration.
purity_nonsense.m:013: Error: clause for predicate `purity_nonsense.e13/0'
purity_nonsense.m:013: without preceding `pred' declaration.
-purity_nonsense.m:018: Warning: unnecessary `impure' marker.
-purity_nonsense.m:018: Higher-order goals are always pure.
purity_nonsense.m:008: Error: no clauses for
purity_nonsense.m:008: predicate `purity_nonsense.undefined/0'.
+purity_nonsense.m:018: In clause for predicate `purity_nonsense.e14/1':
+purity_nonsense.m:018: in argument 1 (i.e. the predicate term) of impure higher-order predicate call:
+purity_nonsense.m:018: type error: variable `P' has type `(pred)',
+purity_nonsense.m:018: expected type was `(impure (pred))'.
purity_nonsense.m:012: In clause for predicate `purity_nonsense.e12/0':
purity_nonsense.m:012: in argument 1 of call to predicate `impure/1':
purity_nonsense.m:012: error: the language construct \\+/1 should be
@@ -42,6 +44,4 @@
purity_nonsense.m:013: error: undefined symbol `semi/0'.
purity_nonsense.m:013: In clause for predicate `purity_nonsense.e13/0':
purity_nonsense.m:013: error: `semipure' marker in an inappropriate place.
-purity_nonsense.m:015: In predicate `purity_nonsense.e14/1':
-purity_nonsense.m:015: warning: declared `impure' but actually pure.
For more information, try recompiling with `-E'.
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
The University of Melbourne | of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh> | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list