Diff: Make Mercury cope with impure code (part 1/2)
Peter Schachte
pets at cs.mu.oz.au
Fri Nov 28 18:44:45 AEDT 1997
================ begin part 1/2 ================
Make Mercury cope with impure code
The purpose of this diff is to allow Mercury programs to contain
impure Mercury code without the compiler changing its behavior
inappropriately, while still allowing the compiler to aggressively
optimize pure code. To do this, we require impure predicates to be so
declared, and calls to impure predicates to be flagged as such. We
also allow predicates implemented in terms of impure predicates to be
promised to be pure; lacking such a promise, any predicate that calls
an impure predicate is assumed to be impure.
At the moment, we don't allow impure functions (only predicates),
though some of the work necessary to support them has been done.
Note that to make the operators work properly, the precedence of the
`pred' and `func' operators has been changed from 1199 to 800.
Estimated hours taken: 120
compiler/purity.m:
New compiler pass for purity checking.
compiler/hlds_goal.m:
Add `impure' and `semipure' to the goal_feature enum.
compiler/hlds_out.m:
compiler/typecheck.m:
compiler/special_pred.m:
Fixed code that prints predicate name to write something more
helpful for special (compiler-generated) predicates. Added
code to print new markers. Added purity argument to
mercury_output_pred_type. New public predicate
special_pred_description/2 provides an english description for
each compiler-generated predicate.
compiler/hlds_pred.m:
Add `impure' and `semipure' to marker enum. Added new
public predicates to get predicate purity and whether or not
it's promised to be pure.
compiler/prog_data.m:
compiler/mercury_to_mercury.m:
compiler/prog_io.m:
compiler/prog_io_goal.m:
compiler/prog_io_pragma.m:
compiler/prog_io_dcg.m:
compiler/prog_util.m:
compiler/equiv_type.m:
compiler/intermod.m:
compiler/mercury_to_c.m:
compiler/module_qual.m:
Add purity argument to pred and func items. Add new `impure'
and `semipure' operators. Add promise_pure pragma. Add
purity/2 wrapper to goal_expr type.
compiler/make_hlds.m:
compiler/mercury_to_goedel.m:
Added purity argument to module_add_{pred,func},
clauses_info_add_pragma_c_code, and to pred and func items.
Handle promise_pure pragma. Handle purity/2 wrapper used to
handle user-written impurity annotations on goals.
compiler/mercury_compile.m:
Add purity checking pass between type and mode checking.
compiler/mode_errors.m:
Distinguish mode errors caused by impure goals preventing
goals being delayed.
compiler/modes.m:
Don't delay impure goals, and ensure before scheduling an
impure goal that no goals are delayed. Actually, we go ahead
and try to schedule goals even if impurity causes a problem,
and then if it still doesn't mode check, then we report an
ordinary mode error. Only if the clause would be mode correct
except for an impure goal do we report it as an impurity problem.
compiler/simplify.m:
Don't optimize away non-pure duplicate calls. We could do
better and still optimize duplicate semipure goals without an
intervening impure goal, but it's probably not worth the
trouble. Also don't eliminate impure goals on a failing branch.
compiler/notes/compiler_design.html:
Documented purity checking pass.
doc/reference_manual.texi:
Document purity system.
doc/transition_guide.texi:
library/nc_builtin.nl:
library/ops.m:
library/sp_builtin.nl:
New operators and new precdence for `pred' and `func'
operators.
tests/hard_coded/purity.m
tests/hard_coded/purity.exp
tests/hard_coded/Mmakefile:
tests/invalid/purity.m
tests/invalid/purity_nonsense.m
tests/invalid/purity.err_exp
tests/invalid/purity_nonsense.err_exp
tests/invalid/Mmakefile:
Test cases for purity.
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/equiv_type.m,v
retrieving revision 1.9
diff -u -r1.9 equiv_type.m
--- equiv_type.m 1997/08/22 13:54:55 1.9
+++ equiv_type.m 1997/09/02 04:36:22
@@ -112,17 +112,20 @@
equiv_type__replace_in_type_defn(TypeDefn0, VarSet0, EqvMap,
TypeDefn, VarSet, ContainsCirc).
-equiv_type__replace_in_item(pred(VarSet0, PredName, TypesAndModes0, Det, Cond),
- EqvMap, pred(VarSet, PredName, TypesAndModes, Det, Cond), no) :-
+equiv_type__replace_in_item(
+ pred(VarSet0, PredName, TypesAndModes0, Det, Cond, Purity),
+ EqvMap,
+ pred(VarSet, PredName, TypesAndModes, Det, Cond, Purity),
+ no) :-
equiv_type__replace_in_tms(TypesAndModes0, VarSet0, EqvMap,
TypesAndModes, VarSet).
equiv_type__replace_in_item(
func(VarSet0, PredName, TypesAndModes0,
- RetTypeAndMode0, Det, Cond),
+ RetTypeAndMode0, Det, Cond, Purity),
EqvMap,
func(VarSet, PredName, TypesAndModes, RetTypeAndMode,
- Det, Cond),
+ Det, Cond, Purity),
no) :-
equiv_type__replace_in_tms(TypesAndModes0, VarSet0, EqvMap,
TypesAndModes, VarSet1),
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_goal.m,v
retrieving revision 1.42
diff -u -r1.42 hlds_goal.m
--- hlds_goal.m 1997/10/13 08:09:41 1.42
+++ hlds_goal.m 1997/11/14 00:32:04
@@ -365,9 +365,11 @@
:- type hlds_goal_info.
:- type goal_feature
- ---> constraint. % This is included if the goal is
+ ---> constraint % This is included if the goal is
% a constraint. See constraint.m
% for the definition of this.
+ ; (impure) % This goal is impure. See hlds_pred.m.
+ ; (semipure). % This goal is semipure. See hlds_pred.m.
% see notes/ALLOCATION for what these alternatives mean
:- type resume_point ---> resume_point(set(var), resume_locs)
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.175
diff -u -r1.175 hlds_out.m
--- hlds_out.m 1997/11/24 07:26:42 1.175
+++ hlds_out.m 1997/11/25 01:23:54
@@ -174,7 +174,7 @@
:- implementation.
-:- import_module mercury_to_mercury, globals, options.
+:- import_module mercury_to_mercury, globals, options, purity, special_pred.
:- import_module llds_out, prog_out, prog_util, (inst), instmap, trace.
:- import_module bool, int, string, list, set, map, std_util, assoc_list.
@@ -238,16 +238,21 @@
{ pred_info_name(PredInfo, Name) },
{ pred_info_arity(PredInfo, Arity) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
- hlds_out__write_pred_or_func(PredOrFunc),
- io__write_string(" `"),
- io__write_string(Module),
- io__write_string(":"),
- ( { string__append("__", _, Name) } ->
+ ( { special_pred_name_arity(Kind, _, Name, Arity) } ->
+ { special_pred_description(Kind, Descr) },
+ io__write_string(Descr),
+ io__write_string(" for type "),
{ pred_info_arg_types(PredInfo, TVarSet, ArgTypes) },
- { term__context_init(Context) },
- mercury_output_term(term__functor(term__atom(Name),
- ArgTypes, Context), TVarSet, no)
+ ( { special_pred_get_type(Name, ArgTypes, Type) } ->
+ mercury_output_term(Type, TVarSet, no)
+ ;
+ { error("special_pred_get_type failed!") }
+ )
;
+ hlds_out__write_pred_or_func(PredOrFunc),
+ io__write_string(" `"),
+ io__write_string(Module),
+ io__write_string(":"),
{ PredOrFunc = function ->
OrigArity is Arity - 1
;
@@ -255,9 +260,9 @@
},
io__write_string(Name),
io__write_string("/"),
- io__write_int(OrigArity)
- ),
- io__write_string("'").
+ io__write_int(OrigArity),
+ io__write_string("'")
+ ).
hlds_out__write_pred_proc_id(ModuleInfo, PredId, ProcId) -->
hlds_out__write_pred_id(ModuleInfo, PredId),
@@ -447,8 +452,8 @@
{ pred_info_import_status(PredInfo, ImportStatus) },
{ pred_info_get_markers(PredInfo, Markers) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
- mercury_output_pred_type(TVarSet, qualified(Module, PredName), ArgTypes,
- no, Context),
+ mercury_output_pred_type(TVarSet, qualified(Module, PredName),
+ ArgTypes, no, pure, Context),
{ ClausesInfo = clauses_info(VarSet, _, VarTypes, HeadVars, Clauses) },
hlds_out__write_indent(Indent),
io__write_string("% pred id: "),
@@ -504,6 +509,9 @@
hlds_out__marker_name(magic, "magic").
hlds_out__marker_name(obsolete, "obsolete").
hlds_out__marker_name(memo, "memo").
+hlds_out__marker_name((impure), "impure").
+hlds_out__marker_name((semipure), "semipure").
+hlds_out__marker_name(promised_pure, "promised_pure").
hlds_out__marker_name(terminates, "terminates").
hlds_out__marker_name(check_termination, "check_termination").
hlds_out__marker_name(does_not_terminate, "does_not_terminate").
@@ -811,6 +819,21 @@
io__write_string("% store map:\n"),
hlds_out__write_var_to_lvals(SMlist, VarSet, AppendVarnums,
Indent)
+ ;
+ []
+ ),
+ ( { string__contains_char(Verbose, 'g') }
+ ->
+ { goal_info_get_features(GoalInfo, Features) },
+ { set__to_sorted_list(Features, Flist) },
+ ( { Flist = [] } ->
+ []
+ ;
+ hlds_out__write_indent(Indent),
+ io__write_string("% Goal features: "),
+ io__write(Flist),
+ io__write_string("\n")
+ )
;
[]
).
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.38
diff -u -r1.38 hlds_pred.m
--- hlds_pred.m 1997/11/24 07:26:44 1.38
+++ hlds_pred.m 1997/11/25 06:09:02
@@ -14,6 +14,7 @@
:- interface.
:- import_module hlds_data, hlds_goal, hlds_module, llds, prog_data, instmap.
+:- import_module purity.
:- import_module bool, list, map, std_util, term, varset.
:- import_module term_util.
@@ -200,6 +201,21 @@
; memo % Requests that this predicate be evaluated
% using memoing.
% Used for pragma(memo).
+ ; (impure) % Requests that no transformation that would
+ % be inappropriate for impure code be
+ % performed on calls to this predicate. This
+ % includes reordering calls to it relative to
+ % other goals (in both conjunctions and
+ % disjunctions), and removing redundant calls
+ % to it.
+ ; (semipure) % Requests that no transformation that would
+ % be inappropriate for semipure code be
+ % performed on calls to this predicate. This
+ % includes removing redundant calls to it on
+ % different sides of an impure goal.
+ ; promised_pure % Requests that calls to this predicate be
+ % transformed as usual, despite any impure
+ % or semipure markers present.
% The terminates and does_not_terminate
% pragmas are kept as markers to ensure
@@ -348,6 +364,15 @@
:- pred pred_info_requested_no_inlining(pred_info).
:- mode pred_info_requested_no_inlining(in) is semidet.
+:- pred pred_info_get_purity(pred_info, purity).
+:- mode pred_info_get_purity(in, out) is det.
+
+:- pred pred_info_get_promised_pure(pred_info, bool).
+:- mode pred_info_get_promised_pure(in, out) is det.
+
+:- pred purity_to_markers(purity, pred_markers).
+:- mode purity_to_markers(in, out) is det.
+
:- pred pred_info_get_is_pred_or_func(pred_info, pred_or_func).
:- mode pred_info_get_is_pred_or_func(in, out) is det.
@@ -367,7 +392,7 @@
:- pred check_marker(pred_markers, marker).
:- mode check_marker(in, in) is semidet.
- % a a marker to the set
+ % add a marker to the set
:- pred add_marker(pred_markers, marker, pred_markers).
:- mode add_marker(in, in, out) is det.
@@ -585,6 +610,29 @@
pred_info_requested_no_inlining(PredInfo0) :-
pred_info_get_markers(PredInfo0, Markers),
check_marker(Markers, no_inline).
+
+pred_info_get_purity(PredInfo0, Purity) :-
+ pred_info_get_markers(PredInfo0, Markers),
+ ( check_marker(Markers, (impure)) ->
+ Purity = (impure)
+ ; check_marker(Markers, (semipure)) ->
+ Purity = (semipure)
+ ;
+ Purity = pure
+ ).
+
+pred_info_get_promised_pure(PredInfo0, Promised) :-
+ pred_info_get_markers(PredInfo0, Markers),
+ ( check_marker(Markers, promised_pure) ->
+ Promised = yes
+ ;
+ Promised = no
+ ).
+
+purity_to_markers(pure, []).
+purity_to_markers(semipure, [semipure]).
+purity_to_markers(impure, [impure]).
+
pred_info_get_markers(PredInfo, Markers) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, Markers, _).
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.36
diff -u -r1.36 intermod.m
--- intermod.m 1997/11/24 07:26:45 1.36
+++ intermod.m 1997/11/25 00:58:50
@@ -848,17 +848,18 @@
{ pred_info_name(PredInfo, Name) },
{ pred_info_arg_types(PredInfo, TVarSet, ArgTypes) },
{ pred_info_context(PredInfo, Context) },
+ { pred_info_get_purity(PredInfo, Purity) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
(
{ PredOrFunc = predicate },
mercury_output_pred_type(TVarSet, qualified(Module, Name),
- ArgTypes, no, Context)
+ ArgTypes, no, Purity, Context)
;
{ PredOrFunc = function },
{ pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType) },
mercury_output_func_type(TVarSet,
qualified(Module, Name), FuncArgTypes,
- FuncRetType, no, Context)
+ FuncRetType, no, Purity, Context)
),
{ pred_info_procedures(PredInfo, Procs) },
{ pred_info_procids(PredInfo, ProcIds) },
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.245
diff -u -r1.245 make_hlds.m
--- make_hlds.m 1997/11/24 07:26:48 1.245
+++ make_hlds.m 1997/11/25 05:01:59
@@ -61,7 +61,7 @@
:- import_module make_tags, quantification, (inst).
:- import_module code_util, unify_proc, special_pred, type_util, mode_util.
:- import_module mercury_to_mercury, passes_aux, clause_to_proc, inst_match.
-:- import_module fact_table, term_util.
+:- import_module fact_table, purity, term_util.
:- import_module string, char, int, set, bintree, list, map, require.
:- import_module bool, getopt, assoc_list, term, term_io, varset.
@@ -188,15 +188,17 @@
module_add_mode_defn(Module0, VarSet, ModeDefn, Cond, Context,
Status, Module).
-add_item_decl_pass_1(pred(VarSet, PredName, TypesAndModes, MaybeDet, Cond),
- Context, Status, Module0, Status, Module) -->
+add_item_decl_pass_1(pred(VarSet, PredName, TypesAndModes, MaybeDet, Cond,
+ Purity), Context, Status, Module0, Status, Module) -->
module_add_pred(Module0, VarSet, PredName, TypesAndModes, MaybeDet,
- Cond, Context, Status, Module).
+ Cond, Purity, Context, Status, Module).
add_item_decl_pass_1(func(VarSet, FuncName, TypesAndModes, RetTypeAndMode,
- MaybeDet, Cond), Context, Status, Module0, Status, Module) -->
+ MaybeDet, Cond, Purity), Context, Status, Module0, Status,
+ Module) -->
module_add_func(Module0, VarSet, FuncName, TypesAndModes,
- RetTypeAndMode, MaybeDet, Cond, Context, Status, Module).
+ RetTypeAndMode, MaybeDet, Cond, Purity, Context, Status,
+ Module).
add_item_decl_pass_1(pred_mode(VarSet, PredName, Modes, MaybeDet, Cond),
Context, Status, Module0, Status, Module) -->
@@ -382,6 +384,10 @@
{ Pragma = fact_table(_, _, _) },
{ Module = Module0 }
;
+ { Pragma = promise_pure(Name, Arity) },
+ add_pred_marker(Module0, "promise_pure", Name, Arity, Context,
+ promised_pure, [], Module)
+ ;
{ Pragma = termination_info(PredOrFunc, SymName, ModeList,
Termination) },
{ module_info_get_predicate_table(Module0, Preds) },
@@ -461,8 +467,8 @@
).
add_item_decl_pass_2(func(_VarSet, FuncName, TypesAndModes, _RetTypeAndMode,
- _MaybeDet, _Cond), _Context, Status, Module0, Status, Module)
- -->
+ _MaybeDet, _Cond, _Purity), _Context, Status, Module0, Status,
+ Module) -->
%
% add default modes for function declarations, if necessary
%
@@ -488,7 +494,7 @@
--> [].
add_item_decl_pass_2(mode_defn(_, _, _), _, Status, Module, Status, Module)
--> [].
-add_item_decl_pass_2(pred(_, _, _, _, _), _, Status, Module, Status, Module)
+add_item_decl_pass_2(pred(_, _, _, _, _, _), _, Status, Module, Status, Module)
--> [].
add_item_decl_pass_2(pred_mode(_, _, _, _, _), _, Status, Module, Status,
Module) --> [].
@@ -537,9 +543,9 @@
Module, Module, Info, Info) --> [].
add_item_clause(mode_defn(_, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
-add_item_clause(pred(_, _, _, _, _), Status, Status, _,
+add_item_clause(pred(_, _, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
-add_item_clause(func(_, _, _, _, _, _), Status, Status, _,
+add_item_clause(func(_, _, _, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
add_item_clause(pred_mode(_, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
@@ -656,9 +662,8 @@
{ Module = Module1 }
)
;
- { string__append_list(
- ["`:- pragma ", PragmaName, "' declaration"],
- Description) },
+ { string__append_list(["`", PragmaName, "' pragma"],
+ Description) },
undefined_pred_or_func_error(Name, Arity, Context,
Description),
{ module_info_incr_errors(Module0, Module) }
@@ -1058,12 +1063,13 @@
%---------------------------------------------------------------------------%
:- pred module_add_pred(module_info, varset, sym_name, list(type_and_mode),
- maybe(determinism), condition, term__context,
+ maybe(determinism), condition, purity, term__context,
item_status, module_info, io__state, io__state).
-:- mode module_add_pred(in, in, in, in, in, in, in, in, out, di, uo) is det.
+:- mode module_add_pred(in, in, in, in, in, in, in, in, in, out, di, uo)
+ is det.
module_add_pred(Module0, VarSet, PredName, TypesAndModes, MaybeDet, Cond,
- Context, item_status(Status, NeedQual), Module) -->
+ Purity, Context, item_status(Status, NeedQual), Module) -->
% Only preds with opt_imported clauses are tagged as opt_imported, so
% that the compiler doesn't look for clauses for other preds read in
% from optimization interfaces.
@@ -1073,7 +1079,7 @@
DeclStatus = Status
},
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
- add_new_pred(Module0, VarSet, PredName, Types, Cond, Context,
+ add_new_pred(Module0, VarSet, PredName, Types, Cond, Purity, Context,
DeclStatus, NeedQual, predicate, Module1),
(
{ MaybeModes = yes(Modes) }
@@ -1085,12 +1091,13 @@
).
:- pred module_add_func(module_info, varset, sym_name, list(type_and_mode),
- type_and_mode, maybe(determinism), condition, term__context,
- item_status, module_info, io__state, io__state).
-:- mode module_add_func(in, in, in, in, in, in, in, in, in, out, di, uo) is det.
+ type_and_mode, maybe(determinism), condition, purity,
+ term__context, item_status, module_info, io__state, io__state).
+:- mode module_add_func(in, in, in, in, in, in, in, in, in, in, out, di, uo)
+ is det.
module_add_func(Module0, VarSet, FuncName, TypesAndModes, RetTypeAndMode,
- MaybeDet, Cond, Context,
+ MaybeDet, Cond, Purity, Context,
item_status(Status, NeedQual), Module) -->
% Only funcs with opt_imported clauses are tagged as opt_imported, so
% that the compiler doesn't look for clauses for other preds.
@@ -1102,7 +1109,7 @@
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
{ split_type_and_mode(RetTypeAndMode, RetType, MaybeRetMode) },
{ list__append(Types, [RetType], Types1) },
- add_new_pred(Module0, VarSet, FuncName, Types1, Cond, Context,
+ add_new_pred(Module0, VarSet, FuncName, Types1, Cond, Purity, Context,
DeclStatus, NeedQual, function, Module1),
(
{ MaybeModes = yes(Modes) },
@@ -1116,15 +1123,16 @@
).
:- pred add_new_pred(module_info, tvarset, sym_name, list(type), condition,
- term__context, import_status, need_qualifier, pred_or_func,
- module_info, io__state, io__state).
-:- mode add_new_pred(in, in, in, in, in, in, in, in, in, out, di, uo) is det.
+ purity, term__context, import_status, need_qualifier,
+ pred_or_func, module_info, io__state, io__state).
+:- mode add_new_pred(in, in, in, in, in, in, in, in, in, in, out, di, uo)
+ is det.
% NB. Predicates are also added in polymorphism.m, which converts
% lambda expressions into separate predicates, so any changes may need
% to be reflected there too.
-add_new_pred(Module0, TVarSet, PredName, Types, Cond, Context,
+add_new_pred(Module0, TVarSet, PredName, Types, Cond, Purity, Context,
Status, NeedQual, PredOrFunc, Module) -->
{ module_info_name(Module0, ModuleName) },
{ list__length(Types, Arity) },
@@ -1139,7 +1147,7 @@
{ Module1 = Module0 },
{ module_info_get_predicate_table(Module1, PredicateTable0) },
{ clauses_info_init(Arity, ClausesInfo) },
- { init_markers(Markers) },
+ { purity_to_markers(Purity, Markers) },
{ pred_info_init(ModuleName, PredName, Arity, TVarSet, Types,
Cond, Context, ClausesInfo, Status, Markers,
none, PredOrFunc, PredInfo0) },
@@ -1792,7 +1800,8 @@
->
{ pred_info_clauses_info(PredInfo1, Clauses0) },
{ pred_info_arg_types(PredInfo1, _TVarSet, ArgTypes) },
- clauses_info_add_pragma_c_code(Clauses0,
+ { pred_info_get_purity(PredInfo1, Purity) },
+ clauses_info_add_pragma_c_code(Clauses0, Purity,
MayCallMercury, PredId, ProcId, VarSet,
PVars, ArgTypes, C_Code, Context, ExtraInfo,
Clauses, Info0, Info),
@@ -2415,17 +2424,17 @@
% pragma c_code declaration and the head vars of the pred. Also return the
% hlds_goal.
-:- pred clauses_info_add_pragma_c_code(clauses_info, may_call_mercury,
+:- pred clauses_info_add_pragma_c_code(clauses_info, purity, may_call_mercury,
pred_id, proc_id, varset, list(pragma_var), list(type),
string, term__context,
maybe(pair(list(string))), clauses_info,
qual_info, qual_info, io__state, io__state) is det.
:- mode clauses_info_add_pragma_c_code(in, in, in, in, in, in, in, in, in, in,
- out, in, out, di, uo) is det.
+ in, out, in, out, di, uo) is det.
-clauses_info_add_pragma_c_code(ClausesInfo0, MayCallMercury, PredId, ModeId,
- PVarSet, PVars, OrigArgTypes, C_Code, Context, ExtraInfo,
- ClausesInfo, Info0, Info) -->
+clauses_info_add_pragma_c_code(ClausesInfo0, Purity, MayCallMercury, PredId,
+ ModeId, PVarSet, PVars, OrigArgTypes, C_Code, Context,
+ ExtraInfo, ClausesInfo, Info0, Info) -->
{
ClausesInfo0 = clauses_info(VarSet0, VarTypes, VarTypes1,
HeadVars, ClauseList),
@@ -2450,7 +2459,9 @@
% build the pragma_c_code
goal_info_init(GoalInfo0),
- goal_info_set_context(GoalInfo0, Context, GoalInfo),
+ goal_info_set_context(GoalInfo0, Context, GoalInfo1),
+ % Put the purity in the goal_info in case this c code is inlined
+ add_goal_info_purity_feature(GoalInfo1, Purity, GoalInfo),
HldsGoal0 = pragma_c_code(C_Code, MayCallMercury, PredId, ModeId, Args,
Names, OrigArgTypes, ExtraPragmaInfo) - GoalInfo
},
@@ -2592,8 +2603,8 @@
transform_goal_2(TransformedGoal, Context, VarSet0, Subst,
Goal, VarSet, Info0, Info).
-transform_goal_2(call(Name, Args0), Context, VarSet0, Subst, Goal, VarSet,
- Info0, Info) -->
+transform_goal_2(call(Name, Args0, Purity), Context, VarSet0, Subst, Goal,
+ VarSet, Info0, Info) -->
(
{ Name = unqualified("\\=") },
{ Args0 = [LHS, RHS] }
@@ -2604,30 +2615,48 @@
;
{ term__apply_substitution_to_list(Args0, Subst, Args) },
{ make_fresh_arg_vars(Args, VarSet0, HeadVars, VarSet1) },
- {
+ (
% check for a higher-order call,
% i.e. a call to either call/N or ''/N.
- ( Name = unqualified("call")
+ { Name = unqualified("call")
; Name = unqualified("")
- ),
- HeadVars = [PredVar | RealHeadVars]
+ },
+ { HeadVars = [PredVar | RealHeadVars] }
->
- % initialize some fields to junk
- Types = [],
- Modes = [],
- Det = erroneous,
- Call = higher_order_call(PredVar, RealHeadVars,
- Types, Modes, Det, predicate)
+ { % initialize some fields to junk
+ Types = [],
+ Modes = [],
+ Det = erroneous,
+ Call = higher_order_call(PredVar, RealHeadVars,
+ Types, Modes, Det,
+ predicate),
+ 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")
+ )
;
% initialize some fields to junk
- invalid_pred_id(PredId),
- invalid_proc_id(ModeId),
- MaybeUnifyContext = no,
- Call = call(PredId, ModeId, HeadVars, not_builtin,
- MaybeUnifyContext, Name)
- },
+ { invalid_pred_id(PredId),
+ invalid_proc_id(ModeId),
+ MaybeUnifyContext = no,
+ Call = call(PredId, ModeId, HeadVars, not_builtin,
+ MaybeUnifyContext, Name),
+ Purity1 = Purity
+ }
+ ),
{ goal_info_init(GoalInfo0) },
- { goal_info_set_context(GoalInfo0, Context, GoalInfo) },
+ { goal_info_set_context(GoalInfo0, Context, GoalInfo1) },
+ { add_goal_info_purity_feature(GoalInfo1, Purity1, GoalInfo) },
{ Goal0 = Call - GoalInfo },
{ list__length(Args, Arity) },
@@ -2644,6 +2673,7 @@
unravel_unification(A, B, Context, explicit, [],
VarSet0, Goal, VarSet, Info0, Info).
+
%-----------------------------------------------------------------------------
% `insert_arg_unifications' takes a list of variables,
@@ -3323,6 +3353,8 @@
hlds_out__write_pred_call_id(Name/Arity),
io__write_string("\n"),
prog_out__write_context(Context),
+ % XXX is `preceding' the right word here? Can't the pred or func decl
+ % appear afterward? Would `corresponding' be a better word?
io__write_string(" without preceding `pred' or `func' declaration\n").
:- pred undefined_mode_error(sym_name, int, term__context, string,
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.60
diff -u -r1.60 mercury_compile.m
--- mercury_compile.m 1997/11/08 13:11:34 1.60
+++ mercury_compile.m 1997/11/14 00:32:20
@@ -30,7 +30,7 @@
% the main compiler passes (in order of execution)
:- import_module handle_options, prog_io, modules, module_qual, equiv_type.
-:- import_module make_hlds, typecheck, modes.
+:- import_module make_hlds, typecheck, purity, modes.
:- import_module switch_detection, cse_detection, det_analysis, unique_modes.
:- import_module simplify, intermod, trans_opt, bytecode_gen, bytecode.
:- import_module (lambda), polymorphism, termination, higher_order, inlining.
@@ -550,10 +550,13 @@
% is det.
:- mode mercury_compile__frontend_pass_2_by_phases(in, out, out, di, uo) is det.
-mercury_compile__frontend_pass_2_by_phases(HLDS4, HLDS20, FoundError) -->
+mercury_compile__frontend_pass_2_by_phases(HLDS3, HLDS20, FoundError) -->
globals__io_lookup_bool_option(verbose, Verbose),
globals__io_lookup_bool_option(statistics, Stats),
+ mercury_compile__puritycheck(HLDS3, Verbose, Stats, HLDS4),
+ mercury_compile__maybe_dump_hlds(HLDS4, "04", "puritycheck"),
+
mercury_compile__modecheck(HLDS4, Verbose, Stats, HLDS5,
FoundModeError, UnsafeToContinue),
mercury_compile__maybe_dump_hlds(HLDS5, "05", "modecheck"),
@@ -914,6 +917,24 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+
+:- pred mercury_compile__puritycheck(module_info, bool, bool,
+ module_info, io__state, io__state).
+:- mode mercury_compile__puritycheck(in, in, in, out, di, uo) is det.
+
+mercury_compile__puritycheck(HLDS0, Verbose, Stats, HLDS) -->
+ { module_info_num_errors(HLDS0, NumErrors0) },
+ puritycheck(HLDS0, HLDS),
+ { module_info_num_errors(HLDS, NumErrors) },
+ ( { NumErrors \= NumErrors0 } ->
+ maybe_write_string(Verbose,
+ "% Program contains purity error(s).\n"),
+ io__set_exit_status(1)
+ ;
+ maybe_write_string(Verbose,
+ "% Program is purity-correct.\n")
+ ),
+ maybe_report_stats(Stats).
:- pred mercury_compile__modecheck(module_info, bool, bool,
module_info, bool, bool, io__state, io__state).
Index: compiler/mercury_to_c.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_c.m,v
retrieving revision 1.28
diff -u -r1.28 mercury_to_c.m
--- mercury_to_c.m 1997/11/24 23:08:21 1.28
+++ mercury_to_c.m 1997/11/25 00:58:55
@@ -170,8 +170,9 @@
;
c_gen_indent(Indent),
io__write_string("/****\n"),
+ { pred_info_get_purity(PredInfo, Purity) },
mercury_output_pred_type(TVarSet, unqualified(PredName),
- ArgTypes, no, Context),
+ ArgTypes, no, Purity, Context),
{ pred_info_clauses_info(PredInfo, ClausesInfo) },
{ ClausesInfo = clauses_info(VarSet, _VarTypes, _, HeadVars,
Index: compiler/mercury_to_goedel.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_goedel.m,v
retrieving revision 1.60
diff -u -r1.60 mercury_to_goedel.m
--- mercury_to_goedel.m 1997/08/22 13:55:25 1.60
+++ mercury_to_goedel.m 1997/11/19 04:05:09
@@ -40,7 +40,7 @@
:- implementation.
:- import_module bool, int, char, std_util, varset, term, require, string.
-:- import_module prog_io, prog_out, prog_util, equiv_type.
+:- import_module prog_io, prog_out, prog_util, equiv_type, purity.
:- import_module globals, options.
%-----------------------------------------------------------------------------%
@@ -140,16 +140,30 @@
goedel_output_item(mode_defn(VarSet, ModeDefn, _Cond), Context) -->
goedel_output_mode_defn(VarSet, ModeDefn, Context).
-goedel_output_item(pred(VarSet, PredName, TypesAndModes, _Det, _Cond), Context)
- -->
+goedel_output_item(pred(VarSet, PredName, TypesAndModes, _Det, _Cond,
+ Purity), Context) -->
io__write_string("\n"),
maybe_write_line_number(Context),
+ ( { Purity = pure } ->
+ []
+ ;
+ io__write_string(" /* "),
+ write_purity(Purity),
+ io__write_string(" */ ")
+ ),
goedel_output_pred(VarSet, PredName, TypesAndModes, Context).
goedel_output_item(func(VarSet, PredName, TypesAndModes, RetTypeAndMode, _Det,
- _Cond), Context) -->
+ _Cond, Purity), Context) -->
io__write_string("\n"),
maybe_write_line_number(Context),
+ ( { Purity = pure } ->
+ []
+ ;
+ io__write_string(" /* "),
+ write_purity(Purity),
+ io__write_string(" */ ")
+ ),
goedel_output_func(VarSet, PredName, TypesAndModes, RetTypeAndMode,
Context).
@@ -606,7 +620,14 @@
io__write_string(")").
% XXX should preserve some of the qualification information?
-goedel_output_goal_2(call(Name, Term), VarSet, Indent) -->
+goedel_output_goal_2(call(Name, Term, Purity), VarSet, Indent) -->
+ ( { Purity = pure } ->
+ []
+ ;
+ io__write_string("/* "),
+ write_purity(Purity),
+ io__write_string(" */ ")
+ ),
{ unqualify_name(Name, Name0) },
{ term__context_init(Context0) },
goedel_output_call(term__functor(term__atom(Name0), Term, Context0), VarSet, Indent).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.121
diff -u -r1.121 mercury_to_mercury.m
--- mercury_to_mercury.m 1997/11/23 05:18:23 1.121
+++ mercury_to_mercury.m 1997/11/25 05:36:32
@@ -14,7 +14,7 @@
:- module mercury_to_mercury.
:- interface.
-:- import_module hlds_goal, hlds_data, hlds_pred, prog_data, (inst).
+:- import_module hlds_goal, hlds_data, hlds_pred, prog_data, (inst), purity.
:- import_module list, io, varset, term.
% convert_to_mercury(ProgName, OutputFileName, Items)
@@ -23,12 +23,14 @@
:- mode convert_to_mercury(in, in, in, di, uo) is det.
:- pred mercury_output_pred_type(varset, sym_name, list(type),
- maybe(determinism), term__context, io__state, io__state).
-:- mode mercury_output_pred_type(in, in, in, in, in, di, uo) is det.
+ maybe(determinism), purity, term__context,
+ io__state, io__state).
+:- mode mercury_output_pred_type(in, in, in, in, in, in, di, uo) is det.
:- pred mercury_output_func_type(varset, sym_name, list(type), type,
- maybe(determinism), term__context, io__state, io__state).
-:- mode mercury_output_func_type(in, in, in, in, in, in, di, uo) is det.
+ maybe(determinism), purity, term__context,
+ io__state, io__state).
+:- mode mercury_output_func_type(in, in, in, in, in, in, in, di, uo) is det.
:- pred mercury_output_pred_mode_decl(varset, sym_name, list(mode),
maybe(determinism), term__context, io__state, io__state).
@@ -227,16 +229,17 @@
maybe_output_line_number(Context),
mercury_output_mode_defn(VarSet, ModeDefn, Context).
-mercury_output_item(pred(VarSet, PredName, TypesAndModes, Det, _Cond), Context)
- -->
+mercury_output_item(pred(VarSet, PredName, TypesAndModes, Det, _Cond,
+ Purity), Context) -->
maybe_output_line_number(Context),
- mercury_output_pred_decl(VarSet, PredName, TypesAndModes, Det, Context).
+ mercury_output_pred_decl(VarSet, PredName, TypesAndModes, Det,
+ Purity, Context).
mercury_output_item(func(VarSet, PredName, TypesAndModes, RetTypeAndMode, Det,
- _Cond), Context) -->
+ _Cond, Purity), Context) -->
maybe_output_line_number(Context),
mercury_output_func_decl(VarSet, PredName, TypesAndModes,
- RetTypeAndMode, Det, Context).
+ RetTypeAndMode, Det, Purity, Context).
mercury_output_item(pred_mode(VarSet, PredName, Modes, MaybeDet, _Cond),
Context) -->
@@ -310,6 +313,10 @@
{ Pragma = fact_table(Pred, Arity, FileName) },
mercury_output_pragma_fact_table(Pred, Arity, FileName)
;
+ { Pragma = promise_pure(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity, predicate,
+ "promise_pure")
+ ;
{ Pragma = termination_info(PredOrFunc, PredName,
ModeList, Termination) },
termination__output_pragma_termination_info(PredOrFunc,
@@ -1061,12 +1068,15 @@
%-----------------------------------------------------------------------------%
:- pred mercury_output_pred_decl(varset, sym_name, list(type_and_mode),
- maybe(determinism), term__context, io__state, io__state).
-:- mode mercury_output_pred_decl(in, in, in, in, in, di, uo) is det.
+ maybe(determinism), purity, term__context,
+ io__state, io__state).
+:- mode mercury_output_pred_decl(in, in, in, in, in, in, di, uo) is det.
-mercury_output_pred_decl(VarSet, PredName, TypesAndModes, MaybeDet, Context) -->
+mercury_output_pred_decl(VarSet, PredName, TypesAndModes, MaybeDet, Purity,
+ Context) -->
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
- mercury_output_pred_type(VarSet, PredName, Types, MaybeDet, Context),
+ mercury_output_pred_type(VarSet, PredName, Types, MaybeDet, Purity,
+ Context),
(
{ MaybeModes = yes(Modes) },
{ Modes \= [] }
@@ -1077,8 +1087,11 @@
[]
).
-mercury_output_pred_type(VarSet, PredName, Types, MaybeDet, _Context) -->
- io__write_string(":- pred "),
+mercury_output_pred_type(VarSet, PredName, Types, MaybeDet, Purity,
+ _Context) -->
+ io__write_string(":- "),
+ write_purity_prefix(Purity),
+ io__write_string("pred "),
(
{ Types = [Type | Rest] }
->
@@ -1115,15 +1128,31 @@
),
io__write_string(".\n").
+
+% this works under the assumptions that all purity names but `pure' are prefix
+% operators, and that we never need `pure' indicators/declarations.
+
+:- pred write_purity_prefix(purity, io__state, io__state).
+:- mode write_purity_prefix(in, di, uo) is det.
+
+write_purity_prefix(Purity) -->
+ ( { Purity = pure } ->
+ []
+ ;
+ write_purity(Purity),
+ io__write_string(" ")
+ ).
+
+
%-----------------------------------------------------------------------------%
:- pred mercury_output_func_decl(varset, sym_name, list(type_and_mode),
- type_and_mode, maybe(determinism), term__context,
+ type_and_mode, maybe(determinism), purity, term__context,
io__state, io__state).
-:- mode mercury_output_func_decl(in, in, in, in, in, in, di, uo) is det.
+:- mode mercury_output_func_decl(in, in, in, in, in, in, in, di, uo) is det.
mercury_output_func_decl(VarSet, FuncName, TypesAndModes, RetTypeAndMode,
- MaybeDet, Context) -->
+ MaybeDet, Purity, Context) -->
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
{ split_type_and_mode(RetTypeAndMode, RetType, MaybeRetMode) },
(
@@ -1131,17 +1160,19 @@
{ MaybeRetMode = yes(RetMode) }
->
mercury_output_func_type(VarSet, FuncName, Types, RetType,
- no, Context),
+ no, Purity, Context),
mercury_output_func_mode_decl(VarSet, FuncName, Modes, RetMode,
MaybeDet, Context)
;
mercury_output_func_type(VarSet, FuncName, Types, RetType,
- MaybeDet, Context)
+ MaybeDet, Purity, Context)
).
-mercury_output_func_type(VarSet, FuncName, Types, RetType, MaybeDet, _Context)
- -->
- io__write_string(":- func "),
+mercury_output_func_type(VarSet, FuncName, Types, RetType, MaybeDet, Purity,
+ _Context) -->
+ io__write_string(":- "),
+ write_purity_prefix(Purity),
+ io__write_string("func "),
(
{ Types = [Type | Rest] }
->
@@ -1464,7 +1495,8 @@
mercury_output_newline(Indent),
io__write_string(")").
-mercury_output_goal_2(call(Name, Term), VarSet, Indent) -->
+mercury_output_goal_2(call(Name, Term, Purity), VarSet, Indent) -->
+ write_purity_prefix(Purity),
mercury_output_call(Name, Term, VarSet, Indent).
mercury_output_goal_2(unify(A, B), VarSet, _Indent) -->
@@ -1472,6 +1504,7 @@
io__write_string(" = "),
mercury_output_term(B, VarSet, no).
+
:- pred mercury_output_call(sym_name, list(term), varset, int,
io__state, io__state).
:- mode mercury_output_call(in, in, in, in, di, uo) is det.
@@ -1966,6 +1999,7 @@
mercury_unary_prefix_op("func").
mercury_unary_prefix_op("if").
mercury_unary_prefix_op("import_module").
+mercury_unary_prefix_op("impure").
mercury_unary_prefix_op("insert").
mercury_unary_prefix_op("inst").
mercury_unary_prefix_op("lib").
@@ -1980,6 +2014,7 @@
mercury_unary_prefix_op("pred").
mercury_unary_prefix_op("pure").
mercury_unary_prefix_op("rule"). /* NU-Prolog */
+mercury_unary_prefix_op("semipure").
mercury_unary_prefix_op("sorted").
mercury_unary_prefix_op("spy").
mercury_unary_prefix_op("type").
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mode_errors.m,v
retrieving revision 1.50
diff -u -r1.50 mode_errors.m
--- mode_errors.m 1997/11/24 23:10:22 1.50
+++ mode_errors.m 1997/11/25 00:58:59
@@ -77,9 +77,10 @@
; mode_error_unify_var_lambda(var, inst, inst)
% some sort of error in
% attempt to unify a variable with lambda expression
- ; mode_error_conj(list(delayed_goal))
+ ; mode_error_conj(list(delayed_goal), schedule_culprit)
% a conjunction contains one or more unscheduleable
- % goals
+ % goals; schedule_culprit gives the reason why
+ % they couldn't be scheduled.
; mode_error_final_inst(int, var, inst, inst, final_inst_error)
% one of the head variables did not have the
% expected final inst on exit from the proc
@@ -87,6 +88,12 @@
% This is a dummy error - the actual message
% is output by module_qual.m.
+:- type schedule_culprit
+ ---> goal_itself_was_impure
+ ; goals_followed_by_impure_goal(hlds_goal)
+ ; conj_floundered. % we've reached the end of a conjunction
+ % and there were still delayed goals
+
:- type final_inst_error
---> too_instantiated
; not_instantiated_enough
@@ -193,8 +200,8 @@
ArgInsts), ModeInfo) -->
report_mode_error_unify_var_functor(ModeInfo, Var, Name, Args, Inst,
ArgInsts).
-report_mode_error(mode_error_conj(Errors), ModeInfo) -->
- report_mode_error_conj(ModeInfo, Errors).
+report_mode_error(mode_error_conj(Errors, Culprit), ModeInfo) -->
+ report_mode_error_conj(ModeInfo, Errors, Culprit).
report_mode_error(mode_error_no_matching_mode(Vars, Insts), ModeInfo) -->
report_mode_error_no_matching_mode(ModeInfo, Vars, Insts).
report_mode_error(mode_error_final_inst(ArgNum, Var, VarInst, Inst, Reason),
@@ -205,16 +212,19 @@
%-----------------------------------------------------------------------------%
-:- pred report_mode_error_conj(mode_info, list(delayed_goal),
+:- pred report_mode_error_conj(mode_info, list(delayed_goal), schedule_culprit,
io__state, io__state).
-:- mode report_mode_error_conj(mode_info_no_io, in, di, uo) is det.
+:- mode report_mode_error_conj(mode_info_no_io, in, in, di, uo) is det.
-report_mode_error_conj(ModeInfo, Errors) -->
+report_mode_error_conj(ModeInfo, Errors, Culprit) -->
{ mode_info_get_context(ModeInfo, Context) },
{ mode_info_get_varset(ModeInfo, VarSet) },
{ find_important_errors(Errors, ImportantErrors, OtherErrors) },
+
+ % if there's more than one error, and we have verbose-errors
+ % enabled, report them all
globals__io_lookup_bool_option(verbose_errors, VerboseErrors),
- ( { VerboseErrors = yes } ->
+ ( { VerboseErrors = yes, Errors = [_, _ | _] } ->
mode_info_write_context(ModeInfo),
prog_out__write_context(Context),
io__write_string(" mode error in conjunction. The next "),
@@ -240,6 +250,28 @@
;
% There wasn't any error to report! This can't happen.
{ error("report_mode_error_conj") }
+ ),
+
+ % if the goal(s) couldn't be scheduled because we couldn't
+ % reorder things past an impure goal, then report that.
+ ( { Culprit = conj_floundered },
+ { true } % we've already reported everything we can
+ ; { Culprit = goal_itself_was_impure },
+ prog_out__write_context(Context),
+ io__write_string(
+ " The goal could not be reordered, because it was impure.\n")
+ ; { Culprit = goals_followed_by_impure_goal(ImpureGoal) },
+ prog_out__write_context(Context),
+ io__write_string(
+ " The goal could not be reordered, because\n"),
+ prog_out__write_context(Context),
+ io__write_string(
+ " it was followed by an impure goal.\n"),
+ { ImpureGoal = _ - ImpureGoalInfo },
+ { goal_info_get_context(ImpureGoalInfo, ImpureGoalContext) },
+ prog_out__write_context(ImpureGoalContext),
+ io__write_string(
+ " This is the location of the impure goal.\n")
).
:- pred find_important_errors(list(delayed_goal), list(delayed_goal),
Index: compiler/modes.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modes.m,v
retrieving revision 1.209
diff -u -r1.209 modes.m
--- modes.m 1997/11/24 23:10:25 1.209
+++ modes.m 1997/11/25 00:59:01
@@ -292,7 +292,7 @@
:- import_module type_util, mode_util, code_util, prog_data, unify_proc.
:- import_module globals, options, mercury_to_mercury, hlds_out, int, set.
:- import_module passes_aux, typecheck, module_qual, clause_to_proc.
-:- import_module modecheck_unify, modecheck_call, inst_util.
+:- import_module modecheck_unify, modecheck_call, inst_util, purity.
:- import_module list, map, varset, term, prog_out, string, require, std_util.
:- import_module assoc_list.
@@ -902,11 +902,12 @@
mode_checkpoint(exit, "some").
modecheck_goal_expr(call(PredId0, _, Args0, _, Context, PredName0),
- GoalInfo0, Goal) -->
- % do the last step of type-checking
+ GoalInfo0, Goal) -->
+ % Resolve overloading. This is only necessary when invoked to
+ % modecheck a lambda goal; other overloading is handled in purity.m
=(ModeInfo0),
- { resolve_pred_overloading(PredId0, Args0, PredName0, PredName,
- ModeInfo0, PredId) },
+ { resolve_pred_overloading(PredId0, Args0, PredName0, PredName,
+ ModeInfo0, PredId) },
mode_checkpoint(enter, "call"),
mode_info_set_call_context(call(PredId)),
@@ -1068,7 +1069,7 @@
mode_info_set_delay_info(DelayInfo1),
mode_info_add_goals_live_vars(Goals0),
- modecheck_conj_list_2(Goals0, Goals),
+ modecheck_conj_list_2(Goals0, [], Goals, ImpurityErrors),
=(ModeInfo3),
{ mode_info_get_errors(ModeInfo3, NewErrors) },
@@ -1079,13 +1080,21 @@
{ delay_info__leave_conj(DelayInfo4, DelayedGoals, DelayInfo5) },
mode_info_set_delay_info(DelayInfo5),
+ % we only report impurity errors if there were no other errors
( { DelayedGoals = [] } ->
- []
+ % XXX perhaps we should report all the impurity errors,
+ % rather than just the first one
+ ( { ImpurityErrors = [FirstImpurityError | _Rest] } ->
+ mode_info_add_error(FirstImpurityError)
+ ;
+ []
+ )
; { DelayedGoals = [delayed_goal(_DVars, Error, _DGoal)] } ->
mode_info_add_error(Error)
;
{ get_all_waiting_vars(DelayedGoals, Vars) },
- mode_info_error(Vars, mode_error_conj(DelayedGoals))
+ mode_info_error(Vars,
+ mode_error_conj(DelayedGoals, conj_floundered))
).
mode_info_add_goals_live_vars([]) --> [].
@@ -1100,9 +1109,13 @@
mode_info_remove_live_vars(Vars),
mode_info_remove_goals_live_vars(Goals).
-:- pred modecheck_conj_list_2(list(hlds_goal), list(hlds_goal),
- mode_info, mode_info).
-:- mode modecheck_conj_list_2(in, out, mode_info_di, mode_info_uo) is det.
+:- type impurity_errors == list(mode_error_info).
+
+:- pred modecheck_conj_list_2(list(hlds_goal), impurity_errors,
+ list(hlds_goal), impurity_errors,
+ mode_info, mode_info).
+:- mode modecheck_conj_list_2(in, in, out, out, mode_info_di, mode_info_uo)
+ is det.
% Schedule a conjunction.
% If it's empty, then there is nothing to do.
@@ -1111,8 +1124,19 @@
% pending goal (if any), and if not, we delay the goal. Then we
% continue attempting to schedule all the rest of the goals.
-modecheck_conj_list_2([], []) --> [].
-modecheck_conj_list_2([Goal0 | Goals0], Goals) -->
+modecheck_conj_list_2([], ImpurityErrors, [], ImpurityErrors) --> [].
+modecheck_conj_list_2([Goal0 | Goals0], ImpurityErrors0,
+ Goals, ImpurityErrors) -->
+
+ { Goal0 = _GoalExpr - GoalInfo0 },
+ ( { goal_info_is_impure(GoalInfo0) } ->
+ { Impure = yes },
+ check_for_impurity_error(Goal0, ImpurityErrors0,
+ ImpurityErrors1)
+ ;
+ { Impure = no },
+ { ImpurityErrors1 = ImpurityErrors0 }
+ ),
% Hang onto the original instmap & delay_info
mode_info_dcg_get_instmap(InstMap0),
@@ -1131,14 +1155,31 @@
% and delay the goal.
=(ModeInfo1),
{ mode_info_get_errors(ModeInfo1, Errors) },
- ( { Errors = [ FirstError | _] } ->
+ ( { Errors = [ FirstErrorInfo | _] } ->
mode_info_set_errors([]),
mode_info_set_instmap(InstMap0),
mode_info_add_live_vars(NonLocalVars),
- { delay_info__delay_goal(DelayInfo0, FirstError, Goal0,
- DelayInfo1) }
- ;
- { mode_info_get_delay_info(ModeInfo1, DelayInfo1) }
+ { delay_info__delay_goal(DelayInfo0, FirstErrorInfo,
+ Goal0, DelayInfo1) },
+ % delaying an impure goal is an impurity error
+ ( { Impure = yes } ->
+ { FirstErrorInfo = mode_error_info(Vars, _, _, _) },
+ { ImpureError = mode_error_conj(
+ [delayed_goal(Vars, FirstErrorInfo, Goal0)],
+ goal_itself_was_impure) },
+ =(ModeInfo2),
+ { mode_info_get_context(ModeInfo2, Context) },
+ { mode_info_get_mode_context(ModeInfo2, ModeContext) },
+ { ImpureErrorInfo = mode_error_info( Vars, ImpureError,
+ Context, ModeContext) },
+ { ImpurityErrors2 = [ImpureErrorInfo |
+ ImpurityErrors1] }
+ ;
+ { ImpurityErrors2 = ImpurityErrors1 }
+ )
+ ;
+ { mode_info_get_delay_info(ModeInfo1, DelayInfo1) },
+ { ImpurityErrors2 = ImpurityErrors1 }
),
% Next, we attempt to wake up any pending goals,
@@ -1156,16 +1197,68 @@
mode_info_dcg_get_instmap(InstMap),
( { instmap__is_unreachable(InstMap) } ->
mode_info_remove_goals_live_vars(Goals1),
- { Goals2 = [] }
+ { Goals2 = [] },
+ { ImpurityErrors = ImpurityErrors2 }
;
- modecheck_conj_list_2(Goals1, Goals2)
+ modecheck_conj_list_2(Goals1, ImpurityErrors2,
+ Goals2, ImpurityErrors)
),
+
( { Errors = [] } ->
+ % we successfully scheduled this goal, so insert
+ % it in the list of successfully scheduled goals
{ Goals = [Goal | Goals2] }
;
+ % we delayed this goal -- it will be stored in the delay_info
{ Goals = Goals2 }
).
+% check whether there are any delayed goals (other than headvar unifications)
+% at the point where we are about to schedule an impure goal. If so, that is
+% an error.
+:- pred check_for_impurity_error(hlds_goal, impurity_errors, impurity_errors,
+ mode_info, mode_info).
+:- mode check_for_impurity_error(in, in, out, mode_info_di, mode_info_uo)
+ is det.
+check_for_impurity_error(Goal, ImpurityErrors0, ImpurityErrors) -->
+ =(ModeInfo0),
+ { mode_info_get_delay_info(ModeInfo0, DelayInfo0) },
+ { delay_info__leave_conj(DelayInfo0, DelayedGoals,
+ DelayInfo1) },
+ { delay_info__enter_conj(DelayInfo1, DelayInfo) },
+ { mode_info_get_module_info(ModeInfo0, ModuleInfo) },
+ { mode_info_get_predid(ModeInfo0, PredId) },
+ { module_info_pred_info(ModuleInfo, PredId, PredInfo) },
+ { pred_info_clauses_info(PredInfo, ClausesInfo) },
+ { ClausesInfo = clauses_info(_,_,_,HeadVars,_) },
+ ( { no_non_headvar_unification_goals(DelayedGoals, HeadVars) } ->
+ { ImpurityErrors = ImpurityErrors0 }
+ ;
+ mode_info_set_delay_info(DelayInfo),
+ { get_all_waiting_vars(DelayedGoals, Vars) },
+ { ModeError = mode_error_conj(DelayedGoals,
+ goals_followed_by_impure_goal(Goal)) },
+ =(ModeInfo1),
+ { mode_info_get_context(ModeInfo1, Context) },
+ { mode_info_get_mode_context(ModeInfo1, ModeContext) },
+ { ImpurityError = mode_error_info(Vars, ModeError,
+ Context, ModeContext) },
+ { ImpurityErrors = [ImpurityError | ImpurityErrors0] }
+ ).
+
+
+:- pred no_non_headvar_unification_goals(list(delayed_goal), list(var)).
+:- mode no_non_headvar_unification_goals(in, in) is semidet.
+
+no_non_headvar_unification_goals([], _).
+no_non_headvar_unification_goals([delayed_goal(_,_,Goal-_)|Goals], HeadVars) :-
+ Goal = unify(Var,Rhs,_,_,_),
+ ( member(Var, HeadVars)
+ ; Rhs = var(OtherVar),
+ member(OtherVar, HeadVars)
+ ),
+ no_non_headvar_unification_goals(Goals, HeadVars).
+
:- pred dcg_set_state(T, T, T).
:- mode dcg_set_state(in, in, out) is det.
@@ -1325,7 +1418,7 @@
modecheck_set_var_inst(Var0, InitialInst, FinalInst,
Var, ExtraGoals0, ExtraGoals1),
modecheck_set_var_inst_list_2(Vars0, InitialInsts, FinalInsts,
- ExtraGoals1, Vars, ExtraGoals).
+ ExtraGoals1, Vars, ExtraGoals).
:- pred modecheck_set_var_inst(var, inst, inst, var, extra_goals, extra_goals,
mode_info, mode_info).
@@ -1554,34 +1647,6 @@
error("mode_context_to_unify_context: uninitialized context").
%-----------------------------------------------------------------------------%
-
-:- pred resolve_pred_overloading(pred_id, list(var), sym_name, sym_name,
- mode_info, pred_id).
-:- mode resolve_pred_overloading(in, in, in, out, mode_info_ui, out) is det.
- %
- % In the case of a call to an overloaded predicate, typecheck.m
- % does not figure out the correct pred_id. We must do that here.
- %
-resolve_pred_overloading(PredId0, Args0, PredName0, PredName,
- ModeInfo0, PredId) :-
- ( invalid_pred_id(PredId0) ->
- %
- % Find the set of candidate pred_ids for predicates which
- % have the specified name and arity
- %
- mode_info_get_module_info(ModeInfo0, ModuleInfo0),
- mode_info_get_predid(ModeInfo0, ThisPredId),
- module_info_pred_info(ModuleInfo0, ThisPredId, PredInfo),
- pred_info_typevarset(PredInfo, TVarSet),
- mode_info_get_var_types(ModeInfo0, VarTypes0),
- typecheck__resolve_pred_overloading(ModuleInfo0, Args0,
- VarTypes0, TVarSet, PredName0, PredName, PredId)
- ;
- PredId = PredId0,
- PredName = PredName0
- ).
-
-%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% Given a list of variables, and a list of livenesses,
@@ -1612,5 +1677,33 @@
check_circular_modes(Module0, Module) -->
{ Module = Module0 }.
+
+%-----------------------------------------------------------------------------%
+
+:- pred resolve_pred_overloading(pred_id, list(var), sym_name, sym_name,
+ mode_info, pred_id).
+:- mode resolve_pred_overloading(in, in, in, out, mode_info_ui, out) is det.
+ %
+ % In the case of a call to an overloaded predicate, typecheck.m
+ % does not figure out the correct pred_id. We must do that here.
+ %
+resolve_pred_overloading(PredId0, Args0, PredName0, PredName,
+ ModeInfo0, PredId) :-
+ ( invalid_pred_id(PredId0) ->
+ %
+ % Find the set of candidate pred_ids for predicates which
+ % have the specified name and arity
+ %
+ mode_info_get_module_info(ModeInfo0, ModuleInfo0),
+ mode_info_get_predid(ModeInfo0, ThisPredId),
+ module_info_pred_info(ModuleInfo0, ThisPredId, PredInfo),
+ pred_info_typevarset(PredInfo, TVarSet),
+ mode_info_get_var_types(ModeInfo0, VarTypes0),
+ typecheck__resolve_pred_overloading(ModuleInfo0, Args0,
+ VarTypes0, TVarSet, PredName0, PredName, PredId)
+ ;
+ PredId = PredId0,
+ PredName = PredName0
+ ).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.24
diff -u -r1.24 module_qual.m
--- module_qual.m 1997/10/09 09:38:57 1.24
+++ module_qual.m 1997/11/14 01:00:10
@@ -131,8 +131,8 @@
add_mode_defn(ModeDefn, Info0, Info).
collect_mq_info_2(module_defn(_, ModuleDefn), Info0, Info) :-
process_module_defn(ModuleDefn, Info0, Info).
-collect_mq_info_2(pred(_,_,_,_,_), Info, Info).
-collect_mq_info_2(func(_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(pred(_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(func(_,_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pred_mode(_,_,_,_,_), Info, Info).
collect_mq_info_2(func_mode(_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pragma(_), Info, Info).
@@ -258,16 +258,17 @@
module_defn(A, ModuleDefn) - Context, Info0, Info, Continue) -->
{ update_import_status(ModuleDefn, Info0, Info, Continue) }.
-module_qualify_item(pred(A, SymName, TypesAndModes0, D, E) - Context,
- pred(A, SymName, TypesAndModes, D, E) - Context,
+module_qualify_item(pred(A, SymName, TypesAndModes0, D, E, F) - Context,
+ pred(A, SymName, TypesAndModes, D, E, F) - Context,
Info0, Info, yes) -->
{ list__length(TypesAndModes0, Arity) },
{ mq_info_set_error_context(Info0, pred(SymName - Arity) - Context,
Info1) },
qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info).
-module_qualify_item(func(A,SymName, TypesAndModes0, TypeAndMode0,D,E) - Context,
- func(A, SymName, TypesAndModes, TypeAndMode, D, E) - Context,
+module_qualify_item(
+ func(A,SymName,TypesAndModes0,TypeAndMode0,D,E,F) - Context,
+ func(A,SymName,TypesAndModes,TypeAndMode,D,E,F) - Context,
Info0, Info, yes) -->
{ list__length(TypesAndModes0, Arity) },
{ mq_info_set_error_context(Info0, func(SymName - Arity) - Context,
@@ -608,6 +609,8 @@
Info, Info) --> [].
qualify_pragma(fact_table(SymName, Arity, FileName),
fact_table(SymName, Arity, FileName), Info, Info) --> [].
+qualify_pragma(promise_pure(SymName, Arity), promise_pure(SymName, Arity),
+ Info, Info) --> [].
qualify_pragma(termination_info(PredOrFunc, SymName, ModeList0, Termination),
termination_info(PredOrFunc, SymName, ModeList, Termination),
Info0, Info) -->
Index: compiler/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.26
diff -u -r1.26 prog_data.m
--- prog_data.m 1997/10/09 09:39:05 1.26
+++ prog_data.m 1997/11/18 01:07:02
@@ -18,7 +18,7 @@
:- interface.
-:- import_module hlds_data, hlds_pred, (inst).
+:- import_module hlds_data, hlds_pred, (inst), purity.
:- import_module term_util, list, map, varset, term, std_util.
%-----------------------------------------------------------------------------%
@@ -52,11 +52,11 @@
; module_defn(varset, module_defn)
; pred(varset, sym_name, list(type_and_mode),
- maybe(determinism), condition)
+ maybe(determinism), condition, purity)
% VarNames, PredName, ArgTypes, Deterministicness, Cond
; func(varset, sym_name, list(type_and_mode), type_and_mode,
- maybe(determinism), condition)
+ maybe(determinism), condition, purity)
% VarNames, PredName, ArgTypes, ReturnType,
% Deterministicness, Cond
@@ -130,6 +130,9 @@
; fact_table(sym_name, arity, string)
% Predname, Arity, Fact file name.
+ ; promise_pure(sym_name, arity)
+ % Predname, Arity
+
; termination_info(pred_or_func, sym_name, list(mode),
termination)
% the list(mode) is the declared argmodes of the
@@ -190,7 +193,7 @@
; equivalent(goal,goal)
; if_then(vars,goal,goal)
; if_then_else(vars,goal,goal,goal)
- ; call(sym_name, list(term))
+ ; call(sym_name, list(term), purity)
; unify(term, term).
:- type goals == list(goal).
Index: compiler/prog_io.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io.m,v
retrieving revision 1.165
diff -u -r1.165 prog_io.m
--- prog_io.m 1997/11/02 12:29:13 1.165
+++ prog_io.m 1997/11/28 05:23:17
@@ -100,6 +100,7 @@
:- import_module prog_io_goal, prog_io_dcg, prog_io_pragma, prog_io_util.
:- import_module hlds_data, hlds_pred, prog_util, globals, options, (inst).
+:- import_module purity.
:- import_module bool, int, string, std_util, parser, term_io, dir, require.
:- import_module varset, term.
@@ -514,11 +515,12 @@
process_decl(ModuleName, VarSet, "type", [TypeDecl], Result) :-
parse_type_decl(ModuleName, VarSet, TypeDecl, Result).
+ % If this clause is changed, also modify clause below for "impure."
process_decl(ModuleName, VarSet, "pred", [PredDecl], Result) :-
- parse_type_decl_pred(ModuleName, VarSet, PredDecl, Result).
+ parse_type_decl_pred(ModuleName, VarSet, PredDecl, pure, Result).
process_decl(ModuleName, VarSet, "func", [FuncDecl], Result) :-
- parse_type_decl_func(ModuleName, VarSet, FuncDecl, Result).
+ parse_type_decl_func(ModuleName, VarSet, FuncDecl, pure, Result).
process_decl(ModuleName, VarSet, "mode", [ModeDecl], Result) :-
parse_mode_decl(ModuleName, VarSet, ModeDecl, Result).
@@ -661,6 +663,38 @@
process_decl(ModuleName, VarSet, "pragma", Pragma, Result):-
parse_pragma(ModuleName, VarSet, Pragma, Result).
+ % XXX I'm not very happy with this. I believe this should
+ % recursively call process_decl in order to process the pred or func
+ % declaration. The information that the pred/func decl is preceeded
+ % by "impure" should be carried by another argument, which can be
+ % generalised to a list of declared properties or attributes. Then
+ % each predicate for handling a declaration would have to handle
+ % the list of properties, and complain about any invalid properties.
+ % This is a more general solution, and avoids the code duplication of
+ % the calls to parse_type_decl_{pred,func}.
+
+process_decl(ModuleName, VarSet, "impure", [Decl], Result):-
+ process_purity_decl(ModuleName, VarSet, (impure), Decl, Result).
+process_decl(ModuleName, VarSet, "semipure", [Decl], Result):-
+ process_purity_decl(ModuleName, VarSet, (semipure), Decl, Result).
+
+
+:- pred process_purity_decl(string, varset, purity, term, maybe1(item)).
+:- mode process_purity_decl(in, in, in, in, out) is det.
+
+process_purity_decl(ModuleName, VarSet, Purity, Decl, Result) :-
+ ( Decl = term__functor(term__atom("pred"), [PredDecl], _Context)
+ ->
+ parse_type_decl_pred(ModuleName, VarSet,
+ PredDecl, Purity, Result)
+% ; Decl = term__functor(term__atom("func"), [FuncDecl], _Context)
+% ->
+% parse_type_decl_func(ModuleName, VarSet,
+% FuncDecl, Purity, Result)
+ ;
+ Result = error("invalid impurity declaration", Decl)
+ ).
+
:- pred parse_type_decl(string, varset, term, maybe1(item)).
:- mode parse_type_decl(in, in, in, out) is det.
parse_type_decl(ModuleName, VarSet, TypeDecl, Result) :-
@@ -729,43 +763,42 @@
%-----------------------------------------------------------------------------%
- % parse_type_decl_pred(Pred, Condition, Result) succeeds
- % if Pred is a predicate type declaration, and binds Condition
- % to the condition for that declaration (if any), and Result to
- % a representation of the declaration.
-:- pred parse_type_decl_pred(string, varset, term, maybe1(item)).
-:- mode parse_type_decl_pred(in, in, in, out) is det.
+ % parse_type_decl_pred(ModuleName, VarSet, Pred, Purity, Result)
+ % succeeds if Pred is a predicate type declaration, and binds Result
+ % to a representation of the declaration.
+:- pred parse_type_decl_pred(string, varset, term, purity, maybe1(item)).
+:- mode parse_type_decl_pred(in, in, in, in, out) is det.
-parse_type_decl_pred(ModuleName, VarSet, Pred, R) :-
+parse_type_decl_pred(ModuleName, VarSet, Pred, Purity, R) :-
get_condition(Pred, Body, Condition),
get_determinism(Body, Body2, MaybeDeterminism),
process_type_decl_pred(ModuleName, MaybeDeterminism, VarSet, Body2,
- Condition, R).
+ Condition, Purity, R).
:- pred process_type_decl_pred(string, maybe1(maybe(determinism)), varset,
- term, condition, maybe1(item)).
-:- mode process_type_decl_pred(in, in, in, in, in, out) is det.
+ term, condition, purity, maybe1(item)).
+:- mode process_type_decl_pred(in, in, in, in, in, in, out) is det.
-process_type_decl_pred(_MNm, error(Term, Reason), _, _, _,
+process_type_decl_pred(_MNm, error(Term, Reason), _, _, _, _,
error(Term, Reason)).
process_type_decl_pred(ModuleName, ok(MaybeDeterminism), VarSet, Body,
- Condition, R) :-
- process_pred(ModuleName, VarSet, Body, Condition, MaybeDeterminism, R).
+ Condition, Purity, R) :-
+ process_pred(ModuleName, VarSet, Body, Condition, MaybeDeterminism,
+ Purity, R).
%-----------------------------------------------------------------------------%
- % parse_type_decl_func(Func, Condition, Result) succeeds
- % if Func is a function type declaration, and binds Condition
- % to the condition for that declaration (if any), and Result to
+ % parse_type_decl_func(ModuleName, Varset, Func, Purity, Result)
+ % succeeds if Func is a function type declaration, and binds Result to
% a representation of the declaration.
-:- pred parse_type_decl_func(string, varset, term, maybe1(item)).
-:- mode parse_type_decl_func(in, in, in, out) is det.
+:- pred parse_type_decl_func(string, varset, term, purity, maybe1(item)).
+:- mode parse_type_decl_func(in, in, in, in, out) is det.
-parse_type_decl_func(ModuleName, VarSet, Func, R) :-
+parse_type_decl_func(ModuleName, VarSet, Func, Purity, R) :-
get_condition(Func, Body, Condition),
get_determinism(Body, Body2, MaybeDeterminism),
- process_maybe1_to_t(process_func(ModuleName, VarSet, Body2, Condition),
- MaybeDeterminism, R).
+ process_maybe1_to_t(process_func(ModuleName, VarSet, Body2, Condition,
+ Purity), MaybeDeterminism, R).
%-----------------------------------------------------------------------------%
@@ -1079,25 +1112,26 @@
% parse a `:- pred p(...)' declaration
:- pred process_pred(string, varset, term, condition, maybe(determinism),
- maybe1(item)).
-:- mode process_pred(in, in, in, in, in, out) is det.
+ purity, maybe1(item)).
+:- mode process_pred(in, in, in, in, in, in, out) is det.
-process_pred(ModuleName, VarSet, PredType, Cond, MaybeDet, Result) :-
+process_pred(ModuleName, VarSet, PredType, Cond, MaybeDet, Purity, Result) :-
parse_qualified_term(ModuleName, PredType, PredType,
"`:- pred' declaration", R),
- process_pred_2(R, PredType, VarSet, MaybeDet, Cond, Result).
+ process_pred_2(R, PredType, VarSet, MaybeDet, Cond, Purity, Result).
:- pred process_pred_2(maybe_functor, term, varset, maybe(determinism),
- condition, maybe1(item)).
-:- mode process_pred_2(in, in, in, in, in, out) is det.
-process_pred_2(ok(F, As0), PredType, VarSet, MaybeDet, Cond, Result) :-
+ condition, purity, maybe1(item)).
+:- mode process_pred_2(in, in, in, in, in, in, out) is det.
+process_pred_2(ok(F, As0), PredType, VarSet, MaybeDet, Cond, Purity, Result) :-
(
convert_type_and_mode_list(As0, As)
->
(
verify_type_and_mode_list(As)
->
- Result = ok(pred(VarSet, F, As, MaybeDet, Cond))
+ Result = ok(pred(VarSet, F, As, MaybeDet, Cond,
+ Purity))
;
Result = error("some but not all arguments have modes", PredType)
)
@@ -1105,7 +1139,7 @@
Result = error("syntax error in `:- pred' declaration",
PredType)
).
-process_pred_2(error(M, T), _, _, _, _, error(M, T)).
+process_pred_2(error(M, T), _, _, _, _, _, error(M, T)).
%-----------------------------------------------------------------------------%
@@ -1137,11 +1171,11 @@
% parse a `:- func p(...)' declaration
-:- pred process_func(string, varset, term, condition, maybe(determinism),
- maybe1(item)).
-:- mode process_func(in, in, in, in, in, out) is det.
+:- pred process_func(string, varset, term, condition, purity,
+ maybe(determinism), maybe1(item)).
+:- mode process_func(in, in, in, in, in, in, out) is det.
-process_func(ModuleName, VarSet, Term, Cond, MaybeDet, Result) :-
+process_func(ModuleName, VarSet, Term, Cond, Purity, MaybeDet, Result) :-
(
Term = term__functor(term__atom("="),
[FuncTerm, ReturnTypeTerm], _Context)
@@ -1149,16 +1183,16 @@
parse_qualified_term(ModuleName, FuncTerm, Term,
"`:- func' declaration", R),
process_func_2(R, FuncTerm, ReturnTypeTerm, VarSet, MaybeDet,
- Cond, Result)
+ Cond, Purity, Result)
;
Result = error("`=' expected in `:- func' declaration", Term)
).
:- pred process_func_2(maybe_functor, term, term, varset, maybe(determinism),
- condition, maybe1(item)).
-:- mode process_func_2(in, in, in, in, in, in, out) is det.
+ condition, purity, maybe1(item)).
+:- mode process_func_2(in, in, in, in, in, in, in, out) is det.
process_func_2(ok(F, As0), FuncTerm, ReturnTypeTerm, VarSet, MaybeDet, Cond,
- Result) :-
+ Purity, Result) :-
( convert_type_and_mode_list(As0, As) ->
( \+ verify_type_and_mode_list(As) ->
Result = error("some but not all arguments have modes",
@@ -1187,7 +1221,7 @@
FuncTerm)
;
Result = ok(func(VarSet, F, As, ReturnType,
- MaybeDet, Cond))
+ MaybeDet, Cond, Purity))
)
;
Result = error(
@@ -1199,7 +1233,7 @@
"syntax error in arguments of `:- func' declaration",
FuncTerm)
).
-process_func_2(error(M, T), _, _, _, _, _, error(M, T)).
+process_func_2(error(M, T), _, _, _, _, _, _, error(M, T)).
%-----------------------------------------------------------------------------%
Index: compiler/prog_io_dcg.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_dcg.m,v
retrieving revision 1.7
diff -u -r1.7 prog_io_dcg.m
--- prog_io_dcg.m 1997/11/02 12:29:20 1.7
+++ prog_io_dcg.m 1997/11/20 00:07:44
@@ -32,7 +32,7 @@
:- implementation.
-:- import_module prog_io_goal, prog_util, prog_data.
+:- import_module prog_io_goal, prog_util, prog_data, purity.
:- import_module int, string, std_util, varset, list.
%-----------------------------------------------------------------------------%
@@ -107,7 +107,7 @@
list__append(Args0,
[term__variable(Var0), term__variable(Var)],
Args),
- Goal = call(SymName, Args) - Context
+ Goal = call(SymName, Args, pure) - Context
)
;
% A call to a free variable, or to a number or string.
@@ -115,7 +115,7 @@
% will catch calls to numbers and strings.
new_dcg_var(VarSet0, N0, VarSet, N, Var),
Goal = call(unqualified("call"), [Term, term__variable(Var0),
- term__variable(Var)]) - Context
+ term__variable(Var)], pure) - Context
).
% parse_dcg_goal_2(Functor, Args, Context, VarSet0, N0, Var0,
@@ -137,6 +137,13 @@
parse_dcg_goal_2("{}", [G], _, VarSet0, N, Var,
Goal, VarSet, N, Var) :-
parse_goal(G, VarSet0, Goal, VarSet).
+parse_dcg_goal_2("impure", [G], _, VarSet0, N0, Var0, Goal, VarSet, N, Var) :-
+ parse_dcg_goal_with_purity(G, VarSet0, N0, Var0, (impure), Goal,
+ VarSet, N, Var).
+parse_dcg_goal_2("semipure", [G], _, VarSet0, N0, Var0, Goal, VarSet, N,
+ Var) :-
+ parse_dcg_goal_with_purity(G, VarSet0, N0, Var0, (semipure), Goal,
+ VarSet, N, Var).
% Empty list - just unify the input and output DCG args.
parse_dcg_goal_2("[]", [], Context, VarSet0, N0, Var0,
@@ -265,6 +272,23 @@
VarSet0, N0, Var0, some(Vars, A) - Context, VarSet, N, Var) :-
term__vars(Vars0, Vars),
parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet, N, Var).
+
+:- pred parse_dcg_goal_with_purity(term, varset, int, var, purity, goal,
+ varset, int, var).
+:- mode parse_dcg_goal_with_purity(in, in, in, in, in, out, out, out, out)
+ is det.
+
+parse_dcg_goal_with_purity(G, VarSet0, N0, Var0, Purity, Goal, VarSet, N,
+ Var) :-
+ parse_dcg_goal(G, VarSet0, N0, Var0, Goal1, VarSet, N, Var),
+ ( Goal1 = call(Pred, Args, pure) - Context ->
+ Goal = call(Pred, Args, Purity) - Context
+ ;
+ % XXX Should print a warning: user put an `impure' or
+ % `semipure' marker on a non-atomic goal, or else they put
+ % multiple markers on a goal.
+ Goal = Goal1
+ ).
:- pred append_to_disjunct(goal, goal_expr, term__context, goal).
:- mode append_to_disjunct(in, in, in, out) is det.
Index: compiler/prog_io_goal.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.7
diff -u -r1.7 prog_io_goal.m
--- prog_io_goal.m 1997/11/02 12:29:22 1.7
+++ prog_io_goal.m 1997/11/20 04:02:30
@@ -113,7 +113,7 @@
:- implementation.
-:- import_module hlds_data.
+:- import_module hlds_data, purity.
:- import_module int, string, std_util.
% Parse a goal.
@@ -146,12 +146,13 @@
sym_name_and_args(Term, SymName, Args)
->
VarSet = VarSet0,
- Goal = call(SymName, Args) - Context
+ Goal = call(SymName, Args, pure) - Context
;
% A call to a free variable, or to a number or string.
% Just translate it into a call to call/1 - the typechecker
% will catch calls to numbers and strings.
- Goal = call(unqualified("call"), [Term]) - Context,
+ Goal = call(unqualified("call"), [Term], pure)
+ - Context,
VarSet = VarSet0
)
).
@@ -236,6 +237,26 @@
% but then `is/2' itself is a bit of a hack
%
parse_goal_2("is", [A, B], V, unify(A, B), V).
+parse_goal_2("impure", [A0], V0, A, V) :-
+ parse_goal_with_purity(A0, V0, (impure), A, V).
+parse_goal_2("semipure", [A0], V0, A, V) :-
+ parse_goal_with_purity(A0, V0, (semipure), A, V).
+
+
+:- pred parse_goal_with_purity(term, varset, purity, goal_expr, varset).
+:- mode parse_goal_with_purity(in, in, in, out, out) is det.
+
+parse_goal_with_purity(A0, V0, Purity, A, V) :-
+ parse_goal(A0, V0, A1, V),
+ ( A1 = call(Pred, Args, pure) - _ ->
+ A = call(Pred, Args, Purity)
+ ;
+ % XXX Should print a warning: user put an `impure' or
+ % `semipure' marker on a non-atomic goal, or else they put
+ % multiple markers on a goal.
+ A - _ = A1
+ ).
+
%-----------------------------------------------------------------------------%
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.8
diff -u -r1.8 prog_io_pragma.m
--- prog_io_pragma.m 1997/11/02 12:29:23 1.8
+++ prog_io_pragma.m 1997/11/14 01:11:00
@@ -322,6 +322,13 @@
ErrorTerm)
).
+parse_pragma_type(ModuleName, "promise_pure", PragmaTerms,
+ ErrorTerm, _VarSet, Result) :-
+ parse_simple_pragma(ModuleName, "promise_pure",
+ lambda([Name::in, Arity::in, Pragma::out] is det,
+ Pragma = promise_pure(Name, Arity)),
+ PragmaTerms, ErrorTerm, Result).
+
parse_pragma_type(ModuleName, "termination_info", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
(
@@ -429,6 +436,7 @@
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = check_termination(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
+
:- pred parse_simple_pragma(module_name, string,
pred(sym_name, int, pragma_type),
Index: compiler/prog_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_util.m,v
retrieving revision 1.35
diff -u -r1.35 prog_util.m
--- prog_util.m 1997/07/27 15:01:32 1.35
+++ prog_util.m 1997/11/18 05:44:35
@@ -175,8 +175,8 @@
prog_util__rename_in_goal(Cond0, OldVar, NewVar, Cond),
prog_util__rename_in_goal(Then0, OldVar, NewVar, Then),
prog_util__rename_in_goal(Else0, OldVar, NewVar, Else).
-prog_util__rename_in_goal_expr(call(SymName, Terms0), OldVar, NewVar,
- call(SymName, Terms)) :-
+prog_util__rename_in_goal_expr(call(SymName, Terms0, Purity), OldVar, NewVar,
+ call(SymName, Terms, Purity)) :-
term__substitute_list(Terms0, OldVar, term__variable(NewVar), Terms).
prog_util__rename_in_goal_expr(unify(TermA0, TermB0), OldVar, NewVar,
unify(TermA, TermB)) :-
Index: compiler/simplify.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/simplify.m,v
retrieving revision 1.47
diff -u -r1.47 simplify.m
--- simplify.m 1997/11/24 07:27:00 1.47
+++ simplify.m 1997/11/25 00:59:06
@@ -65,7 +65,7 @@
:- import_module code_aux, det_analysis, follow_code, goal_util, const_prop.
:- import_module hlds_module, hlds_goal, hlds_data, (inst), inst_match.
:- import_module globals, options, passes_aux, prog_data, mode_util, type_util.
-:- import_module code_util, quantification, modes.
+:- import_module code_util, quantification, modes, purity.
:- import_module bool, list, set, map, require, std_util, term, varset, int.
%-----------------------------------------------------------------------------%
@@ -171,6 +171,8 @@
% XXX we should warn about this (if the goal wasn't `fail')
%
Detism = failure,
+ % ensure goal is pure or semipure
+ \+ goal_info_is_impure(GoalInfo0),
( det_info_get_fully_strict(DetInfo, no)
; code_aux__goal_cannot_loop(ModuleInfo, Goal0)
)
@@ -194,6 +196,8 @@
simplify_info_get_instmap(Info0, InstMap0),
det_no_output_vars(NonLocalVars, InstMap0, InstMapDelta,
DetInfo),
+ % ensure goal is pure or semipure
+ \+ goal_info_is_impure(GoalInfo0),
( det_info_get_fully_strict(DetInfo, no)
; code_aux__goal_cannot_loop(ModuleInfo, Goal0)
)
@@ -503,10 +507,14 @@
%
% check for duplicate calls to the same procedure
%
- ( simplify_do_calls(Info2) ->
+ ( simplify_do_calls(Info2),
+ goal_info_is_pure(GoalInfo0)
+ ->
common__optimise_call(PredId, ProcId, Args, Goal0, GoalInfo0,
Goal1, Info2, Info3)
- ; simplify_do_warn_calls(Info0) ->
+ ; simplify_do_warn_calls(Info0),
+ goal_info_is_pure(GoalInfo0)
+ ->
% we need to do the pass, for the warnings, but we ignore
% the optimized goal and instead use the original one
common__optimise_call(PredId, ProcId, Args, Goal0, GoalInfo0,
@@ -772,7 +780,9 @@
simplify__goal_2(Goal0, GoalInfo, Goal, GoalInfo, Info0, Info) :-
Goal0 = pragma_c_code(_, _, PredId, ProcId, Args, _, _, _),
- ( simplify_do_calls(Info0) ->
+ ( simplify_do_calls(Info0),
+ goal_info_is_pure(GoalInfo)
+ ->
common__optimise_call(PredId, ProcId, Args, Goal0,
GoalInfo, Goal, Info0, Info)
;
@@ -1221,6 +1231,8 @@
(
simplify_do_warn(Info4),
Goal = _ - GoalInfo,
+ % don't warn about impure disjuncts that can't succeed
+ \+ goal_info_is_impure(GoalInfo),
goal_info_get_determinism(GoalInfo, Detism),
determinism_components(Detism, _, MaxSolns),
MaxSolns = at_most_zero
Index: compiler/special_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/special_pred.m,v
retrieving revision 1.15
diff -u -r1.15 special_pred.m
--- special_pred.m 1997/07/27 15:01:38 1.15
+++ special_pred.m 1997/10/17 06:01:33
@@ -50,6 +50,9 @@
:- pred special_pred_get_type(string, list(Type), Type).
:- mode special_pred_get_type(in, in, out) is semidet.
+:- pred special_pred_description(special_pred_id, string).
+:- mode special_pred_description(in, out) is det.
+
:- implementation.
:- import_module type_util.
@@ -108,5 +111,10 @@
list__reverse(Types, [_, T | _]).
special_pred_get_type("__Compare__", Types, T) :-
list__reverse(Types, [T | _]).
+
+
+special_pred_description(unify, "unification predicate").
+special_pred_description(compare, "comparison predicate").
+special_pred_description(index, "indexing predicate").
%-----------------------------------------------------------------------------%
Index: compiler/typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.219
diff -u -r1.219 typecheck.m
--- typecheck.m 1997/11/24 07:27:10 1.219
+++ typecheck.m 1997/11/25 00:59:13
@@ -2899,16 +2899,17 @@
{ pred_info_arg_types(PredInfo, VarSet, Types0) },
{ strip_builtin_qualifiers_from_type_list(Types0, Types) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
+ { pred_info_get_purity(PredInfo, Purity) },
{ MaybeDet = no },
prog_out__write_context(Context),
io__write_string("Inferred "),
( { PredOrFunc = predicate },
mercury_output_pred_type(VarSet, Name, Types, MaybeDet,
- Context)
+ Purity, Context)
; { PredOrFunc = function },
{ pred_args_to_func_args(Types, ArgTypes, RetType) },
mercury_output_func_type(VarSet, Name, ArgTypes,
- RetType, MaybeDet, Context)
+ RetType, MaybeDet, Purity, Context)
).
%-----------------------------------------------------------------------------%
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.8
diff -u -r1.8 compiler_design.html
--- compiler_design.html 1997/11/08 13:12:08 1.8
+++ compiler_design.html 1997/11/20 00:48:35
@@ -211,6 +211,14 @@
that are used in a variety of different places within the compiler
</ul>
+<dt> purity analysis
+
+ <dd>
+ purity.m is responsible for purity checking, as well as
+ defining the <CODE>purity</CODE> type and a few public
+ operations on it. It also completes the handling of predicate
+ overloading for cases which typecheck.m is unable to handle.
+
<dt> mode analysis
<dd>
@@ -224,9 +232,7 @@
unification goals. It also converts higher-order pred terms
into lambda expressions and module qualifies data constructors.
<li> modecheck_call.m is the sub-module which analyses calls.
- It also converts function calls into predicate calls, and
- does the final step of figuring out which pred_id to use
- for a call to an overloaded predicate.
+ It also converts function calls into predicate calls.
<p>
================ end part 1/2 ================
More information about the developers
mailing list