[m-rev.] for post-commit review:
Zoltan Somogyi
zs at cs.mu.OZ.AU
Wed Mar 8 12:10:53 AEDT 2006
The ideas has already been reviewed, and the code is straightforward.
The parts worth reviewing are the documentation and the tests.
Zoltan.
Add a new pragma, promise_equivalent_clauses, whose effect is to promise
that mode-specific clauses don't make a predicate definition impure.
doc/reference_manual.texi:
Document the new pragma.
compiler/prog_item.m:
Add a representation of the new pragma.
compiler/prog_io_pragma.m:
Parse the new pragma.
compiler/hlds_pred.m:
Add the corresponding marker to predicates.
Reformat some type definitions to comply with our current standards.
compiler/purity.m:
Respect the new pragma when computing the purity of predicates.
compiler/add_pragma.m:
compiler/hlds_out.m:
compiler/intermod.m:
compiler/mercury_to_mercury.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/recompilation.version.m:
compiler/table_gen.m:
Process the new pragma.
compiler/make_hlds_passes.m:
Fix some documentation rot.
tests/hard_coded/promise_equivalent_clauses.{m,exp}:
New test case to test the proper functioning of the new pragma
tests/invalid/promise_equivalent_clauses.{m,exp}:
New test case to test that the new pragma doesn't promise all that
promise_pure would promise.
tests/hard_coded/Mmakefile:
tests/invalid/Mmakefile:
Enable the new test cases.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.24
diff -u -b -r1.24 add_pragma.m
--- compiler/add_pragma.m 24 Feb 2006 01:41:44 -0000 1.24
+++ compiler/add_pragma.m 3 Mar 2006 02:44:56 -0000
@@ -272,6 +272,11 @@
add_pred_marker("promise_semipure", Name, Arity, ImportStatus,
Context, promised_semipure, [], !ModuleInfo, !IO)
;
+ Pragma = promise_equivalent_clauses(Name, Arity),
+ add_pred_marker("promise_equivalent_clauses", Name, Arity,
+ ImportStatus, Context, promised_equivalent_clauses, [],
+ !ModuleInfo, !IO)
+ ;
% Handle pragma termination_info decls later on, in pass 3 --
% we need to add function default modes before handling
% these pragmas
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.383
diff -u -b -r1.383 hlds_out.m
--- compiler/hlds_out.m 27 Feb 2006 06:57:02 -0000 1.383
+++ compiler/hlds_out.m 3 Mar 2006 02:29:57 -0000
@@ -1005,6 +1005,7 @@
marker_name(is_semipure, "semipure").
marker_name(promised_pure, "promise_pure").
marker_name(promised_semipure, "promise_semipure").
+marker_name(promised_equivalent_clauses, "promise_equivalent_clauses").
marker_name(terminates, "terminates").
marker_name(check_termination, "check_termination").
marker_name(does_not_terminate, "does_not_terminate").
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.191
diff -u -b -r1.191 hlds_pred.m
--- compiler/hlds_pred.m 24 Feb 2006 05:49:32 -0000 1.191
+++ compiler/hlds_pred.m 3 Mar 2006 02:18:27 -0000
@@ -105,7 +105,7 @@
% Return an invalid predicate or procedure id. These are intended to be
% used to initialize the relevant fields in in call(...) goals before
- % we do type- and mode-checks, or when those check find that there was
+ % we do type- and mode-checks, or when those checks find that there was
% no predicate matching the call.
%
:- func invalid_pred_id = pred_id.
@@ -142,8 +142,8 @@
% that we need to compute the entry label for that procedure
% in the target language (the llds__code_addr or mlds__code_addr).
-:- type rtti_proc_label --->
- rtti_proc_label(
+:- type rtti_proc_label
+ ---> rtti_proc_label(
pred_or_func :: pred_or_func,
this_module :: module_name,
proc_module :: module_name,
@@ -152,7 +152,8 @@
proc_arg_types :: list(mer_type),
pred_id :: pred_id,
proc_id :: proc_id,
- proc_headvars :: assoc_list(prog_var, prog_var_name),
+ proc_headvars :: assoc_list(prog_var,
+ prog_var_name),
proc_arg_modes :: list(arg_mode),
proc_interface_detism :: determinism,
@@ -747,27 +748,36 @@
% After mode analysis the clauses and the procedure goals are not
% guaranteed to be the same, and the clauses are only kept so that
% the optimized goal can be compared with the original in HLDS dumps.
-:- type clauses_info --->
- clauses_info(
+:- type clauses_info
+ ---> clauses_info(
varset :: prog_varset,
- % variable names
+
explicit_vartypes :: vartypes,
- % variable types from explicit qualifications
+ % Variable types from explicit
+ % qualifications.
+
tvar_name_map :: tvar_name_map,
- % map from variable name to type variable
- % for the type variables occurring in the
- % argument types. This is used to process
- % explicit type qualifications.
+ % Map from variable name to type
+ % variable for the type variables
+ % occurring in the argument types.
+ % This is used to process explicit
+ % type qualifications.
+
vartypes :: vartypes,
- % variable types inferred by typecheck.m.
+ % Variable types inferred by
+ % typecheck.m.
+
headvars :: list(prog_var),
- % head vars
+ % The head variables.
+
clauses_rep :: clauses_rep,
- % the following field is computed by
- % polymorphism.m
+
clauses_rtti_varmaps :: rtti_varmaps,
+ % This field is computed by
+ % polymorphism.m.
+
have_foreign_clauses :: bool
- % do we have foreign language clauses?
+ % Do we have foreign language clauses?
).
:- pred clauses_info_init(int::in, clauses_info::out) is det.
@@ -854,11 +864,12 @@
:- pred clauses_info_set_rtti_varmaps(rtti_varmaps::in,
clauses_info::in, clauses_info::out) is det.
-:- type clause --->
- clause(
+:- type clause
+ ---> clause(
applicable_procs :: list(proc_id),
- % modes for which this clause applies (empty list
- % means it applies to all modes)
+ % Modes for which this clause applies
+ % ([] means it applies to all modes).
+
clause_body :: hlds_goal,
clause_lang :: implementation_language,
clause_context :: prog_context
@@ -1193,14 +1204,21 @@
% 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.
+
; promised_semipure
% Requests that calls to this predicate be treated as
% semipure, despite any impure calls in the body.
+ ; promised_equivalent_clauses
+ % Promises that all modes of the predicate have
+ % equivalent semantics, event if they are defined by
+ % different sets of mode-specific clauses.
+
% The terminates and does_not_terminate pragmas are kept as markers
% to ensure that conflicting declarations are not made by the user.
% Otherwise, the information could be added to the ProcInfos directly.
@@ -1712,8 +1730,8 @@
% polymorphically-typed arguments whose type depends on the
% values of those type_info-related variables;
% accurate GC for the MLDS back-end relies on this.
-:- type pred_info --->
- pred_info(
+:- type pred_info
+ ---> pred_info(
module_name :: module_name,
% Module in which pred occurs.
@@ -1737,9 +1755,9 @@
import_status :: import_status,
goal_type :: goal_type,
- % Whether the goals seen so far, if any, for this
- % predicate are clauses or foreign_code(...)
- % pragmas.
+ % Whether the goals seen so far, if any,
+ % for this predicate are clauses or
+ % foreign_code(...) pragmas.
markers :: pred_markers,
% Various boolean flags.
@@ -1751,65 +1769,76 @@
% Argument types.
decl_typevarset :: tvarset,
- % Names of type vars in the predicate's type decl.
+ % Names of type vars in the predicate's
+ % type declaration.
typevarset :: tvarset,
- % Names of type vars in the predicate's type decl
- % or in the variable type assignments.
+ % Names of type vars in the predicate's
+ % type declaration or in the variable
+ % type assignments.
tvar_kinds :: tvar_kind_map,
% Kinds of the type vars.
exist_quant_tvars :: existq_tvars,
% The set of existentially quantified type
- % variables in the predicate's type decl.
+ % variables in the predicate's type
+ % declaration.
existq_tvar_binding :: tsubst,
- % The statically known bindings of existentially
- % quantified type variables inside this predicate.
- % This field is set at the end of the polymorphism
- % stage.
+ % The statically known bindings of
+ % existentially quantified type variables
+ % inside this predicate. This field is set
+ % at the end of the polymorphism stage.
head_type_params :: head_type_params,
- % The set of type variables which the body of the
- % predicate can't bind, and whose type_infos are
- % produced elsewhere. This includes universally
- % quantified head types (the type_infos are passed
- % in) plus existentially quantified types in preds
- % called from the body (the type_infos are returned
- % from the called preds). Computed during type
- % checking.
+ % The set of type variables which the body
+ % of the predicate can't bind, and whose
+ % type_infos are produced elsewhere.
+ % This includes universally quantified
+ % head types (the type_infos are passed in)
+ % plus existentially quantified types
+ % in preds called from the body (the
+ % type_infos are returned from the
+ % called predicates). Computed during
+ % type checking.
class_context :: prog_constraints,
- % The class constraints on the type variables
- % in the predicate's type declaration.
+ % The class constraints on the type
+ % variables in the predicate's type
+ % declaration.
constraint_proofs :: constraint_proof_map,
- % Explanations of how redundant constraints were
- % eliminated. These are needed by polymorphism.m
- % to work out where to get the typeclass_infos
- % from. Computed during type checking.
+ % Explanations of how redundant constraints
+ % were eliminated. These are needed by
+ % polymorphism.m to work out where to get
+ % the typeclass_infos from. Computed
+ % during type checking.
constraint_map :: constraint_map,
% Maps constraint identifiers to the actual
- % constraints. Computed during type checking.
+ % constraints. Computed during type
+ % checking.
unproven_body_constraints :: list(prog_constraint),
- % Unproven class constraints on type variables
- % in the predicate's body, if any (if this remains
- % non-empty after type checking has finished,
- % post_typecheck.m will report a type error).
+ % Unproven class constraints on type
+ % variables in the predicate's body,
+ % if any (if this remains non-empty
+ % after type checking has finished,
+ % post_typecheck.m will report a
+ % type error).
inst_graph_info :: inst_graph_info,
- % The predicate's inst graph, for constraint
- % based mode analysis.
+ % The predicate's inst graph, for
+ % constraint based mode analysis.
modes :: list(arg_modes_map),
- % Mode information extracted from constraint
- % based mode analysis.
+ % Mode information extracted from
+ % constraint based mode analysis.
assertions :: set(assert_id),
- % List of assertions which mention this predicate.
+ % List of assertions which mention
+ % this predicate.
clauses_info :: clauses_info,
@@ -1818,8 +1847,8 @@
pred_info_init(ModuleName, SymName, Arity, PredOrFunc, Context, Origin,
Status, GoalType, Markers, ArgTypes, TypeVarSet, ExistQVars,
- ClassContext, ClassProofs, ClassConstraintMap,
- ClausesInfo, PredInfo) :-
+ ClassContext, ClassProofs, ClassConstraintMap, ClausesInfo,
+ PredInfo) :-
unqualify_name(SymName, PredName),
sym_name_get_module_name(SymName, ModuleName, PredModuleName),
prog_type__vars_list(ArgTypes, TVars),
@@ -2726,17 +2755,16 @@
%
:- pred clone_proc_id(proc_table::in, proc_id::in, proc_id::out) is det.
- % When mode inference is enabled, we record for each inferred
- % mode whether it is valid or not by keeping a list of error
- % messages in the proc_info. The mode is valid iff this list
- % is empty.
+ % When mode inference is enabled, we record for each inferred mode
+ % whether it is valid or not by keeping a list of error messages
+ % in the proc_info. The mode is valid iff this list is empty.
%
:- func mode_errors(proc_info) = list(mode_error_info).
:- func 'mode_errors :='(proc_info, list(mode_error_info)) = proc_info.
:- pred proc_info_is_valid_mode(proc_info::in) is semidet.
% Make sure that all headvars are named. This can be useful e.g.
- % becasue the debugger ignores unnamed variables.
+ % because the debugger ignores unnamed variables.
%
:- pred ensure_all_headvars_are_named(proc_info::in, proc_info::out) is det.
@@ -2750,176 +2778,201 @@
:- import_module check_hlds.mode_errors.
:- import_module mdbcomp.program_representation.
-:- type proc_info --->
- proc_info(
+:- type proc_info
+ ---> proc_info(
proc_context :: prog_context,
% The context of the `:- mode' decl
- % (or the context of the first clause,
- % if there was no mode declaration).
+ % (or the context of the first
+ % clause, if there was no mode
+ % declaration).
+
prog_varset :: prog_varset,
var_types :: vartypes,
head_vars :: list(prog_var),
inst_varset :: inst_varset,
+
maybe_declared_head_modes :: maybe(list(mer_mode)),
% The declared modes of arguments.
actual_head_modes :: list(mer_mode),
maybe_head_modes_constraint :: maybe(mode_constraint),
+
head_var_caller_liveness :: maybe(list(is_live)),
- % Liveness (in the mode analysis sense)
- % of the arguments in the caller; says
- % whether each argument may be used
- % after the call.
+ % Liveness (in the mode analysis
+ % sense) of the arguments in the
+ % caller; says whether each
+ % argument may be used after
+ % the call.
+
declared_detism :: maybe(determinism),
% The _declared_ determinism of the
- % procedure, or `no' if there was no
- % detism decl.
+ % procedure, or `no' if there was
+ % no detism declaration.
+
inferred_detism :: determinism,
body :: hlds_goal,
can_process :: bool,
- % No if we must not process this procedure
- % yet (used to delay mode checking etc.
- % for complicated modes of unification
- % procs until the end of the unique_modes
- % pass.)
+ % No if we must not process
+ % this procedure yet (used to delay
+ % mode checking etc. for
+ % complicated modes of unification
+ % predicates until the end of the
+ % unique_modes pass.)
+
mode_errors :: list(mode_error_info),
+
proc_rtti_varmaps :: rtti_varmaps,
% Information about type_infos and
% typeclass_infos.
+
eval_method :: eval_method,
% How should the proc be evaluated.
proc_sub_info :: proc_sub_info
).
-:- type proc_sub_info --->
- proc_sub_info(
+:- type proc_sub_info
+ ---> proc_sub_info(
maybe_arg_sizes :: maybe(arg_size_info),
- % Information about the relative sizes
- % of the input and output args of the
- % procedure. Set by termination
- % analysis.
+ % Information about the relative
+ % sizes of the input and output
+ % args of the procedure. Set by
+ % termination analysis.
maybe_termination :: maybe(termination_info),
% The termination properties of the
% procedure. Set by termination
% analysis.
+
termination2 :: termination2_info,
- % Termination properties and argument
- % size constraints for the procedure.
- % Set by termination2 analysis.
+ % Termination properties and
+ % argument size constraints for
+ % the procedure. Set by
+ % termination2 analysis.
is_address_taken :: is_address_taken,
% Is the address of this procedure
- % taken? If yes, we will need to use
- % typeinfo liveness for them, so that
- % deep_copy and accurate gc have the
- % RTTI they need for copying closures.
+ % taken? If yes, we will need to
+ % use typeinfo liveness for them,
+ % so that deep_copy and accurate gc
+ % have the RTTI they need for
+ % copying closures.
%
% Note that any non-local procedure
% must be considered as having its
- % address taken, since it is possible
- % that some other module may do so.
+ % address taken, since it is
+ % possible that some other module
+ % may do so.
stack_slots :: stack_slots,
- % Allocation of variables to stack slots.
+ % Allocation of variables
+ % to stack slots.
arg_pass_info :: maybe(list(arg_info)),
- % The calling convention of each arg:
- % information computed by arg_info.m
- % (based on the modes etc.)
- % and used by code generation
- % to determine how each argument
- % should be passed.
+ % The calling convention of
+ % each argument: information
+ % computed by arg_info.m (based on
+ % the modes etc.) and used by code
+ % generation to determine how
+ % each argument should be passed.
initial_liveness :: liveness_info,
% The initial liveness, for code
% generation.
need_maxfr_slot :: bool,
- % True iff tracing is enabled, this
- % is a procedure that lives on the det
- % stack, and the code of this procedure
- % may create a frame on the det stack.
- % (Only in these circumstances do we
- % need to reserve a stack slot to hold
- % the value of maxfr at the call, for
- % use in implementing retry.)
- %
- % This slot is used only with the LLDS
- % backend XXX. Its value is set during
- % the live_vars pass; it is invalid
+ % True iff tracing is enabled,
+ % this is a procedure that lives
+ % on the det stack, and the code
+ % of this procedure may create
+ % a frame on the det stack.
+ % (Only in these circumstances
+ % do we need to reserve a stack
+ % slot to hold the value of maxfr
+ % at the call, for use in
+ % implementing retry.)
+ % This slot is used only with
+ % the LLDS backend XXX.
+ % Its value is set during the
+ % live_vars pass; it is invalid
% before then.
call_table_tip :: maybe(prog_var),
- % If the procedure's evaluation method
- % is memo, loopcheck or minimal, this
- % slot identifies the variable that
- % holds the tip of the call table.
- % Otherwise, this field will be set to
- % `no'.
+ % If the procedure's evaluation
+ % method is memo, loopcheck or
+ % minimal, this slot identifies the
+ % variable that holds the tip
+ % of the call table. Otherwise,
+ % this field will be set to `no'.
%
% Tabled procedures record, in the
% data structure identified by this
- % variable, that the call is active.
- % When performing a retry across
- % such a procedure, we must reset
- % the state of the call; if we don't,
- % the retried call will find the
- % active call and report an infinite
- % loop error.
+ % variable, that the call is
+ % active. When performing a retry
+ % across such a procedure, we must
+ % reset the state of the call;
+ % if we don't, the retried call
+ % will find the active call and
+ % report an infinite loop error.
%
% Such resetting of course requires
% the debugger to know whether the
- % procedure has reached the call table
- % tip yet. Therefore when binding this
- % variable, the code generator of the
- % relevant backend must record this
- % fact in a place accessible to the
- % debugger, if debugging is enabled.
+ % procedure has reached the call
+ % table tip yet. Therefore when
+ % binding this variable, the code
+ % generator of the relevant backend
+ % must record this fact in a place
+ % accessible to the debugger,
+ % if debugging is enabled.
maybe_table_info :: maybe(proc_table_info),
% If set, it means that procedure
% has been subject to a tabling
- % transformation, either I/O tabling
- % or the regular kind. In the former
- % case, the argument will contain all
- % the information we need to display
- % I/O actions involving this procedure;
- % in the latter case, it will contain
- % all the information we need to display
- % the call tables, answer tables and
- % answer blocks of the procedure.
+ % transformation, either I/O
+ % tabling or the regular kind.
+ % In the former case, the argument
+ % will contain all the information
+ % we need to display I/O actions
+ % involving this procedure; in the
+ % latter case, it will contain
+ % all the information we need
+ % to display the call tables,
+ % answer tables and answer blocks
+ % of the procedure.
% XXX For now, the compiler fully
% supports only procedures whose
- % arguments are all either ints, floats
- % or strings. However, this is still
- % sufficient for debugging most
- % problems in the tabling system.
+ % arguments are all either ints,
+ % floats or strings. However, this
+ % is still sufficient for debugging
+ % most problems in the tabling
+ % system.
maybe_deep_profile_proc_info :: maybe(deep_profile_proc_info),
maybe_untuple_info :: maybe(untuple_proc_info),
- % If set, it means this procedure was
- % created from another procedure by the
- % untupling transformation. This slot
- % records which of the procedure's
+ % If set, it means this procedure
+ % was created from another
+ % procedure by the untupling
+ % transformation. This slot records
+ % which of the procedure's
% arguments were derived from which
- % arguments in the original procedure.
+ % arguments in the original
+ % procedure.
maybe_structure_sharing :: maybe(structure_sharing_domain)
- % Structure sharing information as obtained
- % by the structure sharing analysis.
+ % Structure sharing information
+ % as obtained by the structure
+ % sharing analysis.
).
- % Some parts of the procedure aren't known yet. We initialize
- % them to any old garbage which we will later throw away.
+proc_info_init(MContext, Arity, Types, DeclaredModes, Modes, MaybeArgLives,
+ MaybeDet, IsAddressTaken, NewProc) :-
+ % Some parts of the procedure aren't known yet. We initialize them
+ % to any old garbage which we will later throw away.
% Inferred determinism gets initialized to `erroneous'.
% This is what `det_analysis.m' wants. det_analysis.m
% will later provide the correct inferred determinism for it.
-proc_info_init(MContext, Arity, Types, DeclaredModes, Modes, MaybeArgLives,
- MaybeDet, IsAddressTaken, NewProc) :-
make_n_fresh_vars("HeadVar__", Arity, HeadVars, varset__init, BodyVarSet),
varset__init(InstVarSet),
map__from_corresponding_lists(HeadVars, Types, BodyTypes),
@@ -2952,8 +3005,7 @@
RttiVarMaps, eval_normal, ProcSubInfo).
proc_info_create(Context, VarSet, VarTypes, HeadVars, InstVarSet,
- HeadModes, Detism, Goal, RttiVarMaps, IsAddressTaken,
- ProcInfo) :-
+ HeadModes, Detism, Goal, RttiVarMaps, IsAddressTaken, ProcInfo) :-
proc_info_create(Context, VarSet, VarTypes, HeadVars, InstVarSet,
HeadModes, yes(Detism), Detism, Goal, RttiVarMaps,
IsAddressTaken, ProcInfo).
@@ -3152,20 +3204,19 @@
( map__search(VarTypes, Var, Type) ->
prog_type__vars(Type, TypeVars),
(
- % Optimize common case
- TypeVars = []
- ->
+ TypeVars = [],
+ % Optimize common case,
proc_info_get_typeinfo_vars_2(Vars, VarTypes, TVarMap,
TypeInfoVars)
;
+ TypeVars = [_ | _],
% XXX It's possible there are some complications with
% higher order pred types here -- if so, maybe
% treat them specially.
- % The type_info is either stored in a variable,
- % or in a typeclass_info. Either get the
- % type_info variable or the typeclass_info
- % variable
+ % The type_info is either stored in a variable, or in a
+ % typeclass_info. Either get the type_info variable or
+ % the typeclass_info variable.
LookupVar = (pred(TVar::in, TVarVar::out) is det :-
map__lookup(TVarMap, TVar, Locn),
type_info_locn_var(Locn, TVarVar)
@@ -3283,8 +3334,7 @@
globals__lookup_bool_option(Globals,
record_term_sizes_as_cells, yes)
;
- non_special_body_should_use_typeinfo_liveness(Globals,
- yes)
+ non_special_body_should_use_typeinfo_liveness(Globals, yes)
)
->
InterfaceTypeInfoLiveness = yes
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.192
diff -u -b -r1.192 intermod.m
--- compiler/intermod.m 24 Feb 2006 05:49:32 -0000 1.192
+++ compiler/intermod.m 3 Mar 2006 02:38:20 -0000
@@ -1773,6 +1773,7 @@
should_output_marker(heuristic_inline, no).
should_output_marker(promised_pure, yes).
should_output_marker(promised_semipure, yes).
+should_output_marker(promised_equivalent_clauses, yes).
should_output_marker(terminates, yes).
should_output_marker(does_not_terminate, yes).
% Termination should only be checked in the defining module.
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.30
diff -u -b -r1.30 make_hlds_passes.m
--- compiler/make_hlds_passes.m 27 Feb 2006 06:57:02 -0000 1.30
+++ compiler/make_hlds_passes.m 3 Mar 2006 02:46:00 -0000
@@ -52,8 +52,8 @@
term__context::in, module_info::in, module_info::out, io::di, io::uo)
is det.
- % add_pred_marker(ModuleInfo0, PragmaName, Name, Arity, Status,
- % Context, Marker, ConflictMarkers, ModuleInfo, !IO):
+ % add_pred_marker(PragmaName, Name, Arity, Status,
+ % Context, Marker, ConflictMarkers, !ModuleInfo, !IO):
%
% Adds Marker to the marker list of the pred(s) with give Name and Arity,
% updating the ModuleInfo. If the named pred does not exist, or the pred
@@ -1447,8 +1447,7 @@
MustBeExported, Preds0, Preds, WrongStatus),
(
WrongStatus = yes,
- pragma_status_error(Name, Arity, Context, PragmaName,
- !IO),
+ pragma_status_error(Name, Arity, Context, PragmaName, !IO),
module_info_incr_errors(!ModuleInfo)
;
WrongStatus = no
@@ -1469,7 +1468,7 @@
get_matching_pred_ids(Module0, Name, Arity, PredIds) :-
module_info_get_predicate_table(Module0, PredTable0),
- % check that the pragma is module qualified.
+ % Check that the pragma is module qualified.
(
Name = unqualified(_),
unexpected(this_file, "get_matching_pred_ids: unqualified name")
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.283
diff -u -b -r1.283 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 24 Feb 2006 07:11:11 -0000 1.283
+++ compiler/mercury_to_mercury.m 3 Mar 2006 02:36:09 -0000
@@ -628,6 +628,10 @@
mercury_output_pragma_decl(Pred, Arity, predicate, "promise_semipure",
no, !IO)
;
+ Pragma = promise_equivalent_clauses(Pred, Arity),
+ mercury_output_pragma_decl(Pred, Arity, predicate,
+ "promise_equivalent_clauses", no, !IO)
+ ;
Pragma = termination_info(PredOrFunc, PredName, ModeList,
MaybePragmaArgSizeInfo, MaybePragmaTerminationInfo),
write_pragma_termination_info(PredOrFunc, PredName, ModeList,
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.126
diff -u -b -r1.126 module_qual.m
--- compiler/module_qual.m 24 Feb 2006 01:41:51 -0000 1.126
+++ compiler/module_qual.m 3 Mar 2006 02:36:32 -0000
@@ -1099,6 +1099,7 @@
qualify_pragma(X at reserve_tag(_, _), X, !Info, !IO).
qualify_pragma(X at promise_pure(_, _), X, !Info, !IO).
qualify_pragma(X at promise_semipure(_, _), X, !Info, !IO).
+qualify_pragma(X at promise_equivalent_clauses(_, _), X, !Info, !IO).
qualify_pragma(termination_info(PredOrFunc, SymName, ModeList0, Args, Term),
termination_info(PredOrFunc, SymName, ModeList, Args, Term),
!Info, !IO) :-
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.378
diff -u -b -r1.378 modules.m
--- compiler/modules.m 27 Feb 2006 06:57:03 -0000 1.378
+++ compiler/modules.m 3 Mar 2006 02:37:32 -0000
@@ -2110,6 +2110,7 @@
pragma_allowed_in_interface(reserve_tag(_, _), yes).
pragma_allowed_in_interface(promise_pure(_, _), no).
pragma_allowed_in_interface(promise_semipure(_, _), no).
+pragma_allowed_in_interface(promise_equivalent_clauses(_, _), no).
pragma_allowed_in_interface(unused_args(_, _, _, _, _), no).
pragma_allowed_in_interface(exceptions(_, _, _, _, _), no).
pragma_allowed_in_interface(trailing_info(_, _, _, _, _), no).
@@ -7633,6 +7634,7 @@
; Pragma = obsolete(_, _), Reorderable = yes
; Pragma = promise_pure(_, _), Reorderable = yes
; Pragma = promise_semipure(_, _), Reorderable = yes
+ ; Pragma = promise_equivalent_clauses(_, _), Reorderable = yes
; Pragma = reserve_tag(_, _), Reorderable = yes
; Pragma = source_file(_), Reorderable = no
; Pragma = tabled(_, _, _, _, _), Reorderable = yes
@@ -7712,6 +7714,7 @@
; Pragma = obsolete(_, _), Reorderable = yes
; Pragma = promise_pure(_, _), Reorderable = yes
; Pragma = promise_semipure(_, _), Reorderable = yes
+ ; Pragma = promise_equivalent_clauses(_, _), Reorderable = yes
; Pragma = reserve_tag(_, _), Reorderable = yes
; Pragma = source_file(_), Reorderable = no
; Pragma = tabled(_, _, _, _, _), Reorderable = yes
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.99
diff -u -b -r1.99 prog_io_pragma.m
--- compiler/prog_io_pragma.m 24 Feb 2006 01:41:53 -0000 1.99
+++ compiler/prog_io_pragma.m 3 Mar 2006 01:57:33 -0000
@@ -945,6 +945,13 @@
"`:- pragma fact_table' declaration", ErrorTerm)
).
+parse_pragma_type(ModuleName, "promise_equivalent_clauses", PragmaTerms,
+ ErrorTerm, _VarSet, Result) :-
+ parse_simple_pragma(ModuleName, "promise_equivalent_clauses",
+ (pred(Name::in, Arity::in, Pragma::out) is det :-
+ Pragma = promise_equivalent_clauses(Name, Arity)),
+ PragmaTerms, ErrorTerm, Result).
+
parse_pragma_type(ModuleName, "promise_pure", PragmaTerms, ErrorTerm, _VarSet,
Result) :-
parse_simple_pragma(ModuleName, "promise_pure",
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.5
diff -u -b -r1.5 prog_item.m
--- compiler/prog_item.m 24 Feb 2006 01:41:53 -0000 1.5
+++ compiler/prog_item.m 3 Mar 2006 01:58:09 -0000
@@ -513,6 +513,12 @@
% Purity pragmas
%
+ ; promise_equivalent_clauses(
+ eqv_clauses_name :: sym_name,
+ eqv_clauses_arity :: arity
+ % Predname, Arity
+ )
+
; promise_pure(
pure_name :: sym_name,
pure_arity :: arity
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.89
diff -u -b -r1.89 purity.m
--- compiler/purity.m 24 Feb 2006 05:49:38 -0000 1.89
+++ compiler/purity.m 3 Mar 2006 06:04:48 -0000
@@ -285,16 +285,14 @@
pred_info_get_promised_purity(!.PredInfo, PromisedPurity),
some [!ClausesInfo] (
pred_info_clauses_info(!.PredInfo, !:ClausesInfo),
- ProcIds = pred_info_procids(!.PredInfo),
clauses_info_clauses(Clauses0, !ClausesInfo),
clauses_info_vartypes(!.ClausesInfo, VarTypes0),
clauses_info_varset(!.ClausesInfo, VarSet0),
RunPostTypecheck = yes,
PurityInfo0 = purity_info(ModuleInfo, RunPostTypecheck,
!.PredInfo, VarTypes0, VarSet0, [], dont_make_implicit_promises),
- pred_info_get_goal_type(!.PredInfo, GoalType),
- compute_purity(GoalType, Clauses0, Clauses, ProcIds,
- purity_pure, Purity, PurityInfo0, PurityInfo),
+ compute_purity(Clauses0, Clauses, !.PredInfo, purity_pure, Purity,
+ PurityInfo0, PurityInfo),
PurityInfo = purity_info(_, _, !:PredInfo,
VarTypes, VarSet, RevMessages, _),
clauses_info_set_vartypes(VarTypes, !ClausesInfo),
@@ -397,37 +395,46 @@
true
).
- % Infer the purity of a single (non-pragma c_code) predicate.
+ % Infer the purity of a single (non-foreign_proc) predicate.
%
-:- pred compute_purity(goal_type::in, list(clause)::in, list(clause)::out,
- list(proc_id)::in, purity::in, purity::out,
+:- pred compute_purity(list(clause)::in, list(clause)::out,
+ pred_info::in, purity::in, purity::out,
purity_info::in, purity_info::out) is det.
-compute_purity(_, [], [], _, !Purity, !Info).
-compute_purity(GoalType, [Clause0 | Clauses0], [Clause | Clauses], ProcIds,
- !Purity, !Info) :-
- Clause0 = clause(Ids, Body0 - Info0, Lang, Context),
- compute_expr_purity(Body0, Body, Info0, Bodypurity0, !Info),
+compute_purity([], [], _, !Purity, !Info).
+compute_purity([Clause0 | Clauses0], [Clause | Clauses], PredInfo, !Purity,
+ !Info) :-
+ Clause0 = clause(Ids, GoalExpr0 - GoalInfo0, Lang, Context),
+ compute_expr_purity(GoalExpr0, GoalExpr, GoalInfo0, BodyPurity0, !Info),
% If this clause doesn't apply to all modes of this procedure,
% i.e. the procedure has different clauses for different modes,
- % then we must treat it as impure.
- % the default impurity of foreign_proc procedures is handled when
+ % then we must treat it as impure, unless the programmer has promised
+ % that the clauses are semantically equivalent.
+ %
+ % The default impurity of foreign_proc procedures is handled when
% processing the foreign_proc goal -- they are not counted as impure
- % here simply because they have different clauses for different modes
+ % here simply because they have different clauses for different modes.
+ (
(
- ( applies_to_all_modes(Clause0, ProcIds)
- ; GoalType = pragmas
+ ProcIds = pred_info_procids(PredInfo),
+ applies_to_all_modes(Clause0, ProcIds)
+ ;
+ pred_info_get_markers(PredInfo, Markers),
+ check_marker(Markers, promised_equivalent_clauses)
+ ;
+ pred_info_get_goal_type(PredInfo, GoalType),
+ GoalType = pragmas
)
->
- Clausepurity = purity_pure
+ ClausePurity = purity_pure
;
- Clausepurity = purity_impure
+ ClausePurity = purity_impure
),
- worst_purity(Bodypurity0, Clausepurity) = Bodypurity,
- add_goal_info_purity_feature(Bodypurity, Info0, Info),
- !:Purity = worst_purity(!.Purity, Bodypurity),
- Clause = clause(Ids, Body - Info, Lang, Context),
- compute_purity(GoalType, Clauses0, Clauses, ProcIds, !Purity, !Info).
+ BodyPurity = worst_purity(BodyPurity0, ClausePurity),
+ add_goal_info_purity_feature(BodyPurity, GoalInfo0, GoalInfo),
+ !:Purity = worst_purity(!.Purity, BodyPurity),
+ Clause = clause(Ids, GoalExpr - GoalInfo, Lang, Context),
+ compute_purity(Clauses0, Clauses, PredInfo, !Purity, !Info).
:- pred applies_to_all_modes(clause::in, list(proc_id)::in) is semidet.
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.38
diff -u -b -r1.38 recompilation.version.m
--- compiler/recompilation.version.m 23 Feb 2006 09:37:03 -0000 1.38
+++ compiler/recompilation.version.m 3 Mar 2006 02:37:53 -0000
@@ -584,6 +584,8 @@
yes(MaybePredOrFunc - Name / Arity)).
is_pred_pragma(promise_pure(Name, Arity), yes(no - Name / Arity)).
is_pred_pragma(promise_semipure(Name, Arity), yes(no - Name / Arity)).
+is_pred_pragma(promise_equivalent_clauses(Name, Arity),
+ yes(no - Name / Arity)).
is_pred_pragma(termination_info(PredOrFunc, Name, Modes, _, _),
yes(yes(PredOrFunc) - Name / Arity)) :-
adjust_func_arity(PredOrFunc, Arity, list__length(Modes)).
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.101
diff -u -b -r1.101 table_gen.m
--- compiler/table_gen.m 24 Feb 2006 05:49:40 -0000 1.101
+++ compiler/table_gen.m 3 Mar 2006 02:38:34 -0000
@@ -1898,6 +1898,7 @@
keep_marker(is_semipure) = yes.
keep_marker(promised_pure) = yes.
keep_marker(promised_semipure) = yes.
+keep_marker(promised_equivalent_clauses) = yes.
keep_marker(terminates) = yes.
keep_marker(does_not_terminate) = yes.
keep_marker(check_termination) = no.
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.344
diff -u -b -r1.344 reference_manual.texi
--- doc/reference_manual.texi 24 Feb 2006 07:11:16 -0000 1.344
+++ doc/reference_manual.texi 8 Mar 2006 00:46:55 -0000
@@ -2891,9 +2891,12 @@
Because of this possibility, predicates or functions which are defined
using different code for different modes are by default assumed to be
-impure; the programmer must either (1) carefully ensure that the
-logical meaning of the clauses is the same for all modes,
-in which case a @samp{pragma promise_pure} declaration can be used
+impure; the programmer must either
+(1) carefully ensure that the logical meaning of the clauses
+is the same for all modes,
+which can be declared to the compiler
+through a @samp{pragma promise_equivalent_clauses} declaration,
+or a @samp{pragma promise_pure} declaration,
or (2) declare the predicate or function as impure.
@xref{Impurity}.
@@ -2902,8 +2905,20 @@
the first approach:
@example
+ :- pragma promise_equivalent_clauses(append/3).
+ at end example
+
+The pragma
+
+ at example
:- pragma promise_pure(append/3).
@end example
+
+would also promise that the clauses are equivalent,
+but on top of that would also promise that the code of each clause is pure.
+Sometimes, if some clauses contain impure code,
+that is a promise that the programmer wants to make,
+but this extra promise is unnecessary in this case.
In the example with @samp{var/1} above, the two clauses have different
semantics, so the predicate must be declared as impure:
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.279
diff -u -b -r1.279 Mmakefile
--- tests/hard_coded/Mmakefile 7 Mar 2006 01:03:43 -0000 1.279
+++ tests/hard_coded/Mmakefile 8 Mar 2006 00:48:35 -0000
@@ -142,6 +142,7 @@
pragma_import \
pragma_inline \
pretty_printing \
+ promise_equivalent_clauses \
promise_equivalent_solutions_test \
promise_equiv_with_svars \
pure_mutable \
Index: tests/hard_coded/promise_equivalent_clauses.exp
===================================================================
RCS file: tests/hard_coded/promise_equivalent_clauses.exp
diff -N tests/hard_coded/promise_equivalent_clauses.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/promise_equivalent_clauses.exp 8 Mar 2006 00:27:42 -0000
@@ -0,0 +1,6 @@
+[1, 2, 3] [1, 2, 3]
+[1, 3, 2] [1, 2, 3]
+[2, 1, 3] [1, 2, 3]
+[2, 3, 1] [1, 2, 3]
+[3, 1, 2] [1, 2, 3]
+[3, 2, 1] [1, 2, 3]
Index: tests/hard_coded/promise_equivalent_clauses.m
===================================================================
RCS file: tests/hard_coded/promise_equivalent_clauses.m
diff -N tests/hard_coded/promise_equivalent_clauses.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/promise_equivalent_clauses.m 8 Mar 2006 00:27:39 -0000
@@ -0,0 +1,52 @@
+:- module promise_equivalent_clauses.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module list.
+:- import_module std_util.
+
+main(!IO) :-
+ SortedList = [1, 2, 3],
+ solutions(rev_sort(SortedList), RawLists),
+ list.foldl(test, RawLists, !IO).
+
+:- pred test(list(T)::in, io::di, io::uo) is det.
+
+test(RawList, !IO) :-
+ io.write(RawList, !IO),
+ io.write_string(" ", !IO),
+ rsort(RawList, SortedList),
+ io.write(SortedList, !IO),
+ io.nl(!IO).
+
+:- pred rev_sort(list(T)::in, list(T)::out) is nondet.
+
+rev_sort(SortedList, RawList) :-
+ rsort(RawList, SortedList).
+
+:- pred rsort(list(T), list(T)).
+:- mode rsort(in, out) is det.
+:- mode rsort(out, in) is nondet.
+:- pragma promise_equivalent_clauses(rsort/2).
+
+rsort(Raw::in, Sorted::out) :-
+ list.sort(Raw, Sorted).
+
+rsort(Raw::out, Sorted::in) :-
+ is_sorted(Sorted),
+ list.perm(Sorted, Raw).
+
+:- pred is_sorted(list(T)::in) is semidet.
+
+is_sorted([]).
+is_sorted([_]).
+is_sorted([A, B | Rest]) :-
+ compare(R, A, B),
+ ( R = (<) ; R = (=) ),
+ is_sorted([B | Rest]).
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: [00:54:29] waiting for uid20308's lock in /home/mercury/mercury1/repository/tests/hard_coded/sub-modules
cvs diff: [00:54:59] obtained lock in /home/mercury/mercury1/repository/tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: [00:54:59] waiting for uid20308's lock in /home/mercury/mercury1/repository/tests/invalid
cvs diff: [00:55:29] obtained lock in /home/mercury/mercury1/repository/tests/invalid
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.189
diff -u -b -r1.189 Mmakefile
--- tests/invalid/Mmakefile 23 Feb 2006 09:37:23 -0000 1.189
+++ tests/invalid/Mmakefile 8 Mar 2006 00:52:36 -0000
@@ -136,6 +136,7 @@
pragma_c_code_no_det \
predmode \
prog_io_erroneous \
+ promise_equivalent_clauses \
promise_equivalent_solutions_test \
qual_basic_test2 \
qualified_cons_id2 \
Index: tests/invalid/promise_equivalent_clauses.err_exp
===================================================================
RCS file: tests/invalid/promise_equivalent_clauses.err_exp
diff -N tests/invalid/promise_equivalent_clauses.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/promise_equivalent_clauses.err_exp 8 Mar 2006 00:52:19 -0000
@@ -0,0 +1,5 @@
+promise_equivalent_clauses.m:033: In predicate
+promise_equivalent_clauses.m:033: `promise_equivalent_clauses.rsort/2':
+promise_equivalent_clauses.m:033: purity error: predicate is impure.
+promise_equivalent_clauses.m:033: It must be declared `impure' or promised
+promise_equivalent_clauses.m:033: pure.
Index: tests/invalid/promise_equivalent_clauses.m
===================================================================
RCS file: tests/invalid/promise_equivalent_clauses.m
diff -N tests/invalid/promise_equivalent_clauses.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/promise_equivalent_clauses.m 8 Mar 2006 00:51:58 -0000
@@ -0,0 +1,62 @@
+:- module promise_equivalent_clauses.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module list.
+:- import_module std_util.
+
+main(!IO) :-
+ SortedList = [1, 2, 3],
+ solutions(rev_sort(SortedList), RawLists),
+ list.foldl(test, RawLists, !IO).
+
+:- pred test(list(T)::in, io::di, io::uo) is det.
+
+test(RawList, !IO) :-
+ io.write(RawList, !IO),
+ io.write_string(" ", !IO),
+ rsort(RawList, SortedList),
+ io.write(SortedList, !IO),
+ io.nl(!IO).
+
+:- pred rev_sort(list(T)::in, list(T)::out) is nondet.
+
+rev_sort(SortedList, RawList) :-
+ rsort(RawList, SortedList).
+
+:- pred rsort(list(T), list(T)).
+:- mode rsort(in, out) is det.
+:- mode rsort(out, in) is nondet.
+:- pragma promise_equivalent_clauses(rsort/2).
+
+rsort(Raw::in, Sorted::out) :-
+ list.sort(Raw, Sorted0),
+ impure impure_copy(Sorted0, Sorted).
+
+rsort(Raw::out, Sorted::in) :-
+ is_sorted(Sorted),
+ list.perm(Sorted, Raw).
+
+:- pred is_sorted(list(T)::in) is semidet.
+
+is_sorted([]).
+is_sorted([_]).
+is_sorted([A, B | Rest]) :-
+ compare(R, A, B),
+ ( R = (<) ; R = (=) ),
+ is_sorted([B | Rest]).
+
+:- impure pred impure_copy(T::in, T::out) is det.
+
+:- pragma foreign_proc("C",
+ impure_copy(X::in, Y::out),
+ [will_not_call_mercury, thread_safe],
+"
+ Y = X;
+").
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: [00:55:31] waiting for uid20308's lock in /home/mercury/mercury1/repository/tests/tabling
cvs diff: [00:56:01] obtained lock in /home/mercury/mercury1/repository/tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
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