[m-rev.] For Review: Bug fixes in constraints based mode analysis.
Richard Fothergill
fothergill at gmail.com
Fri Feb 17 18:00:30 AEDT 2006
For review by anyone.
Estimated hours taken: 35
Branch: main.
Bugfixes for constraints based mode analysis (propagation solver).
Fix a bug where the producer/consumer analysis was failing when implied modes
were required in predicate calls. Appropriate unifications are now generated
so as to allow for such calls.
Fix a bug where conservative approximation of nonlocals sets was leading
analysis to assume a goal consumed a variable it didn't actually use. This was
fixed by making a check that variables in nonlocal sets actually appear in the
goal.
Finally, the transformation to hhf was leaving some nonlocals sets inaccurate,
so some producing/consuming conjuncts for certain program variables were being
ignored, resulting in a failure in producer/consumer analysis. This was fixed
by no longer transforming to hhf for the propagation solver constraints
based mode analysis. This is fine for now, because the current version
uses only simple constraints and doesn't need hhf. However, if it is going
to be extended to the full constraints system (that handles subtyping and
partial instantiation) the transformation to hhf will have to be used,
and the nonlocals sets bug fixed.
compiler/handle_options.m
Added option implications since the antecedents do nothing
without the consequents:
debug_mode_constraints -> prop_mode_constraints
simple_mode_constraints -> mode_constraints
compiler/mercury_compile.m
The results of constraints based mode analysis are no longer
discarded - they are now passed on to the rest of the compiler.
The original mode analysis can now finish anything constraints
based mode analysis hasn't done, but it shouldn't have to do
any reordering of conjunctions.
compiler/mode_constraints.m
When the propagation solver is used, the transformation to HHF
no longer occurs, and unifications are generated to allow for
use of implied modes in predicate calls.
compiler/ordering_mode_constraints.m
Variables in nonlocals sets are now ignored if they do not
appear in the goal itself, when discovering if a conjunct
consumes a variable.
compiler/prop_mode_constraints.m:
Implemented a HLDS tranformation that introduces unifications
to allow constraints based mode analysis to consider implied
modes in predicate calls.
tests/valid/Mmakefile:
Included some regression tests for these bugs, and some fairly
large modules that the analysis currently runs correctly on.
tests/valid/Mercury-options:
Included the option --prop-mode-constraints for the new tests.
tests/valid/mc_bag.m:
tests/valid/mc_graph.m:
Reasonably large tests taken and modified from the standard library
that the propagation solver approach to constraints based mode
analysis currently runs correctly on.
tests/valid/mc_extra_nonlocals.m:
tests/valid/mc_hhf_nonlocals_bug.m:
tests/valid/mc_implied_modes.m:
Small tests that used to fail under the above bugs.
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.255
diff -u -r1.255 handle_options.m
--- compiler/handle_options.m 13 Feb 2006 07:57:21 -0000 1.255
+++ compiler/handle_options.m 17 Feb 2006 01:57:47 -0000
@@ -905,8 +905,12 @@
true
),
+ option_implies(debug_mode_constraints, prop_mode_constraints,
+ bool(yes), !Globals),
option_implies(prop_mode_constraints, mode_constraints, bool(yes),
!Globals),
+ option_implies(simple_mode_constraints, mode_constraints, bool(yes),
+ !Globals),
% Minimal model tabling is not compatible with high level code
% or with trailing; see the comments in runtime/mercury_grade.h.
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.376
diff -u -r1.376 mercury_compile.m
--- compiler/mercury_compile.m 13 Feb 2006 03:47:42 -0000 1.376
+++ compiler/mercury_compile.m 17 Feb 2006 00:53:01 -0000
@@ -2238,8 +2238,8 @@
maybe_polymorphism(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 30, "polymorphism", !DumpInfo, !IO),
- maybe_mode_constraints(Verbose, Stats, !.HLDS, HHF_HLDS, !IO),
- maybe_dump_hlds(HHF_HLDS, 33, "mode_constraints", !DumpInfo, !IO),
+ maybe_mode_constraints(Verbose, Stats, !HLDS, !IO),
+ maybe_dump_hlds(!.HLDS, 33, "mode_constraints", !DumpInfo, !IO),
modecheck(Verbose, Stats, !HLDS, FoundModeError, UnsafeToContinue, !IO),
maybe_dump_hlds(!.HLDS, 35, "modecheck", !DumpInfo, !IO),
Index: compiler/mode_constraints.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_constraints.m,v
retrieving revision 1.20
diff -u -r1.20 mode_constraints.m
--- compiler/mode_constraints.m 10 Feb 2006 03:40:55 -0000 1.20
+++ compiler/mode_constraints.m 17 Feb 2006 05:19:02 -0000
@@ -109,12 +109,11 @@
module_info_predids(!.ModuleInfo, PredIds),
globals__io_lookup_bool_option(simple_mode_constraints, Simple, !IO),
globals__io_lookup_bool_option(prop_mode_constraints, New, !IO),
- list__foldl2(hhf__process_pred(Simple), PredIds, !ModuleInfo, !IO),
-
- get_predicate_sccs(!.ModuleInfo, SCCs),
(
New = no,
+ list__foldl2(hhf__process_pred(Simple), PredIds, !ModuleInfo, !IO),
+ get_predicate_sccs(!.ModuleInfo, SCCs),
% Stage 1: Process SCCs bottom-up to determine variable producers.
list__foldl3(process_scc(Simple), SCCs,
@@ -135,6 +134,15 @@
clear_caches(!IO)
;
New = yes,
+ get_predicate_sccs(!.ModuleInfo, SCCs),
+
+ % Preprocess to accomdate implied modes.
+ % XXX The following transformation adds more unifications
+ % than is neccessary - eg, for arguments that will eventually
+ % be `in' modes anyway. The resulting loosening of constraints
+ % makes analysis take up to twice as long. Therefore, a more
+ % subtle approach would likely become a significant optimization.
+ list.foldl(ensure_unique_arguments, PredIds, !ModuleInfo),
% Stage 1: Process SCCs bottom-up to determine constraints on
% variable producers and consumers.
Index: compiler/ordering_mode_constraints.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ordering_mode_constraints.m,v
retrieving revision 1.3
diff -u -r1.3 ordering_mode_constraints.m
--- compiler/ordering_mode_constraints.m 10 Feb 2006 03:40:55 -0000 1.3
+++ compiler/ordering_mode_constraints.m 17 Feb 2006 00:49:42 -0000
@@ -105,6 +105,7 @@
:- import_module check_hlds.mcsolver.
:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_goal.
+:- import_module hlds.goal_util.
:- import_module libs.compiler_util.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.error_util.
@@ -476,10 +477,10 @@
% make_conjuncts_nonlocal_repvars(PredId, Goals, RepvarMap)
%
- % The keys of RepvarMap are the program variables nonlocal
- % to Goals. Each is mapped to the mc_rep_var representation
- % of the proposition that it is produced at a Goal for every
- % Goal it is nonlocal to in Goals.
+ % The keys of RepvarMap are the program variables nonlocal to Goals that
+ % appear in goals. Each is mapped to the mc_rep_var representation of the
+ % proposition that it is produced at a Goal for every Goal it is nonlocal
+ % to in Goals.
%
:- pred make_conjuncts_nonlocal_repvars(pred_id::in, hlds_goals::in,
prog_var_at_conjuncts_map::out) is det.
@@ -495,14 +496,16 @@
make_conjunct_nonlocal_repvars(PredId, Goal, !RepvarMap) :-
GoalInfo = snd(Goal),
- goal_info_get_nonlocals(GoalInfo, NonLocals),
+ goal_info_get_nonlocals(GoalInfo, Nonlocals),
goal_info_get_goal_path(GoalInfo, GoalPath),
+ goal_util.goal_vars(Goal, VarsInGoal),
+ set.intersect(Nonlocals, VarsInGoal, NonlocalsInGoal),
set.fold(
(pred(NL::in, RMap0::in, RMap::out) is det :-
multi_map.set(RMap0, NL, NL `in` PredId `at` GoalPath, RMap)
),
- NonLocals, !RepvarMap).
+ NonlocalsInGoal, !RepvarMap).
%-----------------------------------------------------------------------------%
Index: compiler/prop_mode_constraints.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prop_mode_constraints.m,v
retrieving revision 1.7
diff -u -r1.7 prop_mode_constraints.m
--- compiler/prop_mode_constraints.m 6 Feb 2006 02:36:51 -0000 1.7
+++ compiler/prop_mode_constraints.m 17 Feb 2006 01:16:29 -0000
@@ -48,6 +48,15 @@
mc_var_info::in, mc_var_info::out, pred_constraints_map::in,
pred_constraints_map::out) is det.
+ % ensure_unique_arguments(PredId, !ModuleInfo)
+ %
+ % Creates variables and introduces unifications in predicate PredId where
+ % appropriate to ensure that no program variable is used as an argument of
+ % more than one predicate (including the head of the caller, PredId).
+ %
+:- pred ensure_unique_arguments(pred_id::in, module_info::in, module_info::out)
+ is det.
+
% Checks whether a predicate has been imported according to the
% status_is_imported pred in the hlds_pred module.
%
@@ -95,8 +104,11 @@
:- import_module robdd.
:- import_module set.
:- import_module sparse_bitset.
+:- import_module std_util.
:- import_module string.
:- import_module svmap.
+:- import_module svset.
+:- import_module svvarset.
:- import_module term.
:- import_module term_io.
:- import_module varset.
@@ -236,6 +248,247 @@
add_mode_decl_constraints(ModuleInfo, PredId, ProcId, ArgModes, Args,
!VarInfo, !PredConstraints).
+%----------------------------------------------------------------------------%
+
+ensure_unique_arguments(PredId, !ModuleInfo) :-
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
+ pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ clauses_info_clauses_only(ClausesInfo0, Clauses0),
+ clauses_info_varset(ClausesInfo0, Varset0),
+ clauses_info_vartypes(ClausesInfo0, Vartypes0),
+ clauses_info_headvars(ClausesInfo0, HeadVars),
+
+ SeenSoFar = set.from_list(HeadVars),
+ BodyGoals0 = list.map(func(X) = clause_body(X), Clauses0),
+ list.map_foldl3(ensure_unique_arguments_in_goal, BodyGoals0, BodyGoals,
+ SeenSoFar, _, Varset0, Varset, Vartypes0, Vartypes),
+
+ Clauses = list.map_corresponding(func(C, B) = C ^ clause_body := B,
+ Clauses0, BodyGoals),
+ some [!ClausesInfo] (
+ !:ClausesInfo = ClausesInfo0,
+ clauses_info_set_varset(Varset, !ClausesInfo),
+ clauses_info_set_vartypes(Vartypes, !ClausesInfo),
+ clauses_info_set_clauses(Clauses, !ClausesInfo),
+ pred_info_set_clauses_info(!.ClausesInfo, PredInfo0, PredInfo)
+ ),
+ module_info_set_pred_info(PredId, PredInfo, !ModuleInfo).
+
+ % ensure_unique_arguments_in_goal(!Goal, !SeenSoFar, !Varset,
+ % !Vartypes)
+ %
+ % Creates variables and introduces unifications in Goal, where appropriate,
+ % to ensure that no program variable in SeenSoFar is used as an argument in
+ % a predicate call and that no program variable is used as an argument for
+ % more than one predicate call.
+ % Created variables are added Varset, Vartypes and SeenSoFar. Variables
+ % used as arguments in predicate calls are added to SeenSoFar.
+ %
+:- pred ensure_unique_arguments_in_goal(hlds_goal::in, hlds_goal::out,
+ set(prog_var)::in, set(prog_var)::out, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out) is det.
+
+ensure_unique_arguments_in_goal(!.GoalExpr - !.GoalInfo,
+ !:GoalExpr - !:GoalInfo, !SeenSoFar, !Varset, !Vartypes) :-
+ (
+ !.GoalExpr = conj(Goals0),
+ list.map_foldl3(ensure_unique_arguments_in_goal, Goals0, Goals1,
+ !SeenSoFar, !Varset, !Vartypes),
+ flatten_conjunction(Goals1, Goals),
+ !:GoalExpr = conj(Goals)
+ ;
+ !.GoalExpr = call(CalleePredId, CalleeProcId, Args0, Builtin,
+ UnifyContext, SymName),
+ goal_info_get_context(!.GoalInfo, Context),
+ make_unifications(Context, Unifications, Args0, Args, !SeenSoFar,
+ !Varset, !Vartypes),
+ (
+ % No arguments changed.
+ Unifications = []
+ ;
+ % Some of the argument variables have been replaced.
+ % Need to put the call with its new args in a conjunction
+ % with the unifications.
+ Unifications = [_ | _],
+ CallGoalExpr = call(CalleePredId, CalleeProcId, Args, Builtin,
+ UnifyContext, SymName),
+ replace_call_with_conjunction(CallGoalExpr, Unifications,
+ Args, !:GoalExpr, !GoalInfo)
+ )
+
+ ;
+ !.GoalExpr = generic_call(Details, Args0, Modes, Determinism),
+ goal_info_get_context(!.GoalInfo, Context),
+ make_unifications(Context, Unifications, Args0, Args, !SeenSoFar,
+ !Varset, !Vartypes),
+ (
+ % No arguments changed.
+ Unifications = []
+ ;
+ % Some of the argument variables have been replaced.
+ % Need to put the call with its new args in a conjunction
+ % with the unifications.
+ Unifications = [_ | _],
+ CallGoalExpr = generic_call(Details, Args, Modes, Determinism),
+ replace_call_with_conjunction(CallGoalExpr, Unifications,
+ Args, !:GoalExpr, !GoalInfo)
+ )
+ ;
+ !.GoalExpr = switch(_SwitchVar, _CanFail, _Cases0),
+ unexpected(this_file, "switch")
+% Goals0 = list.map(hlds_goal, Cases0),
+% list.map_foldl2(ensure_unique_arguments_in_goal, Goals0, Goals,
+% !SeenSoFar, !Varset, !Vartypes),
+% Cases = list.map_corresponding('hlds_goal :=', Cases0, Goals),
+% !:GoalExpr = switch(SwitchVar, CanFail, Cases)
+ ;
+ !.GoalExpr = unify(_, _, _, _, _)
+ ;
+ !.GoalExpr = disj(Goals0),
+ list.map_foldl3(ensure_unique_arguments_in_goal, Goals0, Goals,
+ !SeenSoFar, !Varset, !Vartypes),
+ !:GoalExpr = disj(Goals)
+ ;
+ !.GoalExpr = not(Goal0),
+ ensure_unique_arguments_in_goal(Goal0, Goal, !SeenSoFar, !Varset,
+ !Vartypes),
+ !:GoalExpr = not(Goal)
+ ;
+ !.GoalExpr = scope(Reason, Goal0),
+ ensure_unique_arguments_in_goal(Goal0, Goal, !SeenSoFar, !Varset,
+ !Vartypes),
+ !:GoalExpr = scope(Reason, Goal)
+ ;
+ !.GoalExpr = if_then_else(ExistVars, Cond0, Then0, Else0),
+ ensure_unique_arguments_in_goal(Cond0, Cond, !SeenSoFar, !Varset,
+ !Vartypes),
+ ensure_unique_arguments_in_goal(Then0, Then, !SeenSoFar, !Varset,
+ !Vartypes),
+ ensure_unique_arguments_in_goal(Else0, Else, !SeenSoFar, !Varset,
+ !Vartypes),
+ !:GoalExpr = if_then_else(ExistVars, Cond, Then, Else)
+ ;
+ !.GoalExpr = foreign_proc(_, _, _, _, _, _)
+ ;
+ !.GoalExpr = par_conj(Goals0),
+ list.map_foldl3(ensure_unique_arguments_in_goal, Goals0, Goals,
+ !SeenSoFar, !Varset, !Vartypes),
+ !:GoalExpr = par_conj(Goals)
+ ;
+ !.GoalExpr = shorthand(_),
+ unexpected(this_file, "shorthand goal expression")
+ ).
+
+ % flatten_conjunction(!Goals) flattens the conjunction Goals - that
+ % is, moves the conjuncts from nested conjunctions into Goals.
+ %
+:- pred flatten_conjunction(hlds_goals::in, hlds_goals::out) is det.
+
+flatten_conjunction(!Goals) :-
+ list.foldr(add_to_conjunction, !.Goals, [], !:Goals).
+
+ % add_to_conjunction(Goal, !Goals) adds Goal to the front of
+ % the conjunction Goals. It keeps the conjunction flat, so
+ % nested conjunctions are scrapped and their conjuncts prepended
+ % to Goals.
+ %
+:- pred add_to_conjunction(hlds_goal::in, hlds_goals::in, hlds_goals::out)
+ is det.
+
+add_to_conjunction(Goal, !Goals) :-
+ ( Goal = conj(SubGoals) - _ ->
+ list.append(SubGoals, !Goals)
+ ;
+ list.cons(Goal, !Goals)
+ ).
+
+ % make_unifications(Context, MaybeUnifications, Args0, Args, !SeenSoFar,
+ % !Varset, !Vartypes)
+ %
+ % If any of the given arguments in Args0 is in SeenSoFar, creates a new
+ % argument (in Varset and Vartypes) to replace it (in Args), and generates
+ % a unification between new argument and old (with context Context).
+ %
+:- pred make_unifications(prog_context::in, hlds_goals::out,
+ list(prog_var)::in, list(prog_var)::out,
+ set(prog_var)::in, set(prog_var)::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.
+
+make_unifications(Context, Unifications, !Args, !SeenSoFar,
+ !Varset, !Vartypes) :-
+ list.map_foldl4(make_unification(Context), !Args,
+ [], Unifications, !SeenSoFar, !Varset, !Vartypes).
+
+ % make_unification(Context, Var0, Var, !Unifications, !SeenSoFar,
+ % !Varset, !Vartypes)
+ %
+ % If Var0 is in SeenSoFar, creates a new argument Var (in Varset and
+ % Vartypes), and generates a unification between Var0 and Var.
+ %
+:- pred make_unification(prog_context::in, prog_var::in, prog_var::out,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ set(prog_var)::in, set(prog_var)::out, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out) is det.
+
+make_unification(Context, Var0, Var, !Unifications, !SeenSoFar, !Varset,
+ !Vartypes) :-
+ ( set.contains(!.SeenSoFar, Var0) ->
+ %
+ % Make new variable.
+ %
+ OldVarName = varset.lookup_name(!.Varset, Var0),
+ OldVarType = map.lookup(!.Vartypes, Var0),
+ NewVarName = "Arg_" ++ OldVarName,
+ svvarset.new_uniquely_named_var(NewVarName, Var, !Varset),
+ svmap.set(Var, OldVarType, !Vartypes),
+ %
+ % Make new unification.
+ %
+ create_atomic_complicated_unification(Var0, var(Var), Context,
+ implicit("Making call arguments unique for constraints" ++
+ " based mode analysis"), [], purity_pure,
+ UnificationGoalExpr - UnificationGoalInfo0),
+ goal_info_set_nonlocals(set.from_list([Var0, Var]),
+ UnificationGoalInfo0, UnificationGoalInfo),
+ list.cons(UnificationGoalExpr - UnificationGoalInfo, !Unifications)
+ ;
+ Var = Var0
+ ),
+ svset.insert(Var, !SeenSoFar).
+
+ % replace_call_with_conjunction(NewCallGoalExpr, Unifications, NewArgs,
+ % GoalExpr, !GoalInfo)
+ %
+ % Makes a conjunction out of CallGoalExpr and Unifications - the
+ % conjunction becomes GoalExpr and the goal info for the conjunction
+ % becomes !:GoalInfo. Goal info for CallGoalExpr and GoalExpr is
+ % created with the assumption that GoalExpr replaces a call and that
+ % CallGoalExpr is that call with its arguments replaced by NewArgs
+ % (where Unifications contains unfications between old arguments
+ % and their new replacements).
+ %
+:- pred replace_call_with_conjunction(hlds_goal_expr::in, hlds_goals::in,
+ list(prog_var)::in, hlds_goal_expr::out,
+ hlds_goal_info::in, hlds_goal_info::out) is det.
+
+replace_call_with_conjunction(CallGoalExpr, Unifications, NewArgs, GoalExpr,
+ !GoalInfo) :-
+ CallGoalInfo0 = !.GoalInfo,
+ goal_info_get_context(CallGoalInfo0, Context),
+ goal_info_get_nonlocals(CallGoalInfo0, CallNonlocals0),
+ CallNonlocals = set.insert_list(CallNonlocals0, NewArgs),
+ goal_info_set_nonlocals(CallNonlocals, CallGoalInfo0, CallGoalInfo),
+ Goals = list.cons(CallGoalExpr - CallGoalInfo, Unifications),
+ %
+ % Create the new conjunction
+ %
+ GoalExpr = conj(Goals),
+ goal_info_init(!:GoalInfo),
+ goal_info_set_context(Context, !GoalInfo),
+ goal_info_set_nonlocals(CallNonlocals0, !GoalInfo).
+
+%----------------------------------------------------------------------------%
+
module_info_pred_status_is_imported(ModuleInfo, PredId) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
@@ -303,6 +556,12 @@
dump_constraints_and_annotations(ConstraintVarset, FormulaeAndAnnotations,
!IO).
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "prop_mode_constraints.m".
+
%----------------------------------------------------------------------------%
:- end_module prop_mode_constraints.
%----------------------------------------------------------------------------%
Index: tests/valid/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mercury.options,v
retrieving revision 1.27
diff -u -r1.27 Mercury.options
--- tests/valid/Mercury.options 13 Feb 2006 06:30:07 -0000 1.27
+++ tests/valid/Mercury.options 17 Feb 2006 06:27:09 -0000
@@ -83,6 +83,11 @@
MCFLAGS-lambda_inference = --infer-all
MCFLAGS-livevals_seq = -O5 --opt-space
MCFLAGS-loop_inv_bug = --common-struct --loop-invariants
+MCFLAGS-mc_bag = --prop-mode-constraints
+MCFLAGS-mc_extra_nonlocals = --prop-mode-constraints
+MCFLAGS-mc_graph = --prop-mode-constraints
+MCFLAGS-mc_hhf_nonlocals_bug = --prop-mode-constraints
+MCFLAGS-mc_implied_modes = --prop-mode-constraints
MCFLAGS-middle_rec_labels = --middle-rec
MCFLAGS-mostly_uniq_mode_inf = --infer-all
MCFLAGS-mpj6 = --infer-all
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.164
diff -u -r1.164 Mmakefile
--- tests/valid/Mmakefile 10 Feb 2006 05:00:05 -0000 1.164
+++ tests/valid/Mmakefile 17 Feb 2006 06:24:50 -0000
@@ -149,6 +149,11 @@
loop \
loop_in_disj \
loop_inv_bug \
+ mc_bag \
+ mc_extra_nonlocals \
+ mc_graph \
+ mc_hhf_nonlocals_bug \
+ mc_implied_modes \
merge_ground_any \
middle_rec_labels \
modes_bug \
Index: tests/valid/mc_bag.m
===================================================================
RCS file: tests/valid/mc_bag.m
diff -N tests/valid/mc_bag.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/mc_bag.m 17 Feb 2006 06:22:22 -0000
@@ -0,0 +1,564 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%---------------------------------------------------------------------------%
+% Copyright (C) 1994-1999, 2003-2005 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% file: mc_bag.m
+% An implementation of multisets. This is a copy of the standard library
+% module bag, and provides a reasonably large test case for the
+% propagation solver approach to constraints based mode analysis to be
+% run on.
+% main author: conway, crs.
+% stability: medium
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module mc_bag.
+
+:- interface.
+
+:- import_module assoc_list.
+:- import_module list.
+:- import_module set.
+
+:- type mc_bag(T).
+
+ % Create an empty mc_bag.
+ %
+:- pred mc_bag__init(mc_bag(T)::out) is det.
+:- func mc_bag__init = mc_bag(T).
+
+ % Insert a particular value in a mc_bag.
+ %
+:- pred mc_bag__insert(mc_bag(T)::in, T::in, mc_bag(T)::out) is det.
+:- func mc_bag__insert(mc_bag(T), T) = mc_bag(T).
+
+ % Insert a list of values into a mc_bag.
+ %
+:- pred mc_bag__insert_list(mc_bag(T)::in, list(T)::in, mc_bag(T)::out) is det.
+:- func mc_bag__insert_list(mc_bag(T), list(T)) = mc_bag(T).
+
+ % Insert a list of values into a mc_bag.
+ %
+:- pred mc_bag__insert_set(mc_bag(T)::in, set(T)::in, mc_bag(T)::out) is det.
+:- func mc_bag__insert_set(mc_bag(T), set(T)) = mc_bag(T).
+
+ % Make a mc_bag from a list.
+ %
+:- func mc_bag__mc_bag(list(T)) = mc_bag(T).
+:- pred mc_bag__from_list(list(T)::in, mc_bag(T)::out) is det.
+:- func mc_bag__from_list(list(T)) = mc_bag(T).
+
+ % Make a mc_bag from a set.
+ %
+:- pred mc_bag__from_set(set(T)::in, mc_bag(T)::out) is det.
+:- func mc_bag__from_set(set(T)) = mc_bag(T).
+
+ % Given a mc_bag, produce a sorted list containing all the values in
+ % the mc_bag. Each value will appear in the list the same number of
+ % times that it appears in the mc_bag.
+ %
+:- pred mc_bag__to_list(mc_bag(T)::in, list(T)::out) is det.
+:- func mc_bag__to_list(mc_bag(T)) = list(T).
+
+ % Given a mc_bag, produce a sorted list containing all the values
in the mc_bag.
+ % Each value will appear in the list once, with the associated integer
+ % giving the number of times that it appears in the mc_bag.
+ %
+:- pred mc_bag__to_assoc_list(mc_bag(T)::in, assoc_list(T, int)::out) is det.
+:- func mc_bag__to_assoc_list(mc_bag(T)) = assoc_list(T, int).
+
+ % Given a mc_bag, produce a sorted list with no duplicates containing
+ % all the values in the mc_bag.
+ %
+:- pred mc_bag__to_list_without_duplicates(mc_bag(T)::in, list(T)::out) is det.
+:- func mc_bag__to_list_without_duplicates(mc_bag(T)) = list(T).
+
+ % Given a mc_bag, produce a set containing all the values in the mc_bag.
+ %
+:- pred mc_bag__to_set_without_duplicates(mc_bag(T)::in, set(T)::out) is det.
+:- func mc_bag__to_set_without_duplicates(mc_bag(T)) = set(T).
+:- func mc_bag__to_set(mc_bag(T)) = set(T).
+
+ % Remove one occurrence of a particular value from a mc_bag.
+ % Fail if the item does not exist in the mc_bag.
+ %
+:- pred mc_bag__remove(mc_bag(T)::in, T::in, mc_bag(T)::out) is semidet.
+
+ % Remove one occurrence of a particular value from a mc_bag.
+ % Abort if the item does not exist in the mc_bag.
+ %
+:- pred mc_bag__det_remove(mc_bag(T)::in, T::in, mc_bag(T)::out) is det.
+:- func mc_bag__det_remove(mc_bag(T), T) = mc_bag(T).
+
+ % Remove a list of values from a mc_bag. Duplicates are removed
from the mc_bag
+ % the appropriate number of times. Fail if any of the items in the list
+ % do not exist in the mc_bag.
+ %
+ % This call is logically equivalent to:
+ %
+ % mc_bag__remove_list(Bag0, RemoveList, Bag) :-
+ % mc_bag__from_list(RemoveList, RemoveBag),
+ % mc_bag__is_submc_bag(RemoveBag, Bag0),
+ % mc_bag__subtract(Bag0, RemoveBag, Bag).
+ %
+:- pred mc_bag__remove_list(mc_bag(T)::in, list(T)::in,
mc_bag(T)::out) is semidet.
+
+ % Remove a list of values from a mc_bag. Duplicates are removed
from the mc_bag
+ % the appropriate number of times. Abort if any of the items in the list
+ % do not exist in the mc_bag.
+ %
+:- pred mc_bag__det_remove_list(mc_bag(T)::in, list(T)::in,
mc_bag(T)::out) is det.
+:- func mc_bag__det_remove_list(mc_bag(T), list(T)) = mc_bag(T).
+
+ % Remove a set of values from a mc_bag. Each value is removed once.
+ % Fail if any of the items in the set do not exist in the mc_bag.
+ %
+:- pred mc_bag__remove_set(mc_bag(T)::in, set(T)::in, mc_bag(T)::out)
is semidet.
+
+ % Remove a set of values from a mc_bag. Each value is removed once.
+ % Abort if any of the items in the set do not exist in the mc_bag.
+ %
+:- pred mc_bag__det_remove_set(mc_bag(T)::in, set(T)::in,
mc_bag(T)::out) is det.
+:- func mc_bag__det_remove_set(mc_bag(T), set(T)) = mc_bag(T).
+
+ % Delete one occurrence of a particular value from a mc_bag.
+ % If the key is not present, leave the mc_bag unchanged.
+ %
+:- pred mc_bag__delete(mc_bag(T)::in, T::in, mc_bag(T)::out) is det.
+:- func mc_bag__delete(mc_bag(T), T) = mc_bag(T).
+
+ % Remove all occurrences of a particular value from a mc_bag.
+ % Fail if the item does not exist in the mc_bag.
+ %
+:- pred mc_bag__remove_all(mc_bag(T)::in, T::in, mc_bag(T)::out) is semidet.
+
+:- func mc_bag__delete_all(mc_bag(T), T) = mc_bag(T).
+
+ % Delete all occurrences of a particular value from a mc_bag.
+ %
+:- pred mc_bag__delete_all(mc_bag(T)::in, T::in, mc_bag(T)::out) is det.
+
+ % Check whether a mc_bag contains a particular value.
+ %
+:- pred mc_bag__contains(mc_bag(T)::in, T::in) is semidet.
+
+ % Count how many occurrences of the value the mc_bag contains.
+ %
+:- pred mc_bag__count_value(mc_bag(T)::in, T::in, int::out) is det.
+:- func mc_bag__count_value(mc_bag(T), T) = int.
+
+ % mc_bag__subtract(Bag0, SubBag, Bag):
+ %
+ % Subtracts SubBag from Bag0 to produce Bag. Each element in SubBag is
+ % removed from Bag0 to produce Bag. If an element exists in SubBag,
+ % but not in Bag, then that element is not removed. An example:
+ % mc_bag__subtract({1, 1, 2, 2, 3 }, {1, 1, 2, 3, 3, 3}, {2}).
+ %
+:- pred mc_bag__subtract(mc_bag(T)::in, mc_bag(T)::in, mc_bag(T)::out) is det.
+:- func mc_bag__subtract(mc_bag(T), mc_bag(T)) = mc_bag(T).
+
+ % The third mc_bag is the union of the first 2 mc_bags,
+ % e.g. {1, 1, 2, 2} U {2, 2, 3, 3} = {1, 1, 2, 2, 2, 2, 3, 3}.
+ % If the two input mc_bags are known to be unequal in size, then making
+ % the first mc_bag the larger mc_bag will usually be more efficient.
+ %
+:- pred mc_bag__union(mc_bag(T)::in, mc_bag(T)::in, mc_bag(T)::out) is det.
+:- func mc_bag__union(mc_bag(T), mc_bag(T)) = mc_bag(T).
+
+ % The third mc_bag is the intersection of the first 2 mc_bags.
Every element
+ % in the third mc_bag exists in both of the first 2 mc_bags, e.g.
+ % mc_bag__intersect({1, 2, 2, 3, 3}, {2, 2, 3, 4}, {2, 2, 3}).
+ %
+:- pred mc_bag__intersect(mc_bag(T)::in, mc_bag(T)::in, mc_bag(T)::out) is det.
+:- func mc_bag__intersect(mc_bag(T), mc_bag(T)) = mc_bag(T).
+
+ % Fails if there is no intersection between the 2 mc_bags.
+ % mc_bag__intersect(A, B) :- mc_bag__intersect(A, B, C), not
mc_bag__is_empty(C).
+ %
+:- pred mc_bag__intersect(mc_bag(T)::in, mc_bag(T)::in) is semidet.
+
+ % The third mc_bag is the smallest mc_bag that has both the first
two mc_bags
+ % as submc_bags. If an element X is present N times in one of the first
+ % two mc_bags, X will be present at least N times in the third mc_bag.
+ % E.g. {1, 1, 2} upper_bound {2, 2, 3} = {1, 1, 2, 2, 3}.
+ % If the two input mc_bags are known to be unequal in size, then making
+ % the first mc_bag the larger mc_bag will usually be more efficient.
+ %
+:- pred mc_bag__least_upper_bound(mc_bag(T)::in, mc_bag(T)::in,
mc_bag(T)::out) is det.
+:- func mc_bag__least_upper_bound(mc_bag(T), mc_bag(T)) = mc_bag(T).
+
+ % Tests whether the first mc_bag is a submc_bag of the second.
+ % mc_bag__is_submc_bag(A, B) implies that every element in the mc_bag A
+ % is also in the mc_bag B. If an element is in mc_bag A multiple times,
+ % it must be in mc_bag B at least as many times.
+ % e.g. mc_bag__is_submc_bag({1, 1, 2}, {1, 1, 2, 2, 3}).
+ % e.g. mc_bag__is_submc_bag({1, 1, 2}, {1, 2, 3}) :- fail.
+ %
+:- pred mc_bag__is_submc_bag(mc_bag(T)::in, mc_bag(T)::in) is semidet.
+
+ % Check whether a mc_bag is empty.
+ %
+:- pred mc_bag__is_empty(mc_bag(T)::in) is semidet.
+
+ % Fails if the mc_bag is empty.
+ %
+:- pred mc_bag__remove_smallest(mc_bag(T)::in, T::out,
mc_bag(T)::out) is semidet.
+
+ % Compares the two mc_bags, and returns whether the first mc_bag is a
+ % subset (<), is equal (=), or is a superset (>) of the second.
+ % mc_bag__subset_compare(<, {apple, orange}, {apple, apple, orange}).
+ % mc_bag__subset_compare(=, {apple, orange}, {apple, orange}).
+ % mc_bag__subset_compare(>, {apple, apple, orange}, {apple, orange}).
+ % mc_bag__subset_compare(_, {apple, apple}, {orange, orange}) :- fail.
+ %
+:- pred mc_bag__subset_compare(comparison_result::out, mc_bag(T)::in,
mc_bag(T)::in)
+ is semidet.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module map.
+:- import_module require.
+:- import_module std_util.
+
+:- type mc_bag(T) == map(T, int).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__init(Bag) :-
+ map__init(Bag).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__insert(Bag0, Item, Bag) :-
+ ( map__search(Bag0, Item, Count0) ->
+ Count = Count0 + 1
+ ;
+ Count = 1
+ ),
+ map__set(Bag0, Item, Count, Bag).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__insert_list(Bag, [], Bag).
+mc_bag__insert_list(Bag0, [Item|Items], Bag) :-
+ mc_bag__insert(Bag0, Item, Bag1),
+ mc_bag__insert_list(Bag1, Items, Bag).
+
+mc_bag__insert_set(Bag0, Set, Bag) :-
+ set__to_sorted_list(Set, List),
+ % XXX We should exploit the sortedness of List.
+ mc_bag__insert_list(Bag0, List, Bag).
+
+mc_bag__from_list(List, Bag) :-
+ mc_bag__init(Bag0),
+ mc_bag__insert_list(Bag0, List, Bag).
+
+mc_bag__from_set(Set, Bag) :-
+ set__to_sorted_list(Set, List),
+ mc_bag__init(Bag0),
+ % XXX We should exploit the sortedness of List.
+ mc_bag__insert_list(Bag0, List, Bag).
+
+mc_bag__to_list(Bag, List) :-
+ map__to_assoc_list(Bag, AssocList),
+ mc_bag__to_list_2(AssocList, List).
+
+:- pred mc_bag__to_list_2(assoc_list(T, int)::in, list(T)::out) is det.
+
+mc_bag__to_list_2([], []).
+mc_bag__to_list_2([X - Int | Xs ], Out) :-
+ ( Int =< 0 ->
+ mc_bag__to_list_2(Xs, Out)
+ ;
+ NewInt = Int - 1,
+ mc_bag__to_list_2([X - NewInt | Xs], Out0),
+ Out = [X | Out0]
+ ).
+
+mc_bag__to_assoc_list(Bag, AssocList) :-
+ map__to_assoc_list(Bag, AssocList).
+
+mc_bag__to_list_without_duplicates(Bag, List) :-
+ map__keys(Bag, List).
+
+mc_bag__to_set_without_duplicates(Bag, Set) :-
+ map__keys(Bag, List),
+ set__sorted_list_to_set(List, Set).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__delete(Bag0, Item, Bag) :-
+ ( mc_bag__remove(Bag0, Item, Bag1) ->
+ Bag = Bag1
+ ;
+ Bag = Bag0
+ ).
+
+mc_bag__remove(Bag0, Item, Bag) :-
+ map__search(Bag0, Item, Count0),
+ ( Count0 > 1 ->
+ Count = Count0 - 1,
+ map__set(Bag0, Item, Count, Bag)
+ ;
+ map__delete(Bag0, Item, Bag)
+ ).
+
+mc_bag__det_remove(Bag0, Item, Bag) :-
+ ( mc_bag__remove(Bag0, Item, Bag1) ->
+ Bag = Bag1
+ ;
+ error("mc_bag__det_remove: Missing item in mc_bag.")
+ ).
+
+mc_bag__remove_list(Bag, [], Bag).
+mc_bag__remove_list(Bag0, [X | Xs], Bag) :-
+ mc_bag__remove(Bag0, X, Bag1),
+ mc_bag__remove_list(Bag1, Xs, Bag).
+
+mc_bag__det_remove_list(Bag0, List, Bag) :-
+ ( mc_bag__remove_list(Bag0, List, Bag1) ->
+ Bag = Bag1
+ ;
+ error("mc_bag__det_remove_list: Missing item in mc_bag.")
+ ).
+
+mc_bag__remove_set(Bag0, Set, Bag) :-
+ set__to_sorted_list(Set, List),
+ % XXX We should exploit the sortedness of List.
+ mc_bag__remove_list(Bag0, List, Bag).
+
+mc_bag__det_remove_set(Bag0, Set, Bag) :-
+ set__to_sorted_list(Set, List),
+ % XXX We should exploit the sortedness of List.
+ mc_bag__det_remove_list(Bag0, List, Bag).
+
+mc_bag__remove_all(Bag0, Item, Bag) :- % semidet
+ map__remove(Bag0, Item, _Val, Bag).
+
+mc_bag__delete_all(Bag0, Item, Bag) :- % det
+ map__delete(Bag0, Item, Bag).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__contains(Bag, Item) :-
+ map__contains(Bag, Item).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__count_value(Bag, Item, Count) :-
+ ( map__search(Bag, Item, Count0) ->
+ Count = Count0
+ ;
+ Count = 0
+ ).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__subtract(Bag0, SubBag, Bag) :-
+ ( map__remove_smallest(SubBag, SubKey, SubVal, SubBag0) ->
+ ( map__search(Bag0, SubKey, Val) ->
+ NewVal = Val - SubVal,
+ ( NewVal > 0 ->
+ map__det_update(Bag0, SubKey, NewVal, Bag1)
+ ;
+ map__det_remove(Bag0, SubKey, _Val, Bag1)
+ )
+ ;
+ Bag1 = Bag0
+ ),
+ mc_bag__subtract(Bag1, SubBag0, Bag)
+ ;
+ Bag = Bag0
+ ).
+
+mc_bag__union(A, B, Out) :-
+ ( map__remove_smallest(B, Key, BVal, B0) ->
+ ( map__search(A, Key, AVal) ->
+ NewVal = AVal + BVal,
+ map__det_update(A, Key, NewVal, A0)
+ ;
+ map__det_insert(A, Key, BVal, A0)
+ ),
+ mc_bag__union(A0, B0, Out)
+ ;
+ Out = A
+ ).
+
+mc_bag__intersect(A, B, Out) :-
+ mc_bag__init(Out0),
+ mc_bag__intersect_2(A, B, Out0, Out).
+
+:- pred mc_bag__intersect_2(mc_bag(T)::in, mc_bag(T)::in,
mc_bag(T)::in, mc_bag(T)::out)
+ is det.
+
+mc_bag__intersect_2(A, B, Out0, Out) :-
+ ( map__remove_smallest(A, Key, AVal,A0) ->
+ ( map__search(B, Key, BVal) ->
+ int__min(AVal, BVal, Val),
+ map__det_insert(Out0, Key, Val, Out1)
+ ;
+ Out1 = Out0
+ ),
+ mc_bag__intersect_2(A0, B, Out1, Out)
+ ;
+ Out = Out0
+ ).
+
+mc_bag__intersect(A, B) :-
+ map__remove_smallest(A, Key, _AVal,A0),
+ ( map__contains(B, Key) ->
+ true
+ ;
+ mc_bag__intersect(A0, B)
+ ).
+
+mc_bag__least_upper_bound(A, B, Out) :-
+ ( map__remove_smallest(B, Key, BVal, B0) ->
+ ( map__search(A, Key, AVal) ->
+ int__max(AVal, BVal, NewVal),
+ map__det_update(A, Key, NewVal, A0)
+ ;
+ map__det_insert(A, Key, BVal, A0)
+ ),
+ mc_bag__least_upper_bound(A0, B0, Out)
+ ;
+ Out = A
+ ).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__is_submc_bag(SubBag, BigBag) :-
+ mc_bag__subtract(SubBag, BigBag, SubBag0),
+ mc_bag__is_empty(SubBag0).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__is_empty(Bag) :-
+ map__is_empty(Bag).
+
+%---------------------------------------------------------------------------%
+
+mc_bag__remove_smallest(Bag0, Item, Bag) :-
+ map__remove_smallest(Bag0, Item, Val, Bag1),
+ ( Val > 1 ->
+ NewVal = Val - 1,
+ map__det_insert(Bag1, Item, NewVal, Bag)
+ ;
+ Bag = Bag1
+ ).
+
+ % compares the two mc_bags, and returns whether the first mc_bag is a
+ % subset (<), is equal (=), or is a superset (>) of the second
+ % mc_bag__subset_compare(<, {apple, orange}, {apple, apple, orange}).
+ % mc_bag__subset_compare(=, {apple, orange}, {apple, orange}).
+ % mc_bag__subset_compare(>, {apple, apple, orange}, {apple, orange}).
+ % mc_bag__subset_compare(_, {apple, apple}, {orange, orange}) :- fail.
+ % :- pred mc_bag__subset_compare(comparison_result, mc_bag(T), mc_bag(T)).
+ % :- mode mc_bag__subset_compare(out, in, in) is semidet.
+ %
+mc_bag__subset_compare(Res, A, B) :-
+ ( map__remove_smallest(A, Key, AVal, A0) ->
+ ( map__remove(B, Key, BVal, B0) ->
+ compare(ValRes, AVal, BVal),
+ (
+ ValRes = (>),
+ mc_bag__is_submc_bag(B0, A0),
+ Res = (>)
+ ;
+ ValRes = (=),
+ mc_bag__subset_compare(Res, A0, B0)
+ ;
+ ValRes = (<),
+ mc_bag__is_submc_bag(A0, B0),
+ Res = (<)
+ )
+ ;
+ % B is empty, but A is not
+ Res = (>)
+ )
+ ;
+ % A is empty
+ ( map__is_empty(B) ->
+ Res = (=)
+ ;
+ Res = (<)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% Ralph Becket <rwab1 at cl.cam.ac.uk> 29/04/99
+% Function forms added.
+
+mc_bag__init = B :-
+ mc_bag__init(B).
+
+mc_bag__insert(B1, X) = B2 :-
+ mc_bag__insert(B1, X, B2).
+
+mc_bag__insert_list(B1, Xs) = B2 :-
+ mc_bag__insert_list(B1, Xs, B2).
+
+mc_bag__insert_set(B1, Xs) = B2 :-
+ mc_bag__insert_set(B1, Xs, B2).
+
+mc_bag__from_list(Xs) = B :-
+ mc_bag__from_list(Xs, B).
+
+mc_bag__from_set(Xs) = B :-
+ mc_bag__from_set(Xs, B).
+
+mc_bag__to_list(B) = Xs :-
+ mc_bag__to_list(B, Xs).
+
+mc_bag__to_assoc_list(B) = AL :-
+ mc_bag__to_assoc_list(B, AL).
+
+mc_bag__to_list_without_duplicates(B) = Xs :-
+ mc_bag__to_list_without_duplicates(B, Xs).
+
+mc_bag__to_set_without_duplicates(B) = Xs :-
+ mc_bag__to_set_without_duplicates(B, Xs).
+
+mc_bag__det_remove(B1, X) = B2 :-
+ mc_bag__det_remove(B1, X, B2).
+
+mc_bag__det_remove_list(B1, Xs) = B2 :-
+ mc_bag__det_remove_list(B1, Xs, B2).
+
+mc_bag__det_remove_set(B1, Xs) = B2 :-
+ mc_bag__det_remove_set(B1, Xs, B2).
+
+mc_bag__delete(B1, X) = B2 :-
+ mc_bag__delete(B1, X, B2).
+
+mc_bag__delete_all(B1, X) = B2 :-
+ mc_bag__delete_all(B1, X, B2).
+
+mc_bag__count_value(B, X) = N :-
+ mc_bag__count_value(B, X, N).
+
+mc_bag__subtract(B1, B2) = B3 :-
+ mc_bag__subtract(B1, B2, B3).
+
+mc_bag__union(B1, B2) = B3 :-
+ mc_bag__union(B1, B2, B3).
+
+mc_bag__intersect(B1, B2) = B3 :-
+ mc_bag__intersect(B1, B2, B3).
+
+mc_bag__least_upper_bound(B1, B2) = B3 :-
+ mc_bag__least_upper_bound(B1, B2, B3).
+
+mc_bag__mc_bag(Xs) = mc_bag__from_list(Xs).
+
+mc_bag__to_set(B) = mc_bag__to_set_without_duplicates(B).
Index: tests/valid/mc_extra_nonlocals.m
===================================================================
RCS file: tests/valid/mc_extra_nonlocals.m
diff -N tests/valid/mc_extra_nonlocals.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/mc_extra_nonlocals.m 17 Feb 2006 06:22:22 -0000
@@ -0,0 +1,19 @@
+
+% This is a regression test. Some nonlocals sets in the compare predicate
+% generated for the polymorphic type below contained variables that
+% didn't appear in the goal. Constraints based mode analysis using the
+% propagation solve was incorrectly assuming that the goal consumed the
+% variable, and analysis was failing because of this.
+%
+% Constraints based mode analysis has been changed to ignore nonlocals
+% that don't appear in the goal, however the compare predicate for
+% this type may still have inaccurate nonlocals sets at the time of mode
+% analysis.
+
+:- module mc_extra_nonlocals.
+:- interface.
+
+:- type polymorphic(K)
+ ---> empty
+ ; node(polymorphic(K)).
+
Index: tests/valid/mc_graph.m
===================================================================
RCS file: tests/valid/mc_graph.m
diff -N tests/valid/mc_graph.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/mc_graph.m 17 Feb 2006 06:22:22 -0000
@@ -0,0 +1,395 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%---------------------------------------------------------------------------%
+% Copyright (C) 1994-1999, 2003, 2005 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%------------------------------------------------------------------------------%
+%
+% File: mc_graph.m.
+% Main author: conway.
+% Stability: low.
+%
+% This module defines a directed graph data type. The type graph(N, A)
+% stores information of type N in the nodes, and information of type A
+% in the arcs.
+% This is a modified copy of the standard library module graph, and provides
+% a reasonably large test case for the propagation solver approach to
+% constraints based mode analysis to be run on.
+%
+%------------------------------------------------------------------------------%
+%------------------------------------------------------------------------------%
+
+:- module mc_graph.
+
+:- interface.
+
+:- import_module list.
+:- import_module set.
+:- import_module std_util.
+
+ % mc_graph(Node, Arc) represents a directed mc_graph with information of
+ % type Node associated with each node, and information of type Arc
+ % associated with each arc.
+ %
+:- type mc_graph(N, A).
+
+:- type node(N).
+
+:- type arc(A).
+
+ % Lots of mc_graphs don't need to store anything in the arcs so here's
+ % a type equivalence that only has `real' information in the nodes.
+ %
+:- type mc_graph(N) == mc_graph(N, unit).
+
+:- type arc == arc(unit).
+
+ % mc_graph__init(Graph) binds Graph to an empty mc_graph
containing no nodes
+ % and no arcs. (The mc_graph contains a counter of the number of nodes
+ % allocated in it, so it is possible for a mc_graph to contain no nodes
+ % or arcs and still fail to unify with the binding of Graph from
+ % mc_graph__init.)
+ %
+:- pred mc_graph__init(mc_graph(N, A)::out) is det.
+:- func mc_graph__init = mc_graph(N, A).
+
+ % mc_graph__set_node(OldGraph, NodeInfo, Node, NewGraph) takes
+ % OldGraph and NodeInfo which is the information to be stored
+ % in a new node, and returns a key "Node" which refers to that
+ % node, and the new mc_graph NewGraph containing all of the nodes
+ % and arcs in OldGraph as well as the new node.
+ % It is possible to have two nodes in the mc_graph with the
+ % same information stored in them.
+ %
+ % This operation is O(lgN) for a mc_graph containing N nodes.
+ %
+:- pred mc_graph__set_node(mc_graph(N, A)::in, N::in, node(N)::out,
+ mc_graph(N, A)::out) is det.
+
+ % mc_graph__insert_node/4 is the same as mc_graph__set_node/4 except
+ % that if the information to be stored in the node is stored
+ % in another node, then the mc_graph__insert_node/4 fails.
+ %
+ % This operation is O(N) for a mc_graph containing N nodes since
+ % this predicate has to check that the node data isn't in an
+ % existing node.
+ %
+:- pred mc_graph__insert_node(mc_graph(N, A)::in, N::in, node(N)::out,
+ mc_graph(N, A)::out) is semidet.
+
+ % mc_graph__det_insert_node/4 is like mc_graph__insert_node, except
+ % that if the insertion would fail, it calls error/1.
+ %
+:- pred mc_graph__det_insert_node(mc_graph(N, A)::in, N::in, node(N)::out,
+ mc_graph(N, A)::out) is det.
+
+ % mc_graph__search_node(Graph, NodeInfo, Node) nondeterministically
+ % produces bindings of Node such that Node is a node in Graph
+ % that has the information NodeInfo attatched to it.
+ %
+ % This operation is O(lgN) for the first solution for a mc_graph
+ % containing N nodes.
+ %
+:- pred mc_graph__search_node(mc_graph(N, A)::in, N::in,
node(N)::out) is nondet.
+
+ % mc_graph__find_matching_nodes(Graph, NodeInfo, Nodes) takes a mc_graph
+ % Graph and the information NodeInfo and returns the set of nodes
+ % Nodes which have the information NodeInfo stored in them. (The set
+ % Nodes will of course be empty if there are no matching nodes.)
+ %
+ % This operation is O(NlgN) for a mc_graph containing N nodes.
+ %
+:- pred mc_graph__find_matching_nodes(mc_graph(N, A)::in, N::in,
set(node(N))::out)
+ is det.
+:- func mc_graph__find_matching_nodes(mc_graph(N, A), N) = set(node(N)).
+
+ % mc_graph__node_contents(Graph, Node, NodeInfo) takes Graph and
+ % Node and returns the information NodeInfo stored in Node.
+ %
+ % This operation is O(lgN) for a mc_graph containing N nodes.
+ %
+:- pred mc_graph__node_contents(mc_graph(N, A)::in, node(N)::in,
N::out) is det.
+:- func mc_graph__node_contents(mc_graph(N, A), node(N)) = N.
+
+ % mc_graph__successors(Graph, Node, Nodes) takes a mc_graph Graph and
+ % a node Node and returns the set of nodes Nodes that are reachable
+ % (directly - not transitively) from Node.
+ %
+ % This operation is O(NlgN) for a mc_graph containing N nodes.
+ %
+:- pred mc_graph__successors(mc_graph(N, A)::in, node(N)::in,
set(node(N))::out)
+ is det.
+:- func mc_graph__successors(mc_graph(N, A), node(N)) = set(node(N)).
+
+ % mc_graph__nodes(Graph, Nodes) binds Nodes to the set of nodes in Graph.
+ %
+:- pred mc_graph__nodes(mc_graph(N, A)::in, set(node(N))::out) is det.
+:- func mc_graph__nodes(mc_graph(N, A)) = set(node(N)).
+
+ % mc_graph__set_edge(OldGraph, Start, End, ArcInfo, Arc, NewGraph)
+ % takes a mc_graph OldGraph and adds an arc from Start to End with
+ % the information ArcInfo stored in it, and returns a key for
+ % that arc Arc, and the new mc_graph NewGraph.
+ % If an identical arc already exists then this operation has
+ % no effect.
+ %
+ % This operation is O(lgN+lgM) for a mc_graph with N nodes and M arcs.
+ %
+:- pred mc_graph__set_edge(mc_graph(N, A)::in, node(N)::in, node(N)::in, A::in,
+ arc(A)::out, mc_graph(N, A)::out) is det.
+
+ % mc_graph__insert_edge/6 is the same as mc_graph__set_edge/6 except that
+ % if an identical arc already exists in the mc_graph the operation fails.
+ % This is O(N) for a mc_graph with N edges between the two nodes.
+ %
+:- pred mc_graph__insert_edge(mc_graph(N, A)::in, node(N)::in,
node(N)::in, A::in,
+ arc(A)::out, mc_graph(N, A)::out) is semidet.
+
+ % mc_graph__det_insert_edge/6 is like mc_graph__insert_edge except
+ % than instead of failing, it calls error/1.
+ %
+:- pred mc_graph__det_insert_edge(mc_graph(N, A)::in, node(N)::in, node(N)::in,
+ A::in, arc(A)::out, mc_graph(N, A)::out) is det.
+
+ % mc_graph__arc_contents(Graph, Arc, Start, End, ArcInfo) takes a
+ % mc_graph Graph and an arc Arc and returns the start and end nodes
+ % and the information stored in that arc.
+ %
+:- pred mc_graph__arc_contents(mc_graph(N, A)::in, arc(A)::in,
+ node(N)::out, node(N)::out, A::out) is det.
+
+ % mc_graph__path(Graph, Start, End, Path) is true iff there is a path
+ % from the node Start to the node End in Graph that goes through
+ % the sequence of arcs Arcs.
+ % The algorithm will return paths containing at most one cycle.
+ %
+:- pred mc_graph__path(mc_graph(N, A), node(N), node(N), list(arc(A))).
+:- mode mc_graph__path(in, in, in, out) is nondet.
+:- mode mc_graph__path(in, in, out, out) is nondet.
+
+%------------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module counter.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+:- import_module require.
+:- import_module std_util.
+
+:- type mc_graph(N, A)
+ ---> mc_graph(
+ node_supply :: counter,
+ arc_supply :: counter,
+ node_map :: map(node(N), N),
+ arc_map :: map(arc(A), arc_info(N, A)),
+ edge_map :: map(node(N), map(arc(A), node(N)))
+ ).
+
+:- type node(N)
+ ---> node(int).
+
+:- type arc(A)
+ ---> arc(int).
+
+:- type arc_info(N, A)
+ ---> arc_info(node(N), node(N), A).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__init(Graph) :-
+ Graph = mc_graph(counter__init(0), counter__init(0), Nodes, Arcs, Edges),
+ map__init(Nodes),
+ map__init(Arcs),
+ map__init(Edges).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__set_node(!.G, NInfo, node(N), !:G) :-
+ NS0 = !.G ^ node_supply,
+ counter__allocate(N, NS0, NS),
+ !:G = !.G ^ node_supply := NS,
+
+ Nodes0 = !.G ^ node_map,
+ map__set(Nodes0, node(N), NInfo, Nodes),
+ !:G = !.G ^ node_map := Nodes,
+
+ Edges0 = !.G ^ edge_map,
+ map__init(EdgeMap),
+ map__set(Edges0, node(N), EdgeMap, Edges),
+ !:G = !.G ^ edge_map := Edges.
+
+mc_graph__det_insert_node(!.G, NInfo, N, !:G) :-
+ ( mc_graph__insert_node(!.G, NInfo, NPrime, !:G) ->
+ N = NPrime
+ ;
+ error("mc_graph__det_insert_node: node already exists.")
+ ).
+
+mc_graph__insert_node(!.G, NInfo, node(N), !:G) :-
+ % Make sure that the mc_graph doesn't contain NInfo already.
+ \+ map__member(!.G ^ node_map, _, NInfo),
+
+ NS0 = !.G ^ node_supply,
+ counter__allocate(N, NS0, NS),
+ !:G = !.G ^ node_supply := NS,
+
+ Nodes0 = !.G ^ node_map,
+ map__set(Nodes0, node(N), NInfo, Nodes),
+ !:G = !.G ^ node_map := Nodes,
+
+ Edges0 = !.G ^ edge_map,
+ map__init(EdgeSet),
+ map__set(Edges0, node(N), EdgeSet, Edges),
+ !:G = !.G ^ edge_map := Edges.
+
+%------------------------------------------------------------------------------%
+
+mc_graph__search_node(Graph, NodeInfo, Node) :-
+ NodeTable = Graph ^ node_map,
+ map__member(NodeTable, Node, NodeInfo).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__find_matching_nodes(Graph, NodeInfo, NodeSet) :-
+ NodeTable = Graph ^ node_map,
+% Higher order code removed here
+% solutions(mc_graph__select_node(NodeTable, NodeInfo), NodeList),
+ map.sorted_keys(NodeTable, AllNodes),
+ filter_node_info(NodeTable, NodeInfo, AllNodes, MatchingNodes),
+ set__sorted_list_to_set(MatchingNodes, NodeSet).
+
+ % filter_node_info(NodeTable, NodeInfo, Nodes, FilteredNodes)
+ %
+ % Succeeds where FilterNodes are those elements of Nodes for
+ % which the node info for them in NodeTable matches NodeInfo.
+ %
+:- pred filter_node_info(map(node(N), N)::in, N::in, list(node(N))::in,
+ list(node(N))::out) is det.
+
+filter_node_info(_, _, [], []).
+filter_node_info(NodeTable, NodeInfo, [Node | Nodes], FilteredNodes) :-
+ filter_node_info(NodeTable, NodeInfo, Nodes, FilteredNodes0),
+ ( map.search(NodeTable, Node, NodeInfo) ->
+ FilteredNodes = [Node | FilteredNodes0]
+ ;
+ FilteredNodes = FilteredNodes0
+ ).
+
+:- pred mc_graph__select_node(map(node(N), N)::in, N::in,
node(N)::out) is nondet.
+
+mc_graph__select_node(NodeTable, NodeInfo, Node) :-
+ map__member(NodeTable, Node, NodeInfo).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__node_contents(G, N, I) :-
+ map__lookup(G ^ node_map, N, I).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__successors(G, N, Ss) :-
+ map__lookup(G ^ edge_map, N, E),
+ map__values(E, SsList),
+ set__list_to_set(SsList, Ss).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__nodes(G, Ns) :-
+ map__keys(G ^ node_map, Ns1),
+ set__list_to_set(Ns1, Ns).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__set_edge(!.G, Start, End, Info, Arc, !:G) :-
+ AS0 = !.G ^ arc_supply,
+ counter__allocate(A, AS0, AS),
+ Arc = arc(A),
+ !:G = !.G ^ arc_supply := AS,
+
+ Arcs0 = !.G ^ arc_map,
+ map__set(Arcs0, Arc, arc_info(Start, End, Info), Arcs),
+ !:G = !.G ^ arc_map := Arcs,
+
+ Es0 = !.G ^ edge_map,
+ map__lookup(Es0, Start, EdgeMap0),
+ map__set(EdgeMap0, Arc, End, EdgeMap),
+ map__set(Es0, Start, EdgeMap, Es),
+ !:G = !.G ^ edge_map := Es.
+
+%------------------------------------------------------------------------------%
+
+mc_graph__det_insert_edge(!.G, Start, End, Info, Arc, !:G) :-
+ ( mc_graph__insert_edge(!.G, Start, End, Info, ArcPrime, !:G) ->
+ Arc = ArcPrime
+ ;
+ error("mc_graph__det_insert_edge: this edge is already in the
mc_graph.")
+ ).
+
+mc_graph__insert_edge(!.G, Start, End, Info, Arc, !:G) :-
+ AS0 = !.G ^ arc_supply,
+ counter__allocate(A, AS0, AS),
+ Arc = arc(A),
+ !:G = !.G ^ arc_supply := AS,
+
+ Arcs0 = !.G ^ arc_map,
+ map__insert(Arcs0, Arc, arc_info(Start, End, Info), Arcs),
+ !:G = !.G ^ arc_map := Arcs,
+
+ Es0 = !.G ^ edge_map,
+ map__lookup(Es0, Start, EdgeMap0),
+ map__set(EdgeMap0, Arc, End, EdgeMap),
+ map__set(Es0, Start, EdgeMap, Es),
+ !:G = !.G ^ edge_map := Es.
+
+%------------------------------------------------------------------------------%
+
+mc_graph__arc_contents(G, N, S, E, A) :-
+ map__lookup(G ^ arc_map, N, I),
+ I = arc_info(S, E, A).
+
+%------------------------------------------------------------------------------%
+
+mc_graph__path(G, S, E, Path) :-
+ mc_graph__path_2(G, S, E, [], Path).
+
+:- pred mc_graph__path_2(mc_graph(N, A), node(N), node(N),
+ list(node(N)), list(arc(A))).
+:- mode mc_graph__path_2(in, in, in, in, out) is nondet.
+:- mode mc_graph__path_2(in, in, out, in, out) is nondet.
+
+mc_graph__path_2(G, S, E, Nodes0, Path) :-
+ Es = G ^ edge_map,
+ map__lookup(Es, S, Arcs),
+ (
+ map__member(Arcs, A, E),
+ \+ list__member(E, Nodes0),
+ Path = [A]
+ ;
+ map__member(Arcs, A, N),
+ \+ list__member(N, Nodes0),
+ mc_graph__path_2(G, N, E, [N | Nodes0], Path0),
+ Path = [A | Path0]
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% Ralph Becket <rwab1 at cl.cam.ac.uk> 29/04/99
+% Functional forms added.
+
+mc_graph__init = G :-
+ mc_graph__init(G).
+
+mc_graph__find_matching_nodes(G, N) = S :-
+ mc_graph__find_matching_nodes(G, N, S).
+
+mc_graph__node_contents(G, N) = NI :-
+ mc_graph__node_contents(G, N, NI).
+
+mc_graph__successors(G, N) = S :-
+ mc_graph__successors(G, N, S).
+
+mc_graph__nodes(G) = S :-
+ mc_graph__nodes(G,S).
Index: tests/valid/mc_hhf_nonlocals_bug.m
===================================================================
RCS file: tests/valid/mc_hhf_nonlocals_bug.m
diff -N tests/valid/mc_hhf_nonlocals_bug.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/mc_hhf_nonlocals_bug.m 17 Feb 2006 06:35:54 -0000
@@ -0,0 +1,61 @@
+
+% This is a regression test. The transformation HHF was leaving inaccurate
+% nonlocals sets for some conjuncts in the insert_edge predicate, which
+% lead to the propagation solver approach to constraints based mode analysis
+% failing. The transformation still has the bug as this test is written,
+% it's just no longer used when the propagation solver is used.
+
+:- module mc_hhf_nonlocals_bug.
+
+:- interface.
+
+:- import_module std_util.
+
+:- type graph(N, A).
+
+:- type node(N).
+
+:- type arc(A).
+
+:- type graph(N) == graph(N, unit).
+
+:- type arc == arc(unit).
+
+:- pred mc_hhf_nonlocals_bug__insert_edge(graph(N, A)::in, node(N)::in,
+ node(N)::in, A::in, arc(A)::out, graph(N, A)::out) is semidet.
+
+%------------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module counter.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+
+:- type graph(N, A)
+ ---> graph(
+ arc_supply :: counter,
+ arc_map :: map(arc(A), arc_info(N, A)),
+ edge_map :: map(node(N), map(arc(A), node(N)))
+ ).
+
+:- type node(N)
+ ---> node(int).
+
+:- type arc(A)
+ ---> arc(int).
+
+:- type arc_info(N, A)
+ ---> arc_info(node(N), node(N), A).
+
+mc_hhf_nonlocals_bug__insert_edge(!.G, Start, End, Info, Arc, !:G) :-
+ AS0 = !.G ^ arc_supply,
+ counter__allocate(A, AS0, AS),
+ Arc = arc(A),
+ !:G = !.G ^ arc_supply := AS,
+
+ Arcs0 = !.G ^ arc_map,
+ map__insert(Arcs0, Arc, arc_info(Start, End, Info), Arcs),
+ !:G = !.G ^ arc_map := Arcs.
+
Index: tests/valid/mc_implied_modes.m
===================================================================
RCS file: tests/valid/mc_implied_modes.m
diff -N tests/valid/mc_implied_modes.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/mc_implied_modes.m 17 Feb 2006 06:22:22 -0000
@@ -0,0 +1,26 @@
+
+% This is a regression test. The propagation solver approach to constraints
+% based mode analysis was failing to consider implied modes and therefore
+% failing, because the `in' mode of foo implied X wouldn't be produced,
+% but the `out' mode of bar implied the call should produce it.
+
+:- module mc_implied_modes.
+
+:- interface.
+
+:- import_module int.
+
+:- pred foo(int::in, int::out) is nondet.
+
+:- implementation.
+
+foo(X, Y) :-
+ bar(X, Y).
+
+:- pred bar(int::out, int::out) is multi.
+
+bar(1, 1).
+bar(2, 2).
+bar(3, 3).
+bar(4, 4).
+
--------------------------------------------------------------------------
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