[m-rev.] for review: --inform-ite-instead-of-switch
Zoltan Somogyi
zs at csse.unimelb.edu.au
Fri Nov 23 15:55:14 AEDT 2007
For review by Julien.
Unlike most diffs, most parts of this one can be reviewed and committed
independently if needed.
Zoltan.
Add a new compiler option. --inform-ite-instead-of-switch. If this is enabled,
the compiler will generate informational messages about if-then-elses that
it thinks should be converted to switches for the sake of program reliability.
Act on the output generated by this option.
compiler/simplify.m:
Implement the new option.
Fix an old bug that could cause us to generate warnings about code
that was OK in one duplicated copy but not in another (where a switch
arm's code is duplicated due to the case being selected for more than
one cons_id).
compiler/options.m:
Add the new option.
Add a way to test for the bug fix in simplify.
doc/user_guide.tex:
Document the new option.
NEWS:
Mention the new option.
library/*.m:
mdbcomp/*.m:
browser/*.m:
compiler/*.m:
deep_profiler/*.m:
Convert if-then-elses to switches at most of the sites suggested by the
new option. At the remaining sites, switching to switches would have
nontrivial downsides. This typically happens with the switched-on type
has many functors, and we treat one or two specially (e.g. cons/2 in
the cons_id type).
Perform misc cleanups in the vicinity of the if-then-else to switch
conversions.
In a few cases, improve the error messages generated.
compiler/accumulator.m:
compiler/hlds_goal.m:
(Rename and) move insts for particular kinds of goal from
accumulator.m to hlds_goal.m, to allow them to be used in other
modules. Using these insts allowed us to eliminate some if-then-elses
entirely.
compiler/exprn_aux.m:
Instead of fixing some if-then-elses, delete the predicates containing
them, since they aren't used, and (as pointed out by the new option)
would need considerable other fixing if they were ever needed again.
compiler/lp_rational.m:
Add prefixes to the names of the function symbols on some types,
since without those prefixes, it was hard to figure out what type
the switch corresponding to an old if-then-else was switching on.
tests/invalid/reserve_tag.err_exp:
Expect a new, improved error message.
cvs diff: Diffing .
Index: NEWS
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/NEWS,v
retrieving revision 1.482
diff -u -r1.482 NEWS
--- NEWS 14 Nov 2007 03:45:04 -0000 1.482
+++ NEWS 23 Nov 2007 04:36:16 -0000
@@ -224,6 +224,11 @@
* A new option, `--generate-standalone-interface', simplifies the task
of calling Mercury procedures from programs written in other languages.
+* We have added new option, `--inform-ite-instead-of-switch'. If this is
+ enabled, the compiler will generate informational messages about
+ if-then-elses that it thinks should be converted to switches for the
+ sake of program reliability.
+
* We have removed support for Managed C++ as a foreign language for the IL
backend.
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/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
Index: browser/browse.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/browse.m,v
retrieving revision 1.72
diff -u -r1.72 browse.m
--- browser/browse.m 15 Oct 2007 04:27:22 -0000 1.72
+++ browser/browse.m 21 Nov 2007 13:15:28 -0000
@@ -5,11 +5,11 @@
% 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: browse.m.
% Author: aet.
% Stability: low.
-%
+%
% Implements a very simple term browser.
% There are a number of features that haven't been incorporated:
%
@@ -18,7 +18,7 @@
% - User preferences, which use the scripting language
% to allow user control beyond the provided defaults.
% - Node expansion and contraction in the style of Windows Explorer.
-%
+%
%---------------------------------------------------------------------------%
:- module mdb.browse.
@@ -1600,15 +1600,19 @@
split_dirs(Cs, Names) :-
takewhile(not_slash, Cs, NameCs, Rest),
string.from_char_list(NameCs, Name),
- ( NameCs = [] ->
+ (
+ NameCs = [],
Names = []
- ; Rest = [] ->
- Names = [Name]
- ; Rest = [_Slash | RestCs] ->
- split_dirs(RestCs, RestNames),
- Names = [Name | RestNames]
;
- error("split_dirs: software error")
+ NameCs = [_ | _],
+ (
+ Rest = [],
+ Names = [Name]
+ ;
+ Rest = [_Slash | RestCs],
+ split_dirs(RestCs, RestNames),
+ Names = [Name | RestNames]
+ )
).
:- pred not_slash(char::in) is semidet.
@@ -1654,11 +1658,13 @@
:- func dirs_to_string(list(dir)) = string.
dirs_to_string([]) = "".
-dirs_to_string([Dir | Dirs]) =
- ( Dirs = [] ->
- dir_to_string(Dir)
+dirs_to_string([Dir | Dirs]) = DirStr :-
+ (
+ Dirs = [],
+ DirStr = dir_to_string(Dir)
;
- dir_to_string(Dir) ++ "/" ++ dirs_to_string(Dirs)
+ Dirs = [_ | _],
+ DirStr = dir_to_string(Dir) ++ "/" ++ dirs_to_string(Dirs)
).
%---------------------------------------------------------------------------%
Index: browser/browser_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/browser_info.m,v
retrieving revision 1.34
diff -u -r1.34 browser_info.m
--- browser/browser_info.m 14 Aug 2007 05:24:47 -0000 1.34
+++ browser/browser_info.m 21 Nov 2007 13:16:17 -0000
@@ -778,9 +778,15 @@
maybe_set_param(no, _, _, _, _, _, !Params).
maybe_set_param(yes, F, Pr, V, NPr, Setting, !Params) :-
- ( Setting = setting_format(NewFormat) ->
+ (
+ Setting = setting_format(NewFormat),
!:Params = !.Params ^ default_format := NewFormat
;
+ ( Setting = setting_depth(_)
+ ; Setting = setting_width(_)
+ ; Setting = setting_lines(_)
+ ; Setting = setting_size(_)
+ ),
Format0 = !.Params ^ default_format,
FParams0 = !.Params ^ flat_params,
PrParams0 = !.Params ^ raw_pretty_params,
Index: browser/cterm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/cterm.m,v
retrieving revision 1.6
diff -u -r1.6 cterm.m
--- browser/cterm.m 24 Nov 2006 03:47:58 -0000 1.6
+++ browser/cterm.m 21 Nov 2007 13:13:54 -0000
@@ -5,14 +5,14 @@
% 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: cterm.m.
% Author: zs.
-%
+%
% This module provides a mechanism for matching terms from the running program
% against terms specified by debugger commands, which are implemented in C in
% runtime/mercury_trace_term.[ch].
-%
+%
%---------------------------------------------------------------------------%
:- module mdb.cterm.
@@ -86,7 +86,11 @@
match_with_cterms(UnivArgs, CArgs, Match) :-
( cterm_head_tail(CArgs, CHead, CTail) ->
- ( UnivArgs = [UnivHead | UnivTail] ->
+ (
+ UnivArgs = [],
+ Match = no
+ ;
+ UnivArgs = [UnivHead | UnivTail],
Head = univ_value(UnivHead),
match_with_cterm(Head, CHead, MatchHead),
(
@@ -96,13 +100,13 @@
MatchHead = yes,
match_with_cterms(UnivTail, CTail, Match)
)
- ;
- Match = no
)
;
- ( UnivArgs = [] ->
+ (
+ UnivArgs = [],
Match = yes
;
+ UnivArgs = [_ | _],
Match = no
)
).
Index: browser/declarative_analyser.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/declarative_analyser.m,v
retrieving revision 1.38
diff -u -r1.38 declarative_analyser.m
--- browser/declarative_analyser.m 27 Sep 2007 07:28:14 -0000 1.38
+++ browser/declarative_analyser.m 21 Nov 2007 13:19:53 -0000
@@ -352,13 +352,18 @@
!:Analyser = !.Analyser ^ fallback_search_mode := FallBackSearchMode,
!:Analyser = !.Analyser ^ search_mode := FallBackSearchMode,
!:Analyser = !.Analyser ^ last_search_question := no,
- ( FallBackSearchMode = analyser_divide_and_query(Weighting) ->
+ (
+ FallBackSearchMode = analyser_divide_and_query(Weighting),
SearchSpace0 = !.Analyser ^ search_space,
update_weighting_heuristic(Store, Weighting, SearchSpace0,
SearchSpace),
!:Analyser = !.Analyser ^ search_space := SearchSpace
;
- true
+ FallBackSearchMode = analyser_follow_subterm_end(_, _, _, _, _)
+ ;
+ FallBackSearchMode = analyser_binary(_, _, _)
+ ;
+ FallBackSearchMode = analyser_top_down
).
debug_analyser_state(Analyser, Analyser ^ debug_origin).
Index: browser/declarative_edt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/declarative_edt.m,v
retrieving revision 1.21
diff -u -r1.21 declarative_edt.m
--- browser/declarative_edt.m 27 Sep 2007 07:28:14 -0000 1.21
+++ browser/declarative_edt.m 21 Nov 2007 13:17:25 -0000
@@ -1299,9 +1299,18 @@
0, ChildrenOriginalWeight, 0, ChildrenExcess),
list.foldl(add_existing_weight, ChildrenSuspects,
0, ChildrenWeight),
- ( Status = suspect_ignored ->
+ (
+ Status = suspect_ignored,
Weight = ChildrenWeight + ChildrenExcess
;
+ ( Status = suspect_skipped(_)
+ ; Status = suspect_correct
+ ; Status = suspect_erroneous
+ ; Status = suspect_inadmissible
+ ; Status = suspect_pruned
+ ; Status = suspect_in_erroneous_subtree_complement
+ ; Status = suspect_unknown
+ ),
Weight = OriginalWeight - ChildrenOriginalWeight
+ ChildrenWeight + ChildrenExcess
)
Index: browser/declarative_execution.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/declarative_execution.m,v
retrieving revision 1.61
diff -u -r1.61 declarative_execution.m
--- browser/declarative_execution.m 12 Sep 2007 06:21:05 -0000 1.61
+++ browser/declarative_execution.m 21 Nov 2007 13:00:21 -0000
@@ -833,11 +833,9 @@
search_trace_node_store(_, _, _) :-
private_builtin.sorry("search_trace_node_store").
+ % Following are some predicates that are useful for manipulating
+ % the above instance in C code.
%
- % Following are some predicates that are useful for
- % manipulating the above instance in C code.
- %
-
:- func call_node_get_last_interface(trace_node(trace_node_id))
= trace_node_id.
:- pragma foreign_export("C", call_node_get_last_interface(in) = out,
Index: browser/declarative_oracle.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/declarative_oracle.m,v
retrieving revision 1.59
diff -u -r1.59 declarative_oracle.m
--- browser/declarative_oracle.m 12 Jun 2007 04:22:40 -0000 1.59
+++ browser/declarative_oracle.m 21 Nov 2007 13:01:54 -0000
@@ -257,9 +257,13 @@
User0 = Oracle0 ^ user_state,
user_confirm_bug(Bug, Confirmation, User0, User, !IO),
Oracle1 = Oracle0 ^ user_state := User,
- ( Confirmation = overrule_bug ->
+ (
+ Confirmation = overrule_bug,
list.foldl(revise_oracle, Evidence, Oracle1, Oracle)
;
+ ( Confirmation = confirm_bug
+ ; Confirmation = abort_diagnosis
+ ),
Oracle = Oracle1
).
@@ -597,17 +601,21 @@
assert_oracle_kb(wrong_answer(_, _, Atom), truth_value(_, Truth), !KB) :-
get_kb_ground_map(!.KB, Map0),
ProcLayout = Atom ^ final_atom ^ proc_layout,
- %
+
% Insert all modes for the atom if the atom is correct and just the
% one mode if it's not correct. In general we cannot insert all modes
% for erroneous or inadmissible atoms since the atom might be
% erroneous with respect to one mode, but inadmissible with respect to
% another mode.
- %
- ( Truth = truth_correct ->
+
+ (
+ Truth = truth_correct,
foldl(add_atom_to_ground_map(Truth, Atom),
get_all_modes_for_layout(ProcLayout), Map0, Map)
;
+ ( Truth = truth_erroneous
+ ; Truth = truth_inadmissible
+ ),
add_atom_to_ground_map(Truth, Atom, ProcLayout, Map0, Map)
),
set_kb_ground_map(Map, !KB).
Index: browser/declarative_tree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/browser/declarative_tree.m,v
retrieving revision 1.53
diff -u -r1.53 declarative_tree.m
--- browser/declarative_tree.m 12 Nov 2007 03:52:39 -0000 1.53
+++ browser/declarative_tree.m 21 Nov 2007 13:24:31 -0000
@@ -512,33 +512,16 @@
contour_children_2(ContourType, Store, NodeId, StartId, Ns0, Ns) :-
det_trace_node_from_id(Store, NodeId, Node),
(
- (
- Node = node_call(_, _, _, _, _, _, _, _, _, _)
- ;
- % A non-failed NEGE could be encountered when gathering
- % the children of an exception node, since the exception
- % may have been thrown inside the negation.
- (
- ContourType = normal,
- Node = node_neg(_, _, _)
- ;
- ContourType = exception,
- Node = node_neg(_, _, failed)
- )
- ;
- Node = node_cond(_, _, failed)
- )
- ->
+ Node = node_call(_, _, _, _, _, _, _, _, _, _),
throw(internal_error("contour_children_2",
"unexpected start of contour"))
;
- Node = node_exit(_, _, _, _, _, _, _, _)
- ->
+ Node = node_exit(_, _, _, _, _, _, _, _),
% Add a child for this node.
Ns1 = [dynamic(NodeId) | Ns0]
;
- Node = node_fail(_, CallId, _, _, _, _)
- ->
+ Node = node_fail(_, CallId, _, _, _, _),
+
% Fail events can be reached here if there were events missing
% due to a parent being shallow traced. In this case, we can't tell
% whether the call was in a negated context or backtracked over,
@@ -555,8 +538,8 @@
NestedStartId = Call ^ call_preceding,
stratum_children(Store, NodeId, NestedStartId, Ns0, Ns1)
;
- Node = node_neg_fail(Prec, NestedStartId, _)
- ->
+ Node = node_neg_fail(Prec, NestedStartId, _),
+
% There is a nested context. Neg_fail events can be reached here
% if there were events missing due to a parent being shallow traced.
% In this case, we can't tell whether the call was in a negated context
@@ -566,13 +549,12 @@
;
( Node = node_else(Prec, NestedStartId, _)
; Node = node_neg_succ(Prec, NestedStartId, _)
- )
- ->
+ ),
% There is a nested context.
stratum_children(Store, Prec, NestedStartId, Ns0, Ns1)
;
- Node = node_excp(_, CallId, _, _, _, _, _)
- ->
+ Node = node_excp(_, CallId, _, _, _, _, _),
+
% If the contour ends in an exception, then add this exception
% to the list of contour children and continue along the contour,
% since in this case we are only interested in nodes that caused
@@ -593,6 +575,14 @@
stratum_children(Store, NodeId, NestedStartId, Ns0, Ns1)
)
;
+ ( Node = node_redo(_, _, _, _, _)
+ ; Node = node_switch(_, _)
+ ; Node = node_first_disj(_, _)
+ ; Node = node_later_disj(_, _, _)
+ ; Node = node_then(_, _, _)
+ ),
+
+ % We skip neg_succ nodes for the same reason that we skip exit nodes
% This handles the following cases: redo, switch, first_disj,
% later_disj, and then. Also handles cond when the status is anything
% other than failed.
@@ -603,6 +593,40 @@
% how much of it was backtracked over.
Ns1 = Ns0
+ ;
+ Node = node_cond(_, _, CondStatus),
+ (
+ CondStatus = failed,
+ throw(internal_error("contour_children_2",
+ "unexpected start of contour"))
+ ;
+ ( CondStatus = succeeded
+ ; CondStatus = undecided
+ ),
+ Ns1 = Ns0
+ )
+ ;
+ Node = node_neg(_, _, NegStatus),
+ (
+ ContourType = normal,
+ throw(internal_error("contour_children_2",
+ "unexpected start of contour"))
+ ;
+ ContourType = exception,
+ (
+ NegStatus = failed,
+ throw(internal_error("contour_children_2",
+ "unexpected start of contour"))
+ ;
+ ( NegStatus = succeeded
+ ; NegStatus = undecided
+ ),
+ % A non-failed NEGE could be encountered when gathering
+ % the children of an exception node, since the exception
+ % may have been thrown inside the negation.
+ Ns1 = Ns0
+ )
+ )
),
Next = step_left_in_contour(Store, Node),
contour_children(ContourType, Store, Next, StartId, Ns1, Ns).
@@ -625,31 +649,25 @@
(
( Node = node_call(_, _, _, _, _, _, _, _, _, _)
; Node = node_neg(_, _, _)
- ; Node = node_cond(_, _, failed)
- )
- ->
+ ),
throw(internal_error("stratum_children_2",
"unexpected start of contour"))
;
( Node = node_fail(_, _, _, _, _, _)
; Node = node_excp(_, _, _, _, _, _, _)
- )
- ->
+ ),
% Add a child for this node.
Ns1 = [dynamic(NodeId) | Ns0]
;
- Node = node_neg_fail(Prec, NestedStartId, _)
- ->
+ Node = node_neg_fail(Prec, NestedStartId, _),
% There is a nested successful context.
contour_children(normal, Store, Prec, NestedStartId, Ns0, Ns1)
;
- Node = node_else(Prec, NestedStartId, _)
- ->
+ Node = node_else(Prec, NestedStartId, _),
% There is a nested failed context.
stratum_children(Store, Prec, NestedStartId, Ns0, Ns1)
;
- Node = node_exit(_, CallId, _, _, _, _, _, _)
- ->
+ Node = node_exit(_, CallId, _, _, _, _, _, _),
% Only include an exit node as a missing answer child if it
% produces output. If the exit event doesn't produce output
% then the only way the call could have behaved differently
@@ -663,13 +681,28 @@
Ns1 = [dynamic(NodeId) | Ns0]
)
;
- % This handles the following cases: redo, switch, first_disj,
- % later_disj, then and neg_succ. Also handles cond when the status is
- % anything other than failed. We skip neg_succ nodes for the same
- % reason that we skip exit nodes where there are no outputs (see
- % above).
-
+ ( Node = node_redo(_, _, _, _, _)
+ ; Node = node_switch(_, _)
+ ; Node = node_first_disj(_, _)
+ ; Node = node_later_disj(_, _, _)
+ ; Node = node_then(_, _, _)
+ ; Node = node_neg_succ(_, _, _)
+ ),
+ % We skip neg_succ nodes for the same reason that we skip exit nodes
+ % where there are no outputs (see above).
Ns1 = Ns0
+ ;
+ Node = node_cond(_, _, CondStatus),
+ (
+ ( CondStatus = succeeded
+ ; CondStatus = undecided
+ ),
+ Ns1 = Ns0
+ ;
+ CondStatus = failed,
+ throw(internal_error("stratum_children_2",
+ "unexpected start of contour"))
+ )
),
Next = step_in_stratum(Store, Node),
stratum_children(Store, Next, StartId, Ns1, Ns).
@@ -1022,12 +1055,11 @@
( Node = node_call(_, _, _, _, _, _, _, _, _, _) ->
ParentCallNode = Node
;
- %
% We wish to step through negated contexts, so we handle NEGE
% and COND events separately, since step_left_in_contour/2
% will throw an exception if it reaches the boundary of a
% negated context.
- %
+
( Node = node_neg(NegPrec, _, _) ->
PrevNodeId = NegPrec
; Node = node_cond(CondPrec, _, _) ->
@@ -1408,10 +1440,7 @@
;
% Perhaps this is a closure and the argument was passed in
% when the closure was created.
- (
- AtomicGoal =
- higher_order_call_rep(Closure, _)
- ->
+ ( AtomicGoal = higher_order_call_rep(Closure, _) ->
Var = Closure,
MaybePrims = yes(
primitive_list_and_var(Primitives0, Var, yes))
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/accumulator.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/accumulator.m,v
retrieving revision 1.70
diff -u -r1.70 accumulator.m
--- compiler/accumulator.m 27 Aug 2007 06:22:13 -0000 1.70
+++ compiler/accumulator.m 22 Nov 2007 01:56:22 -0000
@@ -1369,12 +1369,8 @@
%-----------------------------------------------------------------------------%
-:- inst plain_call
- ---> plain_call(ground, ground, ground, ground, ground, ground).
-:- inst hlds_plain_call
- ---> hlds_goal(plain_call, ground).
:- inst plain_call_goal
- ---> stored_goal(hlds_plain_call, ground).
+ ---> stored_goal(plain_call, ground).
% Do a goal_store_lookup where the result is known to be a call.
%
@@ -1540,14 +1536,13 @@
% to the accumulator version of the call, which can have the
% substitutions applied to it easily.
%
-:- func create_acc_call(hlds_goal::in(hlds_plain_call), prog_vars::in,
- pred_id::in, proc_id::in, sym_name::in) = (hlds_goal::out(hlds_plain_call))
+:- func create_acc_call(hlds_goal::in(plain_call), prog_vars::in,
+ pred_id::in, proc_id::in, sym_name::in) = (hlds_goal::out(plain_call))
is det.
create_acc_call(OrigCall, Accs, AccPredId, AccProcId, AccName) = Call :-
OrigCall = hlds_goal(OrigCallExpr, GoalInfo),
- OrigCallExpr = plain_call(_PredId, _ProcId, Args, Builtin,
- Context, _Name),
+ OrigCallExpr = plain_call(_PredId, _ProcId, Args, Builtin, Context, _Name),
CallExpr = plain_call(AccPredId, AccProcId, Accs ++ Args, Builtin,
Context, AccName),
Call = hlds_goal(CallExpr, GoalInfo).
Index: compiler/add_clause.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_clause.m,v
retrieving revision 1.46
diff -u -r1.46 add_clause.m
--- compiler/add_clause.m 19 Oct 2007 05:10:36 -0000 1.46
+++ compiler/add_clause.m 21 Nov 2007 09:18:46 -0000
@@ -128,9 +128,7 @@
)
;
% A promise will not have a corresponding pred declaration.
- (
- GoalType = goal_type_promise(_)
- ->
+ ( GoalType = goal_type_promise(_) ->
HeadVars = term.term_list_to_var_list(Args),
preds_add_implicit_for_assertion(HeadVars, !.ModuleInfo,
ModuleName, PredName, Arity, Status, Context, PredOrFunc,
@@ -183,93 +181,99 @@
true
),
(
- IllegalSVarResult = yes(StateVar)
- ->
+ IllegalSVarResult = yes(StateVar),
report_illegal_func_svar_result(Context, ClauseVarSet, StateVar,
!Specs)
;
- % User-supplied clauses for field access functions are not allowed
- % -- the clauses are always generated by the compiler.
- %
- PredOrFunc = pf_function,
- adjust_func_arity(pf_function, FuncArity, Arity),
- is_field_access_function_name(!.ModuleInfo, PredName, FuncArity,
- _, _),
-
- % Don't report errors for clauses for field access
- % function clauses in `.opt' files.
- Status \= status_opt_imported
- ->
- CallId = simple_call_id(PredOrFunc, PredName, Arity),
- MainPieces = [words("Error: clause for automatically generated"),
- words("field access"), simple_call(CallId), suffix("."), nl],
- VerbosePieces = [words("Clauses for field access functions"),
- words("are automatically generated by the compiler."),
- words("To supply your own definition for a field access"),
- words("function, for example to check the input"),
- words("to a field update, give the field"),
- words("of the constructor a different name.")],
- Msg = simple_msg(Context,
- [always(MainPieces), verbose_only(VerbosePieces)]),
- Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
- !:Specs = [Spec | !.Specs]
- ;
- pred_info_is_builtin(!.PredInfo)
- ->
- % When bootstrapping a change that redefines a builtin as
- % normal Mercury code, you may need to disable this action.
- Msg = simple_msg(Context,
- [always([words("Error: clause for builtin.")])]),
- Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
- !:Specs = [Spec | !.Specs]
- ;
- pred_info_get_clauses_info(!.PredInfo, Clauses0),
- pred_info_get_typevarset(!.PredInfo, TVarSet0),
- maybe_add_default_func_mode(!PredInfo, _),
- select_applicable_modes(Args, ClauseVarSet, Status, Context,
- PredId, !.PredInfo, ArgTerms, ProcIdsForThisClause,
- !ModuleInfo, !QualInfo, !Specs),
- clauses_info_add_clause(ProcIdsForThisClause, ClauseVarSet,
- TVarSet0, ArgTerms, Body, Context, Status, PredOrFunc, Arity,
- GoalType, Goal, VarSet, TVarSet, Clauses0, Clauses, Warnings,
- !ModuleInfo, !QualInfo, !Specs),
- pred_info_set_clauses_info(Clauses, !PredInfo),
- ( GoalType = goal_type_promise(PromiseType) ->
- pred_info_set_goal_type(goal_type_promise(PromiseType),
- !PredInfo)
- ;
- pred_info_update_goal_type(goal_type_clause, !PredInfo)
- ),
- pred_info_set_typevarset(TVarSet, !PredInfo),
- pred_info_get_arg_types(!.PredInfo, _ArgTVarSet, ExistQVars,
- ArgTypes),
- pred_info_set_arg_types(TVarSet, ExistQVars, ArgTypes, !PredInfo),
-
- %
- % Check if there are still no modes for the predicate, and if so,
- % set the `infer_modes' flag for that predicate.
- %
- ProcIds = pred_info_all_procids(!.PredInfo),
+ IllegalSVarResult = no,
(
- ProcIds = [],
- pred_info_get_markers(!.PredInfo, EndMarkers0),
- add_marker(marker_infer_modes, EndMarkers0, EndMarkers),
- pred_info_set_markers(EndMarkers, !PredInfo)
+ % User-supplied clauses for field access functions are not
+ % allowed -- the clauses are always generated by the compiler.
+ %
+ PredOrFunc = pf_function,
+ adjust_func_arity(pf_function, FuncArity, Arity),
+ is_field_access_function_name(!.ModuleInfo, PredName,
+ FuncArity, _, _),
+
+ % Don't report errors for clauses for field access
+ % function clauses in `.opt' files.
+ Status \= status_opt_imported
+ ->
+ CallId = simple_call_id(PredOrFunc, PredName, Arity),
+ MainPieces = [
+ words("Error: clause for automatically generated"),
+ words("field access"), simple_call(CallId),
+ suffix("."), nl],
+ VerbosePieces = [words("Clauses for field access functions"),
+ words("are automatically generated by the compiler."),
+ words("To supply your own definition for a field access"),
+ words("function, for example to check the input"),
+ words("to a field update, give the field"),
+ words("of the constructor a different name.")],
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
;
- ProcIds = [_ | _]
- ),
- map.det_update(Preds0, PredId, !.PredInfo, Preds),
- predicate_table_set_preds(Preds, !PredicateTable),
- module_info_set_predicate_table(!.PredicateTable, !ModuleInfo),
- ( Status = status_opt_imported ->
- true
+ pred_info_is_builtin(!.PredInfo)
+ ->
+ % When bootstrapping a change that redefines a builtin as
+ % normal Mercury code, you may need to disable this action.
+ Msg = simple_msg(Context,
+ [always([words("Error: clause for builtin.")])]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
;
- % Warn about singleton variables.
- SimpleCallId = simple_call_id(PredOrFunc, PredName, Arity),
- warn_singletons(VarSet, SimpleCallId, !.ModuleInfo, Goal,
- !Specs),
- % Warn about variables with overlapping scopes.
- warn_overlap(Warnings, VarSet, SimpleCallId, !Specs)
+ pred_info_get_clauses_info(!.PredInfo, Clauses0),
+ pred_info_get_typevarset(!.PredInfo, TVarSet0),
+ maybe_add_default_func_mode(!PredInfo, _),
+ select_applicable_modes(Args, ClauseVarSet, Status, Context,
+ PredId, !.PredInfo, ArgTerms, ProcIdsForThisClause,
+ !ModuleInfo, !QualInfo, !Specs),
+ clauses_info_add_clause(ProcIdsForThisClause, ClauseVarSet,
+ TVarSet0, ArgTerms, Body, Context, Status, PredOrFunc,
+ Arity, GoalType, Goal, VarSet, TVarSet, Clauses0, Clauses,
+ Warnings, !ModuleInfo, !QualInfo, !Specs),
+ pred_info_set_clauses_info(Clauses, !PredInfo),
+ ( GoalType = goal_type_promise(PromiseType) ->
+ pred_info_set_goal_type(goal_type_promise(PromiseType),
+ !PredInfo)
+ ;
+ pred_info_update_goal_type(goal_type_clause, !PredInfo)
+ ),
+ pred_info_set_typevarset(TVarSet, !PredInfo),
+ pred_info_get_arg_types(!.PredInfo, _ArgTVarSet, ExistQVars,
+ ArgTypes),
+ pred_info_set_arg_types(TVarSet, ExistQVars, ArgTypes,
+ !PredInfo),
+
+ % Check if there are still no modes for the predicate, and
+ % if so, set the `infer_modes' flag for that predicate.
+
+ ProcIds = pred_info_all_procids(!.PredInfo),
+ (
+ ProcIds = [],
+ pred_info_get_markers(!.PredInfo, EndMarkers0),
+ add_marker(marker_infer_modes, EndMarkers0, EndMarkers),
+ pred_info_set_markers(EndMarkers, !PredInfo)
+ ;
+ ProcIds = [_ | _]
+ ),
+ map.det_update(Preds0, PredId, !.PredInfo, Preds),
+ predicate_table_set_preds(Preds, !PredicateTable),
+ module_info_set_predicate_table(!.PredicateTable, !ModuleInfo),
+ ( Status = status_opt_imported ->
+ true
+ ;
+ % Warn about singleton variables.
+ SimpleCallId = simple_call_id(PredOrFunc, PredName, Arity),
+ warn_singletons(VarSet, SimpleCallId, !.ModuleInfo, Goal,
+ !Specs),
+ % Warn about variables with overlapping scopes.
+ warn_overlap(Warnings, VarSet, SimpleCallId, !Specs)
+ )
)
)
).
Index: compiler/add_heap_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_heap_ops.m,v
retrieving revision 1.35
diff -u -r1.35 add_heap_ops.m
--- compiler/add_heap_ops.m 7 Aug 2007 07:09:46 -0000 1.35
+++ compiler/add_heap_ops.m 21 Nov 2007 15:22:01 -0000
@@ -144,10 +144,9 @@
cases_add_heap_ops(Cases0, Cases, !Info).
goal_expr_add_heap_ops(negation(InnerGoal), OuterGoalInfo, Goal, !Info) :-
- %
% We handle negations by converting them into if-then-elses:
% not(G) ===> (if G then fail else true)
- %
+
Context = goal_info_get_context(OuterGoalInfo),
InnerGoal = hlds_goal(_, InnerGoalInfo),
Determinism = goal_info_get_determinism(InnerGoalInfo),
@@ -155,7 +154,8 @@
True = true_goal_with_context(Context),
Fail = fail_goal_with_context(Context),
ModuleInfo = !.Info ^ module_info,
- ( NumSolns = at_most_zero ->
+ (
+ NumSolns = at_most_zero,
% The "then" part of the if-then-else will be unreachable, but to
% preserve the invariants that the MLDS back-end relies on, we need to
% make sure that it can't fail. So we use a call to
@@ -164,6 +164,10 @@
generate_call("unused", detism_det, purity_pure, [], [],
ModuleInfo, Context, ThenGoal)
;
+ ( NumSolns = at_most_one
+ ; NumSolns = at_most_many
+ ; NumSolns = at_most_many_cc
+ ),
ThenGoal = Fail
),
NewOuterGoal = if_then_else([], InnerGoal, ThenGoal, True),
@@ -209,7 +213,8 @@
goal_expr_add_heap_ops(PragmaForeign, GoalInfo, Goal, !Info) :-
PragmaForeign = call_foreign_proc(_, _, _, _, _, _, Impl),
- ( Impl = fc_impl_model_non(_, _, _, _, _, _, _, _, _) ->
+ (
+ Impl = fc_impl_model_non(_, _, _, _, _, _, _, _, _),
% XXX Implementing heap reclamation for nondet pragma foreign_code
% via transformation is difficult, because there's nowhere in the HLDS
% pragma_foreign_code goal where we can insert the heap reclamation
@@ -223,6 +228,9 @@
SorryNotImplementedCode),
Goal = SorryNotImplementedCode
;
+ ( Impl = fc_impl_ordinary(_, _)
+ ; Impl = fc_impl_import(_, _, _, _)
+ ),
Goal = hlds_goal(PragmaForeign, GoalInfo)
).
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.72
diff -u -r1.72 add_pragma.m
--- compiler/add_pragma.m 16 Nov 2007 03:44:51 -0000 1.72
+++ compiler/add_pragma.m 21 Nov 2007 09:42:17 -0000
@@ -36,7 +36,7 @@
:- pred add_pragma_reserve_tag(sym_name::in, arity::in, import_status::in,
prog_context::in, module_info::in, module_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
-
+
:- pred add_pragma_foreign_export_enum(foreign_language::in, sym_name::in,
arity::in, export_enum_attributes::in, assoc_list(sym_name, string)::in,
import_status::in, prog_context::in, module_info::in, module_info::out,
@@ -235,9 +235,9 @@
% types).
Pragma = pragma_foreign_export_enum(_, _, _, _, _)
;
- % Likewise for pragma foreign_enum.
+ % Likewise for pragma foreign_enum.
Pragma = pragma_foreign_enum(_, _, _, _)
- ;
+ ;
% Handle pragma tabled decls later on (when we process clauses).
Pragma = pragma_tabled(_, _, _, _, _, _)
;
@@ -520,7 +520,7 @@
TypeCtor = type_ctor(TypeName, TypeArity),
module_info_get_type_table(!.ModuleInfo, Types0),
ContextPieces = [
- words("In"), fixed("`pragma reserve_tag'"), words("declaration for"),
+ words("In"), quote("pragma reserve_tag"), words("declaration for"),
sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
],
( map.search(Types0, TypeCtor, TypeDefn0) ->
@@ -538,46 +538,54 @@
->
MaybeSeverity = yes(severity_error),
ErrorPieces = [
- words("error: `reserve_tag' declaration must have"),
+ words("error:"), quote("pragma reserve_tag"),
+ words("declaration must have"),
words("the same visibility as the type definition.")
]
;
- TypeBody0 = hlds_du_type(Body, _CtorTags0, _IsEnum0,
- MaybeUserEqComp, ReservedTag0, _ReservedAddr, IsForeign)
- ->
(
- ReservedTag0 = uses_reserved_tag,
- % Make doubly sure that we don't get any spurious warnings
- % with intermodule optimization...
- TypeStatus \= status_opt_imported
- ->
- MaybeSeverity = yes(severity_warning),
+ TypeBody0 = hlds_du_type(Body, _CtorTags0, _IsEnum0,
+ MaybeUserEqComp, ReservedTag0, _ReservedAddr, IsForeign),
+ (
+ ReservedTag0 = uses_reserved_tag,
+ % Make doubly sure that we don't get any spurious warnings
+ % with intermodule optimization...
+ TypeStatus \= status_opt_imported
+ ->
+ MaybeSeverity = yes(severity_warning),
+ ErrorPieces = [
+ words("warning: multiple"),
+ quote("pragma reserved_tag"),
+ words("declarations for the same type.")
+ ]
+ ;
+ MaybeSeverity = no,
+ ErrorPieces = []
+ ),
+
+ % We passed all the semantic checks. Mark the type as having
+ % a reserved tag, and recompute the constructor tags.
+ ReservedTag = uses_reserved_tag,
+ module_info_get_globals(!.ModuleInfo, Globals),
+ assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor,
+ ReservedTag, Globals, CtorTags, ReservedAddr, EnumDummy),
+ TypeBody = hlds_du_type(Body, CtorTags, EnumDummy,
+ MaybeUserEqComp, ReservedTag, ReservedAddr, IsForeign),
+ hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
+ map.set(Types0, TypeCtor, TypeDefn, Types),
+ module_info_set_type_table(Types, !ModuleInfo)
+ ;
+ ( TypeBody0 = hlds_eqv_type(_)
+ ; TypeBody0 = hlds_foreign_type(_)
+ ; TypeBody0 = hlds_solver_type(_, _)
+ ; TypeBody0 = hlds_abstract_type(_)
+ ),
+ MaybeSeverity = yes(severity_error),
ErrorPieces = [
- words("warning: multiple"), fixed("`pragma reserved_tag'"),
- words("declarations for the same type.")
+ words("error:"), sym_name_and_arity(TypeName / TypeArity),
+ words("is not a discriminated union type."), nl
]
- ;
- MaybeSeverity = no,
- ErrorPieces = []
- ),
-
- % We passed all the semantic checks. Mark the type as having
- % a reserved tag, and recompute the constructor tags.
- ReservedTag = uses_reserved_tag,
- module_info_get_globals(!.ModuleInfo, Globals),
- assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor,
- ReservedTag, Globals, CtorTags, ReservedAddr, EnumDummy),
- TypeBody = hlds_du_type(Body, CtorTags, EnumDummy, MaybeUserEqComp,
- ReservedTag, ReservedAddr, IsForeign),
- hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
- map.set(Types0, TypeCtor, TypeDefn, Types),
- module_info_set_type_table(Types, !ModuleInfo)
- ;
- MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error:"), sym_name_and_arity(TypeName / TypeArity),
- words("is not a discriminated union type."), nl
- ]
+ )
)
;
MaybeSeverity = yes(severity_error),
@@ -612,7 +620,7 @@
words("declaration for"),
sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
],
- (
+ (
% Emit an error message for foreign_export_enum pragmas for the
% builtin atomic types.
TypeArity = 0,
@@ -632,7 +640,7 @@
;
( map.search(TypeDefnTable, TypeCtor, TypeDefn) ->
get_type_defn_body(TypeDefn, TypeBody),
- (
+ (
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_abstract_type(_)
; TypeBody = hlds_solver_type(_, _)
@@ -741,9 +749,9 @@
% Strip off module qualifiers that match those of the type
% being exported. We leave those that do not match so that
% they can be reported as errors later.
- %
+ %
StripQualifiers = (func(Name0) = Name :-
- (
+ (
Name0 = qualified(ModuleQualifier, UnqualName),
( ModuleQualifier = ModuleName ->
Name = unqualified(UnqualName)
@@ -772,7 +780,7 @@
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
!:Specs = [Spec | !.Specs]
).
-
+
:- pred build_export_enum_name_map(format_components::in,
foreign_language::in, sym_name::in, arity::in, prog_context::in,
string::in, map(sym_name, string)::in, list(constructor)::in,
@@ -781,14 +789,14 @@
build_export_enum_name_map(ContextPieces, Lang, TypeName, TypeArity,
Context, Prefix, Overrides0, Ctors, MaybeMapping, !Specs) :-
- (
+ (
TypeName = qualified(TypeModuleQual, _)
;
% The type name should have been module qualified by now.
TypeName = unqualified(_),
unexpected(this_file, "unqualified type name for foreign_export_enum")
),
-
+
list.foldl3(add_ctor_to_name_map(Lang, Prefix, TypeModuleQual),
Ctors, Overrides0, Overrides, map.init, NameMap, [], BadCtors),
%
@@ -864,16 +872,16 @@
[
always(ContextPieces ++ BadCtorsErrorPieces),
verbose_only(BadCtorsVerboseErrorPieces)
- ]),
+ ]),
BadCtorsSpec = error_spec(severity_error,
phase_parse_tree_to_hlds, [BadCtorsMsg]),
list.cons(BadCtorsSpec, !Specs),
MaybeMapping = no
)
).
-
+
% Check that the mapping from foreign names to Mercury names is not
- % one-to-many.
+ % one-to-many.
%
:- pred check_name_map_for_conflicts(prog_context::in, format_components::in,
map(sym_name, string)::in, maybe(map(sym_name, string))::out,
@@ -883,7 +891,7 @@
MaybeNameMap, !Specs) :-
NamesAndForeignNames = map.to_assoc_list(NameMap),
( bimap.from_assoc_list(NamesAndForeignNames, _) ->
- MaybeNameMap = yes(NameMap)
+ MaybeNameMap = yes(NameMap)
;
MaybeNameMap = no,
% XXX we should report exactly why it is not bijective.
@@ -894,7 +902,7 @@
Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
!:Specs = [Spec | !.Specs]
- ).
+ ).
% add_ctor_to_name_map(ForeignLanguage, Overrides, Prefix, Ctor, !Map,
% !BadCtors):
@@ -908,14 +916,14 @@
add_ctor_to_name_map(Lang, Prefix, _TypeModQual, Ctor, !Overrides, !NameMap,
!BadCtors) :-
CtorSymName = Ctor ^ cons_name,
- (
+ (
% All of the constructor sym_names should be module qualified by now.
% We unqualify them before inserting them into the mapping since
% the code in export.m expects that to be done.
%
CtorSymName = qualified(_, _),
UnqualCtorName = unqualify_name(CtorSymName),
- UnqualSymName = unqualified(UnqualCtorName)
+ UnqualSymName = unqualified(UnqualCtorName)
;
CtorSymName = unqualified(_),
unexpected(this_file, "unqualified constructor name")
@@ -931,7 +939,7 @@
ForeignName1 = UnqualCtorName
),
ForeignName = Prefix ++ ForeignName1,
- (
+ (
Lang = lang_c,
IsValidForeignName = pred_to_bool(is_valid_c_identifier(ForeignName))
;
@@ -949,7 +957,7 @@
IsValidForeignName = no,
list.cons(UnqualSymName, !BadCtors)
).
-
+
%-----------------------------------------------------------------------------%
add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues,
@@ -961,7 +969,7 @@
words("declaration for"),
sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
],
- (
+ (
% Emit an error message for foreign_enum pragmas for the
% builtin atomic types.
TypeArity = 0,
@@ -1013,7 +1021,7 @@
% module or they are both imported. Any other combination
% is illegal.
IsTypeLocal = status_defined_in_this_module(TypeStatus),
- (
+ (
(
IsTypeLocal = yes,
( ImportStatus = status_local
@@ -1035,7 +1043,7 @@
MaybeForeignTagMap = yes(ForeignTagMap)
->
map.foldl2(make_foreign_tag(Lang, ForeignTagMap),
- OldTagValues, map.init, TagValues, [],
+ OldTagValues, map.init, TagValues, [],
UnmappedCtors),
(
UnmappedCtors = [],
@@ -1050,7 +1058,7 @@
UnmappedCtors = [_ | _],
add_foreign_enum_unmapped_ctors_error(Context,
ContextPieces, UnmappedCtors, !Specs)
- )
+ )
;
% If there are no matching foreign_enum pragmas for
% this target language then don't do anything.
@@ -1103,7 +1111,7 @@
% will have already done so.
MaybeSeverity = no,
ErrorPieces = []
- ),
+ ),
(
ErrorPieces = []
;
@@ -1150,7 +1158,7 @@
% The constructor names we get from the parse tree may be unqualified
% but the ones we match against in the HLDS are not. Module qualify
- % them.
+ % them.
%
% XXX module_qual.m should really be doing this rather than add_pragma.m.
%
@@ -1186,7 +1194,7 @@
target_lang_to_foreign_enum_lang(target_java) = lang_java.
target_lang_to_foreign_enum_lang(target_asm) =
sorry(this_file, "pragma foreign_enum and --target `asm'.").
-target_lang_to_foreign_enum_lang(target_x86_64) =
+target_lang_to_foreign_enum_lang(target_x86_64) =
sorry(this_file, "pragma foreign_enum and --target `x86_64'.").
target_lang_to_foreign_enum_lang(target_erlang) = lang_erlang.
@@ -1237,7 +1245,7 @@
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
[Msg]),
list.cons(Spec, !Specs).
-
+
:- pred add_foreign_enum_bijection_error(prog_context::in,
format_components::in, list(error_spec)::in, list(error_spec)::out)
is det.
@@ -1251,7 +1259,7 @@
Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
list.cons(Spec, !Specs).
-
+
:- pred add_foreign_enum_pragma_in_interface_error(prog_context::in,
sym_name::in, arity::in, list(error_spec)::in, list(error_spec)::out)
is det.
@@ -1267,7 +1275,7 @@
Msg = simple_msg(Context, [always(ErrorPieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
list.cons(Spec, !Specs).
-
+
%-----------------------------------------------------------------------------%
:- pred add_pragma_unused_args(pred_or_func::in, sym_name::in, arity::in,
@@ -1580,100 +1588,104 @@
Types, ExistQVars, ClassContext, SubstOk, !ModuleInfo, !Specs) :-
assoc_list.keys(Subst, VarsToSub),
(
- Subst = []
- ->
+ Subst = [],
unexpected(this_file,
"handle_pragma_type_spec_subst: empty substitution")
;
+ Subst = [_ | _],
find_duplicate_list_elements(VarsToSub, MultiSubstVars0),
- MultiSubstVars0 = [_ | _]
- ->
- list.sort_and_remove_dups(MultiSubstVars0, MultiSubstVars),
- report_multiple_subst_vars(PredInfo0, Context, TVarSet0,
- MultiSubstVars, !Specs),
- ExistQVars = [],
- Types = [],
- ClassContext = constraints([], []),
- varset.init(TVarSet),
- SubstOk = no
- ;
- pred_info_get_typevarset(PredInfo0, CalledTVarSet),
- varset.create_name_var_map(CalledTVarSet, NameVarIndex0),
- list.filter((pred(Var::in) is semidet :-
- varset.lookup_name(TVarSet0, Var, VarName),
- \+ map.contains(NameVarIndex0, VarName)
- ), VarsToSub, UnknownVarsToSub),
- (
- UnknownVarsToSub = [],
- % Check that the substitution is not recursive.
- set.list_to_set(VarsToSub, VarsToSubSet),
-
- assoc_list.values(Subst, SubstTypes0),
- type_vars_list(SubstTypes0, TVarsInSubstTypes0),
- set.list_to_set(TVarsInSubstTypes0, TVarsInSubstTypes),
-
- set.intersect(TVarsInSubstTypes, VarsToSubSet, RecSubstTVars0),
- set.to_sorted_list(RecSubstTVars0, RecSubstTVars),
-
- (
- RecSubstTVars = [],
- map.init(TVarRenaming0),
- list.append(VarsToSub, TVarsInSubstTypes0, VarsToReplace),
-
- get_new_tvars(VarsToReplace, TVarSet0, CalledTVarSet, TVarSet,
- NameVarIndex0, _, TVarRenaming0, TVarRenaming),
-
- % Check that none of the existentially quantified variables
- % were substituted.
- map.apply_to_list(VarsToSub, TVarRenaming, RenamedVarsToSub),
- pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
- list.filter((pred(RenamedVar::in) is semidet :-
- list.member(RenamedVar, ExistQVars)
- ), RenamedVarsToSub, SubExistQVars),
+ (
+ MultiSubstVars0 = [_ | _],
+ list.sort_and_remove_dups(MultiSubstVars0, MultiSubstVars),
+ report_multiple_subst_vars(PredInfo0, Context, TVarSet0,
+ MultiSubstVars, !Specs),
+ ExistQVars = [],
+ Types = [],
+ ClassContext = constraints([], []),
+ varset.init(TVarSet),
+ SubstOk = no
+ ;
+ MultiSubstVars0 = [],
+ pred_info_get_typevarset(PredInfo0, CalledTVarSet),
+ varset.create_name_var_map(CalledTVarSet, NameVarIndex0),
+ list.filter((pred(Var::in) is semidet :-
+ varset.lookup_name(TVarSet0, Var, VarName),
+ \+ map.contains(NameVarIndex0, VarName)
+ ), VarsToSub, UnknownVarsToSub),
+ (
+ UnknownVarsToSub = [],
+ % Check that the substitution is not recursive.
+ set.list_to_set(VarsToSub, VarsToSubSet),
+
+ assoc_list.values(Subst, SubstTypes0),
+ type_vars_list(SubstTypes0, TVarsInSubstTypes0),
+ set.list_to_set(TVarsInSubstTypes0, TVarsInSubstTypes),
+
+ set.intersect(TVarsInSubstTypes, VarsToSubSet, RecSubstTVars0),
+ set.to_sorted_list(RecSubstTVars0, RecSubstTVars),
+
(
- SubExistQVars = [],
- map.init(TypeSubst0),
- apply_variable_renaming_to_type_list(TVarRenaming,
- SubstTypes0, SubstTypes),
- assoc_list.from_corresponding_lists(RenamedVarsToSub,
- SubstTypes, SubAL),
- list.foldl(map_set_from_pair, SubAL,
- TypeSubst0, TypeSubst),
-
- % Apply the substitution.
- pred_info_get_arg_types(PredInfo0, Types0),
- pred_info_get_class_context(PredInfo0, ClassContext0),
- apply_rec_subst_to_type_list(TypeSubst, Types0, Types),
- apply_rec_subst_to_prog_constraints(TypeSubst,
- ClassContext0, ClassContext),
- SubstOk = yes(TypeSubst)
+ RecSubstTVars = [],
+ map.init(TVarRenaming0),
+ list.append(VarsToSub, TVarsInSubstTypes0, VarsToReplace),
+
+ get_new_tvars(VarsToReplace, TVarSet0, CalledTVarSet,
+ TVarSet, NameVarIndex0, _,
+ TVarRenaming0, TVarRenaming),
+
+ % Check that none of the existentially quantified variables
+ % were substituted.
+ map.apply_to_list(VarsToSub, TVarRenaming,
+ RenamedVarsToSub),
+ pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
+ list.filter((pred(RenamedVar::in) is semidet :-
+ list.member(RenamedVar, ExistQVars)
+ ), RenamedVarsToSub, SubExistQVars),
+ (
+ SubExistQVars = [],
+ map.init(TypeSubst0),
+ apply_variable_renaming_to_type_list(TVarRenaming,
+ SubstTypes0, SubstTypes),
+ assoc_list.from_corresponding_lists(RenamedVarsToSub,
+ SubstTypes, SubAL),
+ list.foldl(map_set_from_pair, SubAL,
+ TypeSubst0, TypeSubst),
+
+ % Apply the substitution.
+ pred_info_get_arg_types(PredInfo0, Types0),
+ pred_info_get_class_context(PredInfo0, ClassContext0),
+ apply_rec_subst_to_type_list(TypeSubst, Types0, Types),
+ apply_rec_subst_to_prog_constraints(TypeSubst,
+ ClassContext0, ClassContext),
+ SubstOk = yes(TypeSubst)
+ ;
+ SubExistQVars = [_ | _],
+ report_subst_existq_tvars(PredInfo0, Context,
+ SubExistQVars, !Specs),
+ Types = [],
+ ClassContext = constraints([], []),
+ SubstOk = no
+ )
;
- SubExistQVars = [_ | _],
- report_subst_existq_tvars(PredInfo0, Context,
- SubExistQVars, !Specs),
+ RecSubstTVars = [_ | _],
+ report_recursive_subst(PredInfo0, Context, TVarSet0,
+ RecSubstTVars, !Specs),
+ ExistQVars = [],
Types = [],
ClassContext = constraints([], []),
+ varset.init(TVarSet),
SubstOk = no
)
;
- RecSubstTVars = [_ | _],
- report_recursive_subst(PredInfo0, Context, TVarSet0,
- RecSubstTVars, !Specs),
+ UnknownVarsToSub = [_ | _],
+ report_unknown_vars_to_subst(PredInfo0, Context, TVarSet0,
+ UnknownVarsToSub, !Specs),
ExistQVars = [],
Types = [],
ClassContext = constraints([], []),
varset.init(TVarSet),
SubstOk = no
)
- ;
- UnknownVarsToSub = [_ | _],
- report_unknown_vars_to_subst(PredInfo0, Context, TVarSet0,
- UnknownVarsToSub, !Specs),
- ExistQVars = [],
- Types = [],
- ClassContext = constraints([], []),
- varset.init(TVarSet),
- SubstOk = no
)
).
@@ -2657,10 +2669,14 @@
Statistics = table_gather_statistics,
AllowReset = table_allow_reset
),
- ( Strictness = specified(MaybeArgMethods, _HiddenArgMethod) ->
+ (
+ Strictness = specified(MaybeArgMethods, _HiddenArgMethod),
check_pred_args_against_tabling_methods(DeclaredArgModes,
MaybeArgMethods, !.ModuleInfo, 1, MaybeError)
;
+ ( Strictness = all_strict
+ ; Strictness = all_fast_loose
+ ),
check_pred_args_against_tabling(DeclaredArgModes, !.ModuleInfo,
1, MaybeError)
),
@@ -3301,7 +3317,7 @@
goal_info_set_purity(Purity, GoalInfo1, GoalInfo),
% XXX ARGVEC - the foreign_args field in the hlds_goal_expr type
% should also be a an proc_arg_vector rather than a list.
- HeadVarList = proc_arg_vector_to_list(HeadVars),
+ HeadVarList = proc_arg_vector_to_list(HeadVars),
make_foreign_args(HeadVarList, ArgInfo, OrigArgTypes, ForeignArgs),
% Perform some renaming in any user annotated sharing information.
maybe_rename_user_annotated_sharing_information(Globals,
@@ -3446,7 +3462,7 @@
% Just ignore the clause - if they are both for the same
% language then we emit an error message as well.
% XXX This won't detect multiple clauses in languages
- % that are not supported by this backend.
+ % that are not supported by this backend.
!:Action = ignore,
( OldLang = NewLang ->
PiecesA = [
Index: compiler/add_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pred.m,v
retrieving revision 1.32
diff -u -r1.32 add_pred.m
--- compiler/add_pred.m 17 Jul 2007 23:48:26 -0000 1.32
+++ compiler/add_pred.m 21 Nov 2007 09:25:43 -0000
@@ -420,15 +420,22 @@
PredModule = pred_info_module(!.PredInfo),
PredName = pred_info_name(!.PredInfo),
PredSymName = qualified(PredModule, PredName),
- ( IsClassMethod = yes ->
+ (
+ IsClassMethod = yes,
unspecified_det_for_method(PredSymName, Arity, PredOrFunc,
MContext, !Specs)
- ; status_is_exported(ImportStatus) = yes ->
- unspecified_det_for_exported(PredSymName, Arity, PredOrFunc,
- MContext, !Specs)
;
- unspecified_det_for_local(PredSymName, Arity, PredOrFunc,
- MContext, !Specs)
+ IsClassMethod = no,
+ IsExported = status_is_exported(ImportStatus),
+ (
+ IsExported = yes,
+ unspecified_det_for_exported(PredSymName, Arity, PredOrFunc,
+ MContext, !Specs)
+ ;
+ IsExported = no,
+ unspecified_det_for_local(PredSymName, Arity, PredOrFunc,
+ MContext, !Specs)
+ )
)
;
MaybeDet = yes(_)
Index: compiler/add_special_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_special_pred.m,v
retrieving revision 1.23
diff -u -r1.23 add_special_pred.m
--- compiler/add_special_pred.m 31 Oct 2007 13:27:23 -0000 1.23
+++ compiler/add_special_pred.m 21 Nov 2007 09:26:45 -0000
@@ -342,15 +342,24 @@
Context, Status0, !ModuleInfo) :-
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_bool_option(Globals, special_preds, GenSpecialPreds),
- ( GenSpecialPreds = yes ->
+ (
+ GenSpecialPreds = yes,
do_add_special_pred_decl_for_real(SpecialPredId,
TVarSet, Type, TypeCtor, Context, Status0, !ModuleInfo)
- ; SpecialPredId = spec_pred_unify ->
- add_special_pred_unify_status(TypeBody, Status0, Status),
- do_add_special_pred_decl_for_real(SpecialPredId, TVarSet,
- Type, TypeCtor, Context, Status, !ModuleInfo)
;
- true
+ GenSpecialPreds = no,
+ (
+ SpecialPredId = spec_pred_unify,
+ add_special_pred_unify_status(TypeBody, Status0, Status),
+ do_add_special_pred_decl_for_real(SpecialPredId, TVarSet,
+ Type, TypeCtor, Context, Status, !ModuleInfo)
+ ;
+ SpecialPredId = spec_pred_compare
+ ;
+ SpecialPredId = spec_pred_index
+ ;
+ SpecialPredId = spec_pred_init
+ )
).
do_add_special_pred_decl_for_real(SpecialPredId, TVarSet, Type, TypeCtor,
Index: compiler/add_trail_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_trail_ops.m,v
retrieving revision 1.47
diff -u -r1.47 add_trail_ops.m
--- compiler/add_trail_ops.m 7 Aug 2007 07:09:46 -0000 1.47
+++ compiler/add_trail_ops.m 21 Nov 2007 15:19:59 -0000
@@ -162,10 +162,9 @@
cases_add_trail_ops(Cases0, Cases, !Info).
goal_expr_add_trail_ops(negation(InnerGoal), OuterGoalInfo, Goal, !Info) :-
- %
% We handle negations by converting them into if-then-elses:
% not(G) ===> (if G then fail else true)
- %
+
Context = goal_info_get_context(OuterGoalInfo),
InnerGoal = hlds_goal(_, InnerGoalInfo),
Determinism = goal_info_get_determinism(InnerGoalInfo),
@@ -173,7 +172,8 @@
True = true_goal_with_context(Context),
Fail = fail_goal_with_context(Context),
ModuleInfo = !.Info ^ module_info,
- ( NumSolns = at_most_zero ->
+ (
+ NumSolns = at_most_zero,
% The "then" part of the if-then-else will be unreachable, but to
% preserve the invariants that the MLDS back-end relies on, we need to
% make sure that it can't fail. So we use a call to
@@ -183,6 +183,10 @@
generate_simple_call(PrivateBuiltin, "unused", pf_predicate, only_mode,
detism_det, purity_pure, [], [], [], ModuleInfo, Context, ThenGoal)
;
+ ( NumSolns = at_most_one
+ ; NumSolns = at_most_many
+ ; NumSolns = at_most_many_cc
+ ),
ThenGoal = Fail
),
NewOuterGoal = if_then_else([], InnerGoal, ThenGoal, True),
@@ -231,7 +235,8 @@
conj(plain_conj,
[Goal2, ResetTicketCommitGoal, PruneTicketsToGoal]),
OuterGoalInfo),
- ( OuterCodeModel = model_semi ->
+ (
+ OuterCodeModel = model_semi,
FailGoal = hlds_goal(_, FailGoalInfo),
FailCode = hlds_goal(
conj(plain_conj,
@@ -239,6 +244,9 @@
FailGoalInfo),
Goal3 = hlds_goal(disj([SuccCode, FailCode]), OuterGoalInfo)
;
+ ( OuterCodeModel = model_det
+ ; OuterCodeModel = model_non
+ ),
Goal3 = SuccCode
),
GoalExpr =
@@ -277,13 +285,17 @@
% Commit the trail ticket entries if the condition succeeds.
%
Then1 = hlds_goal(_, Then1GoalInfo),
- ( CondCodeModel = model_non ->
+ (
+ CondCodeModel = model_non,
gen_reset_ticket_solve(TicketVar, Context, ResetTicketSolveGoal,
!.Info),
Then = hlds_goal(
conj(plain_conj, [ResetTicketSolveGoal, Then1]),
Then1GoalInfo)
;
+ ( CondCodeModel = model_det
+ ; CondCodeModel = model_semi
+ ),
gen_reset_ticket_commit(TicketVar, Context, ResetTicketCommitGoal,
!.Info),
gen_prune_ticket(Context, PruneTicketGoal, !.Info),
Index: compiler/add_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_type.m,v
retrieving revision 1.29
diff -u -r1.29 add_type.m
--- compiler/add_type.m 14 Nov 2007 04:24:50 -0000 1.29
+++ compiler/add_type.m 21 Nov 2007 09:28:49 -0000
@@ -409,23 +409,24 @@
!:FoundError = !.FoundError `or` NewFoundError,
(
!.FoundError = yes
- ->
- true
- ;
- % Equivalence types are fully expanded on the IL and Java backends,
- % so the special predicates aren't required.
- are_equivalence_types_expanded(!.ModuleInfo),
- Body = hlds_eqv_type(_)
- ->
- true
;
- % XXX kind inference:
- % We set the kinds to `star'. This will be different when we have
- % a kind system.
- prog_type.var_list_to_type_list(map.init, Args, ArgTypes),
- construct_type(TypeCtor, ArgTypes, Type),
- add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
- !ModuleInfo)
+ !.FoundError = no,
+ (
+ % Equivalence types are fully expanded on the IL and Java backends,
+ % so the special predicates aren't required.
+ are_equivalence_types_expanded(!.ModuleInfo),
+ Body = hlds_eqv_type(_)
+ ->
+ true
+ ;
+ % XXX kind inference:
+ % We set the kinds to `star'. This will be different when we have
+ % a kind system.
+ prog_type.var_list_to_type_list(map.init, Args, ArgTypes),
+ construct_type(TypeCtor, ArgTypes, Type),
+ add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
+ !ModuleInfo)
+ )
).
% Check_foreign_type ensures that if we are generating code for a specific
@@ -752,9 +753,11 @@
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
!FieldNameTable, !Specs) :-
- ( FieldName = qualified(FieldModule0, _) ->
+ (
+ FieldName = qualified(FieldModule0, _),
FieldModule = FieldModule0
;
+ FieldName = unqualified(_),
unexpected(this_file, "add_ctor_field_name: unqualified field name")
),
(
Index: compiler/arg_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/arg_info.m,v
retrieving revision 1.57
diff -u -r1.57 arg_info.m
--- compiler/arg_info.m 7 Aug 2007 07:09:46 -0000 1.57
+++ compiler/arg_info.m 21 Nov 2007 08:25:22 -0000
@@ -191,9 +191,13 @@
% of this decision.)
%
make_arg_infos(ArgTypes, ArgModes, CodeModel, ModuleInfo, ArgInfo) :-
- ( CodeModel = model_semi ->
+ (
+ CodeModel = model_semi,
StartReg = 2
;
+ ( CodeModel = model_det
+ ; CodeModel = model_non
+ ),
StartReg = 1
),
make_arg_infos_list(ArgModes, ArgTypes, 1, StartReg, ModuleInfo, ArgInfo).
@@ -205,10 +209,14 @@
make_arg_infos_list([Mode | Modes], [Type | Types], !.InReg, !.OutReg,
ModuleInfo, [ArgInfo | ArgInfos]) :-
mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
- ( ArgMode = top_in ->
+ (
+ ArgMode = top_in,
ArgReg = !.InReg,
!:InReg = !.InReg + 1
;
+ ( ArgMode = top_out
+ ; ArgMode = top_unused
+ ),
ArgReg = !.OutReg,
!:OutReg = !.OutReg + 1
),
@@ -242,9 +250,13 @@
compute_in_and_out_vars_2(ModuleInfo, Vars,
Modes, Types, !:InVars, !:OutVars),
mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
- ( ArgMode = top_in ->
+ (
+ ArgMode = top_in,
!:InVars = [Var | !.InVars]
;
+ ( ArgMode = top_out
+ ; ArgMode = top_unused
+ ),
!:OutVars = [Var | !.OutVars]
).
@@ -285,10 +297,13 @@
input_args([], []).
input_args([arg_info(Loc, Mode) | Args], !:Locs) :-
input_args(Args, !:Locs),
- ( Mode = top_in ->
+ (
+ Mode = top_in,
!:Locs = [Loc | !.Locs]
;
- true
+ Mode = top_out
+ ;
+ Mode = top_unused
).
%---------------------------------------------------------------------------%
Index: compiler/basic_block.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/basic_block.m,v
retrieving revision 1.33
diff -u -r1.33 basic_block.m
--- compiler/basic_block.m 6 Jan 2007 09:23:24 -0000 1.33
+++ compiler/basic_block.m 21 Nov 2007 09:56:19 -0000
@@ -187,9 +187,11 @@
:- pred get_fallthrough_from_seq(list(label)::in, maybe(label)::out) is det.
get_fallthrough_from_seq(LabelSeq, MaybeFallThrough) :-
- ( LabelSeq = [NextLabel | _] ->
+ (
+ LabelSeq = [NextLabel | _],
MaybeFallThrough = yes(NextLabel)
;
+ LabelSeq = [],
MaybeFallThrough = no
).
Index: compiler/bytecode.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode.m,v
retrieving revision 1.72
diff -u -r1.72 bytecode.m
--- compiler/bytecode.m 2 Jul 2007 05:30:28 -0000 1.72
+++ compiler/bytecode.m 21 Nov 2007 06:15:08 -0000
@@ -165,7 +165,8 @@
output_bytecode_file(FileName, ByteCodes, !IO) :-
io.open_binary_output(FileName, Result, !IO),
- ( Result = ok(FileStream) ->
+ (
+ Result = ok(FileStream),
io.set_binary_output_stream(FileStream, OutputStream, !IO),
bytecode.version(Version),
output_short(Version, !IO),
@@ -173,6 +174,7 @@
io.set_binary_output_stream(OutputStream, _, !IO),
io.close_binary_output(FileStream, !IO)
;
+ Result = error(_),
io.progname_base("byte.m", ProgName, !IO),
io.write_string("\n", !IO),
io.write_string(ProgName, !IO),
@@ -184,7 +186,8 @@
debug_bytecode_file(FileName, ByteCodes, !IO) :-
io.open_output(FileName, Result, !IO),
- ( Result = ok(FileStream) ->
+ (
+ Result = ok(FileStream),
io.set_output_stream(FileStream, OutputStream, !IO),
bytecode.version(Version),
io.write_string("bytecode_version ", !IO),
@@ -194,6 +197,7 @@
io.set_output_stream(OutputStream, _, !IO),
io.close_output(FileStream, !IO)
;
+ Result = error(_),
io.progname_base("byte.m", ProgName, !IO),
io.write_string("\n", !IO),
io.write_string(ProgName, !IO),
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.115
diff -u -r1.115 bytecode_gen.m
--- compiler/bytecode_gen.m 11 Sep 2007 03:12:27 -0000 1.115
+++ compiler/bytecode_gen.m 21 Nov 2007 06:17:45 -0000
@@ -158,9 +158,13 @@
gen_places(OutputArgs, ByteInfo, PlaceCode),
% If semideterministic, reserve temp slot 0 for the return value
- ( CodeModel = model_semi ->
+ (
+ CodeModel = model_semi,
get_next_temp(_FrameTemp, ByteInfo1, ByteInfo2)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_non
+ ),
ByteInfo2 = ByteInfo1
),
@@ -180,10 +184,14 @@
proc_id_to_int(ProcId, ProcInt),
EnterCode = node([byte_enter_proc(ProcInt, Detism, LabelCount, EndLabel,
TempCount, VarInfos)]),
- ( CodeModel = model_semi ->
+ (
+ CodeModel = model_semi,
EndofCode = node([byte_semidet_succeed, byte_label(EndLabel),
byte_endof_proc])
;
+ ( CodeModel = model_det
+ ; CodeModel = model_non
+ ),
EndofCode = node([byte_label(EndLabel), byte_endof_proc])
),
Code = tree_list([EnterCode, BodyCode, EndofCode]).
@@ -206,10 +214,15 @@
(
GoalExpr = generic_call(GenericCallType,
ArgVars, ArgModes, Detism),
- ( GenericCallType = higher_order(PredVar, _, _, _) ->
+ (
+ GenericCallType = higher_order(PredVar, _, _, _),
gen_higher_order_call(PredVar, ArgVars, ArgModes, Detism,
!.ByteInfo, Code)
;
+ ( GenericCallType = class_method(_, _, _, _)
+ ; GenericCallType = cast(_)
+ ; GenericCallType = event_call(_)
+ ),
% XXX
% string.append_list([
% "bytecode for ", GenericCallFunctor, " calls"], Msg),
@@ -219,10 +232,14 @@
)
;
GoalExpr = plain_call(PredId, ProcId, ArgVars, BuiltinState, _, _),
- ( BuiltinState = not_builtin ->
+ (
+ BuiltinState = not_builtin,
Detism = goal_info_get_determinism(GoalInfo),
gen_call(PredId, ProcId, ArgVars, Detism, !.ByteInfo, Code)
;
+ ( BuiltinState = inline_builtin
+ ; BuiltinState = out_of_line_builtin
+ ),
gen_builtin(PredId, ProcId, ArgVars, !.ByteInfo, Code)
)
;
Index: compiler/call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/call_gen.m,v
retrieving revision 1.192
diff -u -r1.192 call_gen.m
--- compiler/call_gen.m 27 Sep 2007 10:42:04 -0000 1.192
+++ compiler/call_gen.m 21 Nov 2007 10:04:39 -0000
@@ -176,9 +176,13 @@
generic_call_info(Globals, GenericCall, length(InVars), CodeAddr,
SpecifierArgInfos, FirstImmInput, HoCallVariant),
determinism_to_code_model(Det, CodeModel),
- ( CodeModel = model_semi ->
+ (
+ CodeModel = model_semi,
FirstOutput = 2
;
+ ( CodeModel = model_det
+ ; CodeModel = model_non
+ ),
FirstOutput = 1
),
@@ -540,13 +544,17 @@
find_nonlive_outputs([], _, NonLiveOutputs, NonLiveOutputs).
find_nonlive_outputs([Var - arg_info(_ArgLoc, Mode) | Args],
Liveness, NonLiveOutputs0, NonLiveOutputs) :-
- ( Mode = top_out ->
+ (
+ Mode = top_out,
( set.member(Var, Liveness) ->
NonLiveOutputs1 = NonLiveOutputs0
;
set.insert(NonLiveOutputs0, Var, NonLiveOutputs1)
)
;
+ ( Mode = top_in
+ ; Mode = top_unused
+ ),
NonLiveOutputs1 = NonLiveOutputs0
),
find_nonlive_outputs(Args, Liveness, NonLiveOutputs1, NonLiveOutputs).
@@ -673,9 +681,17 @@
code_info::in, code_info::out) is det.
generate_builtin_arg(Rval0, Rval, Code, !CI) :-
- ( Rval0 = var(Var) ->
+ (
+ Rval0 = var(Var),
produce_variable(Var, Code, Rval, !CI)
;
+ ( Rval0 = const(_)
+ ; Rval0 = unop(_, _)
+ ; Rval0 = binop(_, _, _)
+ ; Rval0 = mkword(_, _)
+ ; Rval0 = mem_addr(_)
+ ; Rval0 = lval(_)
+ ),
Rval = Rval0,
Code = empty
).
@@ -686,18 +702,26 @@
input_arg_locs([], []).
input_arg_locs([Var - arg_info(Loc, Mode) | Args], Vs) :-
input_arg_locs(Args, Vs0),
- ( Mode = top_in ->
+ (
+ Mode = top_in,
Vs = [Var - Loc | Vs0]
;
+ ( Mode = top_out
+ ; Mode = top_unused
+ ),
Vs = Vs0
).
output_arg_locs([], []).
output_arg_locs([Var - arg_info(Loc, Mode) | Args], Vs) :-
output_arg_locs(Args, Vs0),
- ( Mode = top_out ->
+ (
+ Mode = top_out,
Vs = [Var - Loc | Vs0]
;
+ ( Mode = top_in
+ ; Mode = top_unused
+ ),
Vs = Vs0
).
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.116
diff -u -r1.116 check_typeclass.m
--- compiler/check_typeclass.m 14 Nov 2007 04:00:05 -0000 1.116
+++ compiler/check_typeclass.m 22 Nov 2007 08:00:00 -0000
@@ -1576,11 +1576,16 @@
check_ctor_constraints(TypeTable, TypeCtor, !ModuleInfo, !Specs) :-
map.lookup(TypeTable, TypeCtor, TypeDefn),
get_type_defn_body(TypeDefn, Body),
- ( Body = hlds_du_type(Ctors, _, _, _, _, _, _) ->
+ (
+ Body = hlds_du_type(Ctors, _, _, _, _, _, _),
list.foldl2(check_ctor_type_ambiguities(TypeCtor, TypeDefn), Ctors,
!ModuleInfo, !Specs)
;
- true
+ ( Body = hlds_eqv_type(_)
+ ; Body = hlds_foreign_type(_)
+ ; Body = hlds_solver_type(_, _)
+ ; Body = hlds_abstract_type(_)
+ )
).
:- pred check_ctor_type_ambiguities(type_ctor::in, hlds_type_defn::in,
@@ -1787,27 +1792,27 @@
InstanceTypes),
HeaderPieces =
[words("In instance declaration for"),
- words("`" ++ ClassNameString ++
- "(" ++ InstanceTypesString ++ ")':"),
+ words("`" ++ ClassNameString ++ "(" ++ InstanceTypesString ++ ")':"),
words("multiple implementations of type class"),
p_or_f(PredOrFunc), words("method"),
sym_name_and_arity(MethodName / Arity), suffix("."), nl],
HeadingMsg = simple_msg(InstanceContext, [always(HeaderPieces)]),
- ( MatchingInstanceMethods = [FirstInstance0 | LaterInstances0] ->
- FirstInstance = FirstInstance0,
- LaterInstances = LaterInstances0
+ (
+ MatchingInstanceMethods = [FirstInstance | LaterInstances]
;
+ MatchingInstanceMethods = [],
unexpected(this_file, "no matching instances")
),
FirstInstanceContext = FirstInstance ^ instance_method_decl_context,
FirstPieces = [words("First definition appears here."), nl],
FirstMsg = simple_msg(FirstInstanceContext, [always(FirstPieces)]),
- DefnToMsg = (pred(Definition::in, Msg::out) is det :-
- TheContext = Definition ^ instance_method_decl_context,
- SubsequentPieces =
- [words("Subsequent definition appears here."), nl],
- Msg = simple_msg(TheContext, [always(SubsequentPieces)])
- ),
+ DefnToMsg =
+ (pred(Definition::in, Msg::out) is det :-
+ TheContext = Definition ^ instance_method_decl_context,
+ SubsequentPieces =
+ [words("Subsequent definition appears here."), nl],
+ Msg = simple_msg(TheContext, [always(SubsequentPieces)])
+ ),
list.map(DefnToMsg, LaterInstances, LaterMsgs),
Spec = error_spec(severity_error, phase_type_check,
Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.80
diff -u -r1.80 clause_to_proc.m
--- compiler/clause_to_proc.m 7 Aug 2007 07:09:47 -0000 1.80
+++ compiler/clause_to_proc.m 21 Nov 2007 07:02:39 -0000
@@ -199,8 +199,7 @@
SingleGoal = hlds_goal(SingleExpr, _),
(
SingleExpr = call_foreign_proc(_, _, _, Args, ExtraArgs,
- MaybeTraceRuntimeCond, _)
- ->
+ MaybeTraceRuntimeCond, _),
% Use the original variable names for the headvars of foreign_proc
% clauses, not the introduced `HeadVar__n' names.
VarSet = list.foldl(set_arg_names, Args, VarSet0),
@@ -209,6 +208,17 @@
expect(unify(MaybeTraceRuntimeCond, no), this_file,
"copy_clauses_to_proc: trace runtime cond")
;
+ ( SingleExpr = plain_call(_, _, _, _, _, _)
+ ; SingleExpr = generic_call(_, _, _, _)
+ ; SingleExpr = unify(_, _, _, _, _)
+ ; SingleExpr = conj(_, _)
+ ; SingleExpr = disj(_)
+ ; SingleExpr = switch(_, _, _)
+ ; SingleExpr = if_then_else(_,_, _, _)
+ ; SingleExpr = negation(_)
+ ; SingleExpr = scope(_, _)
+ ; SingleExpr = shorthand(_)
+ ),
VarSet = VarSet0
),
Goal = SingleGoal
@@ -223,10 +233,12 @@
% mode declaration.
%
goal_info_init(GoalInfo0),
- ( GoalList = [FirstGoal | _] ->
+ (
+ GoalList = [FirstGoal | _],
FirstGoal = hlds_goal(_, FirstGoalInfo),
Context = goal_info_get_context(FirstGoalInfo)
;
+ GoalList = [],
proc_info_get_context(!.Proc, Context)
),
goal_info_set_context(Context, GoalInfo0, GoalInfo1),
Index: compiler/code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.173
diff -u -r1.173 code_gen.m
--- compiler/code_gen.m 7 Aug 2007 07:09:47 -0000 1.173
+++ compiler/code_gen.m 21 Nov 2007 10:17:23 -0000
@@ -89,17 +89,23 @@
CodeModel = model_det
;
CodeModel = model_semi,
- ( ContextModel \= model_det ->
- true
- ;
+ (
+ ContextModel = model_det,
unexpected(this_file, "semidet model in det context")
+ ;
+ ( ContextModel = model_semi
+ ; ContextModel = model_non
+ )
)
;
CodeModel = model_non,
- ( ContextModel = model_non ->
- true
- ;
+ (
+ ( ContextModel = model_det
+ ; ContextModel = model_semi
+ ),
unexpected(this_file, "nondet model in det/semidet context")
+ ;
+ ContextModel = model_non
)
),
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.352
diff -u -r1.352 code_info.m
--- compiler/code_info.m 19 Nov 2007 06:36:23 -0000 1.352
+++ compiler/code_info.m 21 Nov 2007 10:16:07 -0000
@@ -1531,70 +1531,84 @@
FailInfo = fail_info(ResumePoints, ResumeKnown, CurfrMaxfr, CondEnv,
Allow),
(
- CodeModel \= model_non
- ->
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
HijackInfo = disj_no_hijack,
Code = node([
llds_instr(comment("disj no hijack"), "")
])
;
- CondEnv = inside_non_condition
- ->
- HijackInfo = disj_temp_frame,
- create_temp_frame(do_fail, "prepare for disjunction", Code, !CI)
- ;
- Allow = not_allowed
- ->
+ CodeModel = model_non,
(
- CurfrMaxfr = must_be_equal,
- ResumeKnown = resume_point_known(has_been_done),
- stack.pop(ResumePoints, TopResumePoint, RestResumePoints),
- stack.is_empty(RestResumePoints),
- TopResumePoint = stack_only(_, do_fail)
- ->
- HijackInfo = disj_quarter_hijack,
- Code = node([
- llds_instr(comment("disj quarter hijack of do_fail"), "")
- ])
- ;
+ CondEnv = inside_non_condition,
HijackInfo = disj_temp_frame,
create_temp_frame(do_fail, "prepare for disjunction", Code, !CI)
+ ;
+ CondEnv = not_inside_non_condition,
+ (
+ Allow = not_allowed,
+ (
+ CurfrMaxfr = must_be_equal,
+ ResumeKnown = resume_point_known(has_been_done),
+ stack.pop(ResumePoints, TopResumePoint, RestResumePoints),
+ stack.is_empty(RestResumePoints),
+ TopResumePoint = stack_only(_, do_fail)
+ ->
+ HijackInfo = disj_quarter_hijack,
+ Code = node([
+ llds_instr(comment("disj quarter hijack of do_fail"),
+ "")
+ ])
+ ;
+ HijackInfo = disj_temp_frame,
+ create_temp_frame(do_fail, "prepare for disjunction", Code,
+ !CI)
+ )
+ ;
+ Allow = allowed,
+ (
+ CurfrMaxfr = must_be_equal,
+ (
+ ResumeKnown = resume_point_known(has_been_done),
+ HijackInfo = disj_quarter_hijack,
+ Code = node([
+ llds_instr(comment("disj quarter hijack"), "")
+ ])
+ ;
+ ( ResumeKnown = resume_point_known(wont_be_done)
+ ; ResumeKnown = resume_point_unknown
+ ),
+ acquire_temp_slot(slot_lval(redoip_slot(lval(curfr))),
+ non_persistent_temp_slot, RedoipSlot, !CI),
+ HijackInfo = disj_half_hijack(RedoipSlot),
+ Code = node([
+ llds_instr(assign(RedoipSlot,
+ lval(redoip_slot(lval(curfr)))),
+ "prepare for half disj hijack")
+ ])
+ )
+ ;
+ CurfrMaxfr = may_be_different,
+ acquire_temp_slot(slot_lval(redoip_slot(lval(maxfr))),
+ non_persistent_temp_slot, RedoipSlot, !CI),
+ acquire_temp_slot(slot_lval(redofr_slot(lval(maxfr))),
+ non_persistent_temp_slot, RedofrSlot, !CI),
+ HijackInfo = disj_full_hijack(RedoipSlot, RedofrSlot),
+ Code = node([
+ llds_instr(
+ assign(RedoipSlot, lval(redoip_slot(lval(maxfr)))),
+ "prepare for full disj hijack"),
+ llds_instr(
+ assign(RedofrSlot, lval(redofr_slot(lval(maxfr)))),
+ "prepare for full disj hijack"),
+ llds_instr(
+ assign(redofr_slot(lval(maxfr)), lval(curfr)),
+ "prepare for full disj hijack")
+ ])
+ )
+ )
)
- ;
- CurfrMaxfr = must_be_equal,
- ResumeKnown = resume_point_known(has_been_done)
- ->
- HijackInfo = disj_quarter_hijack,
- Code = node([
- llds_instr(comment("disj quarter hijack"), "")
- ])
- ;
- CurfrMaxfr = must_be_equal
- ->
- % Here ResumeKnown must be resume_point_unknown
- % or resume_point_known(wont_be_done).
- acquire_temp_slot(slot_lval(redoip_slot(lval(curfr))),
- non_persistent_temp_slot, RedoipSlot, !CI),
- HijackInfo = disj_half_hijack(RedoipSlot),
- Code = node([
- llds_instr(assign(RedoipSlot, lval(redoip_slot(lval(curfr)))),
- "prepare for half disj hijack")
- ])
- ;
- % Here CurfrMaxfr must be may_be_different.
- acquire_temp_slot(slot_lval(redoip_slot(lval(maxfr))),
- non_persistent_temp_slot, RedoipSlot, !CI),
- acquire_temp_slot(slot_lval(redofr_slot(lval(maxfr))),
- non_persistent_temp_slot, RedofrSlot, !CI),
- HijackInfo = disj_full_hijack(RedoipSlot, RedofrSlot),
- Code = node([
- llds_instr(assign(RedoipSlot, lval(redoip_slot(lval(maxfr)))),
- "prepare for full disj hijack"),
- llds_instr(assign(RedofrSlot, lval(redofr_slot(lval(maxfr)))),
- "prepare for full disj hijack"),
- llds_instr(assign(redofr_slot(lval(maxfr)), lval(curfr)),
- "prepare for full disj hijack")
- ])
).
undo_disj_hijack(HijackInfo, Code, !CI) :-
@@ -2124,50 +2138,54 @@
),
HijackCode = tree(MaxfrCode, tree(TempFrameCode, MarkCode))
;
- ResumeKnown = resume_point_known(has_been_done),
- CurfrMaxfr = must_be_equal
- ->
- HijackInfo = commit_quarter_hijack,
- HijackCode = node([
- llds_instr(assign(redoip_slot(lval(curfr)), StackLabelConst),
- "hijack the redofr slot")
- ])
- ;
- CurfrMaxfr = must_be_equal
- ->
- % Here ResumeKnown must be resume_point_unknown or
- % resume_point_known(wont_be_done).
-
- acquire_temp_slot(slot_lval(redoip_slot(lval(curfr))),
- non_persistent_temp_slot, RedoipSlot, !CI),
- HijackInfo = commit_half_hijack(RedoipSlot),
- HijackCode = node([
- llds_instr(assign(RedoipSlot, lval(redoip_slot(lval(curfr)))),
- "prepare for half commit hijack"),
- llds_instr(assign(redoip_slot(lval(curfr)), StackLabelConst),
- "hijack the redofr slot")
- ])
- ;
- % Here CurfrMaxfr must be may_be_different.
- acquire_temp_slot(slot_lval(redoip_slot(lval(maxfr))),
- non_persistent_temp_slot, RedoipSlot, !CI),
- acquire_temp_slot(slot_lval(redofr_slot(lval(maxfr))),
- non_persistent_temp_slot, RedofrSlot, !CI),
- acquire_temp_slot(slot_lval(maxfr),
- non_persistent_temp_slot, MaxfrSlot, !CI),
- HijackInfo = commit_full_hijack(RedoipSlot, RedofrSlot, MaxfrSlot),
- HijackCode = node([
- llds_instr(assign(RedoipSlot, lval(redoip_slot(lval(maxfr)))),
- "prepare for full commit hijack"),
- llds_instr(assign(RedofrSlot, lval(redofr_slot(lval(maxfr)))),
- "prepare for full commit hijack"),
- llds_instr(save_maxfr(MaxfrSlot),
- "prepare for full commit hijack"),
- llds_instr(assign(redofr_slot(lval(maxfr)), lval(curfr)),
- "hijack the redofr slot"),
- llds_instr(assign(redoip_slot(lval(maxfr)), StackLabelConst),
- "hijack the redoip slot")
- ])
+ (
+ CurfrMaxfr = must_be_equal,
+ (
+ ResumeKnown = resume_point_known(has_been_done),
+ HijackInfo = commit_quarter_hijack,
+ HijackCode = node([
+ llds_instr(assign(redoip_slot(lval(curfr)),
+ StackLabelConst),
+ "hijack the redofr slot")
+ ])
+ ;
+ ( ResumeKnown = resume_point_known(wont_be_done)
+ ; ResumeKnown = resume_point_unknown
+ ),
+ acquire_temp_slot(slot_lval(redoip_slot(lval(curfr))),
+ non_persistent_temp_slot, RedoipSlot, !CI),
+ HijackInfo = commit_half_hijack(RedoipSlot),
+ HijackCode = node([
+ llds_instr(assign(RedoipSlot,
+ lval(redoip_slot(lval(curfr)))),
+ "prepare for half commit hijack"),
+ llds_instr(assign(redoip_slot(lval(curfr)),
+ StackLabelConst),
+ "hijack the redofr slot")
+ ])
+ )
+ ;
+ CurfrMaxfr = may_be_different,
+ acquire_temp_slot(slot_lval(redoip_slot(lval(maxfr))),
+ non_persistent_temp_slot, RedoipSlot, !CI),
+ acquire_temp_slot(slot_lval(redofr_slot(lval(maxfr))),
+ non_persistent_temp_slot, RedofrSlot, !CI),
+ acquire_temp_slot(slot_lval(maxfr),
+ non_persistent_temp_slot, MaxfrSlot, !CI),
+ HijackInfo = commit_full_hijack(RedoipSlot, RedofrSlot, MaxfrSlot),
+ HijackCode = node([
+ llds_instr(assign(RedoipSlot, lval(redoip_slot(lval(maxfr)))),
+ "prepare for full commit hijack"),
+ llds_instr(assign(RedofrSlot, lval(redofr_slot(lval(maxfr)))),
+ "prepare for full commit hijack"),
+ llds_instr(save_maxfr(MaxfrSlot),
+ "prepare for full commit hijack"),
+ llds_instr(assign(redofr_slot(lval(maxfr)), lval(curfr)),
+ "hijack the redofr slot"),
+ llds_instr(assign(redoip_slot(lval(maxfr)), StackLabelConst),
+ "hijack the redoip slot")
+ ])
+ )
),
maybe_save_trail_info(AddTrailOps, MaybeTrailSlots, SaveTrailCode, !CI),
maybe_save_region_commit_frame(AddRegionOps, ForwardLiveVarsBeforeGoal,
@@ -2467,7 +2485,8 @@
true
),
stack.push(ResumePoints0, ResumePoint, ResumePoints),
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
pick_stack_resume_point(ResumePoint, _, StackLabel),
LabelConst = const(llconst_code_addr(StackLabel)),
Code = node([
@@ -2476,6 +2495,9 @@
]),
RedoipUpdate = has_been_done
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
Code = empty,
RedoipUpdate = wont_be_done
),
@@ -4309,10 +4331,10 @@
(
find_unused_slot_for_item([Head | Tail], HeadItem, TempsInUse,
ChosenHeadStackVar, Remainder),
- ( ChosenHeadStackVar = stackvar(N) ->
+ ( ChosenHeadStackVar = stackvar(N) ->
StackId0 = det_stack,
FirstSlotNum0 = N
- ; ChosenHeadStackVar = framevar(N) ->
+ ; ChosenHeadStackVar = framevar(N) ->
StackId0 = nondet_stack,
FirstSlotNum0 = N
;
Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.180
diff -u -r1.180 code_util.m
--- compiler/code_util.m 13 Aug 2007 03:01:38 -0000 1.180
+++ compiler/code_util.m 21 Nov 2007 10:16:36 -0000
@@ -418,10 +418,14 @@
build_input_arg_list_2([], []).
build_input_arg_list_2([V - Arg | Rest0], VarArgs) :-
Arg = arg_info(Loc, Mode),
- ( Mode = top_in ->
+ (
+ Mode = top_in,
arg_loc_to_register(Loc, Reg),
VarArgs = [V - Reg | VarArgs0]
;
+ ( Mode = top_out
+ ; Mode = top_unused
+ ),
VarArgs = VarArgs0
),
build_input_arg_list_2(Rest0, VarArgs0).
Index: compiler/common.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/common.m,v
retrieving revision 1.103
diff -u -r1.103 common.m
--- compiler/common.m 7 Aug 2007 07:09:49 -0000 1.103
+++ compiler/common.m 21 Nov 2007 06:31:08 -0000
@@ -598,10 +598,18 @@
simplify_info_incr_cost_delta(Cost, !Info),
simplify_info_set_requantify(!Info),
Detism0 = goal_info_get_determinism(GoalInfo),
- ( Detism0 \= detism_det ->
- simplify_info_set_rerun_det(!Info)
+ (
+ Detism0 = detism_det
;
- true
+ ( Detism0 = detism_semi
+ ; Detism0 = detism_non
+ ; Detism0 = detism_multi
+ ; Detism0 = detism_failure
+ ; Detism0 = detism_erroneous
+ ; Detism0 = detism_cc_non
+ ; Detism0 = detism_cc_multi
+ ),
+ simplify_info_set_rerun_det(!Info)
)
;
Context = goal_info_get_context(GoalInfo),
@@ -850,9 +858,7 @@
simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
rtti_varmaps_var_info(RttiVarMaps0, FromVar, FromVarRttiInfo),
rtti_varmaps_var_info(RttiVarMaps0, ToVar, ToVarRttiInfo),
- (
- calculate_induced_tsubst(ToVarRttiInfo, FromVarRttiInfo, TSubst)
- ->
+ ( calculate_induced_tsubst(ToVarRttiInfo, FromVarRttiInfo, TSubst) ->
( map.is_empty(TSubst) ->
true
;
@@ -863,20 +869,31 @@
% variables has rtti_var_info recorded. This can happen if a new
% variable has been introduced, eg in quantification, without
% being recorded in the rtti_varmaps.
- FromVarRttiInfo = non_rtti_var
- ->
- rtti_var_info_duplicate(ToVar, FromVar, RttiVarMaps0, RttiVarMaps),
- simplify_info_set_rtti_varmaps(RttiVarMaps, !Info)
- ;
- ToVarRttiInfo = non_rtti_var
- ->
- rtti_var_info_duplicate(FromVar, ToVar, RttiVarMaps0, RttiVarMaps),
- simplify_info_set_rtti_varmaps(RttiVarMaps, !Info)
- ;
- % calculate_induced_tsubst failed for a different reason, either
- % because unification failed or because one variable was a
- % type_info and the other was a typeclass_info.
- unexpected(this_file, "apply_induced_tsubst: inconsistent info")
+ (
+ FromVarRttiInfo = non_rtti_var,
+ rtti_var_info_duplicate(ToVar, FromVar,
+ RttiVarMaps0, RttiVarMaps),
+ simplify_info_set_rtti_varmaps(RttiVarMaps, !Info)
+ ;
+ ( FromVarRttiInfo = type_info_var(_)
+ ; FromVarRttiInfo = typeclass_info_var(_)
+ ),
+ (
+ ToVarRttiInfo = non_rtti_var,
+ rtti_var_info_duplicate(FromVar, ToVar,
+ RttiVarMaps0, RttiVarMaps),
+ simplify_info_set_rtti_varmaps(RttiVarMaps, !Info)
+ ;
+ ( ToVarRttiInfo = type_info_var(_)
+ ; ToVarRttiInfo = typeclass_info_var(_)
+ ),
+ % Calculate_induced_tsubst failed for a different reason,
+ % either because unification failed or because one variable
+ % was a type_info and the other was a typeclass_info.
+ unexpected(this_file,
+ "apply_induced_tsubst: inconsistent info")
+ )
+ )
).
% Calculate the induced substitution by unifying the types or constraints,
Index: compiler/compile_target_code.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/compile_target_code.m,v
retrieving revision 1.123
diff -u -r1.123 compile_target_code.m
--- compiler/compile_target_code.m 9 Nov 2007 06:32:25 -0000 1.123
+++ compiler/compile_target_code.m 21 Nov 2007 05:56:00 -0000
@@ -549,15 +549,18 @@
),
globals.io_get_tags_method(Tags_Method, !IO),
- ( Tags_Method = tags_high ->
+ (
+ Tags_Method = tags_high,
TagsOpt = "-DMR_HIGHTAGS "
;
+ ( Tags_Method = tags_low
+ ; Tags_Method = tags_none
+ ),
TagsOpt = ""
),
globals.io_lookup_int_option(num_tag_bits, NumTagBits, !IO),
string.int_to_string(NumTagBits, NumTagBitsString),
- string.append_list(["-DMR_TAGBITS=", NumTagBitsString, " "],
- NumTagBitsOpt),
+ NumTagBitsOpt = "-DMR_TAGBITS=" ++ NumTagBitsString ++ " ",
globals.io_lookup_bool_option(decl_debug, DeclDebug, !IO),
(
DeclDebug = yes,
@@ -659,7 +662,8 @@
% We ignore the debug flag unless one of the base flags is set.
MinimalModelOpt = MinimalModelBaseOpt
;
- MinimalModelOpt = MinimalModelBaseOpt ++ "-DMR_MINIMAL_MODEL_DEBUG"
+ MinimalModelOpt = MinimalModelBaseOpt ++
+ "-DMR_MINIMAL_MODEL_DEBUG "
)
;
MinimalModelDebug = no,
@@ -754,7 +758,7 @@
GCC_Regs = yes,
string.prefix(FullArch, "powerpc-apple-darwin")
->
- AppleGCCRegWorkaroundOpt = "-fno-loop-optimize"
+ AppleGCCRegWorkaroundOpt = "-fno-loop-optimize "
;
AppleGCCRegWorkaroundOpt = ""
),
@@ -788,9 +792,9 @@
SinglePrecFloatOpt,
UseRegionsOpt,
TypeLayoutOpt,
- InlineAllocOpt, " ",
+ InlineAllocOpt,
AnsiOpt, " ",
- AppleGCCRegWorkaroundOpt, " ",
+ AppleGCCRegWorkaroundOpt,
WarningOpt, " ",
CFLAGS,
" -c ", C_File, " ",
@@ -1116,7 +1120,13 @@
globals.io_lookup_bool_option(compile_to_shared_lib, CompileToSharedLib,
!IO),
- TargetType = (CompileToSharedLib = yes -> shared_library ; executable),
+ (
+ CompileToSharedLib = yes,
+ TargetType = shared_library
+ ;
+ CompileToSharedLib = no,
+ TargetType = executable
+ ),
get_object_code_type(TargetType, PIC, !IO),
maybe_pic_object_file_extension(PIC, Obj, !IO),
@@ -1336,10 +1346,22 @@
globals.io_lookup_bool_option(extra_initialization_functions, ExtraInits,
!IO),
- ExtraInitsOpt = ( ExtraInits = yes -> "-x" ; "" ),
+ (
+ ExtraInits = yes,
+ ExtraInitsOpt = "-x"
+ ;
+ ExtraInits = no,
+ ExtraInitsOpt = ""
+ ),
globals.io_lookup_bool_option(main, Main, !IO),
- NoMainOpt = ( Main = no -> "-l" ; "" ),
+ (
+ Main = no,
+ NoMainOpt = "-l"
+ ;
+ Main = yes,
+ NoMainOpt = ""
+ ),
globals.io_lookup_string_option(experimental_complexity,
ExperimentalComplexity, !IO),
@@ -1491,9 +1513,16 @@
ObjectsList, LinkSucceeded, !IO)
;
LinkTargetType = executable,
- ( Target = target_erlang ->
+ (
+ Target = target_erlang,
create_erlang_shell_script(ModuleName, LinkSucceeded, !IO)
;
+ ( Target = target_c
+ ; Target = target_il
+ ; Target = target_java
+ ; Target = target_asm
+ ; Target = target_x86_64
+ ),
link_exe_or_shared_lib(ErrorStream, LinkTargetType, ModuleName,
OutputFileName, ObjectsList, LinkSucceeded, !IO)
)
@@ -1790,13 +1819,12 @@
StaticGCLibs = "",
SharedGCLibs = ""
;
- ( GCMethod = gc_boehm
- ; GCMethod = gc_boehm_debug
- ),
- ( GCMethod = gc_boehm_debug ->
- GCGrade0 = "gc_debug"
- ;
+ (
+ GCMethod = gc_boehm,
GCGrade0 = "gc"
+ ;
+ GCMethod = gc_boehm_debug,
+ GCGrade0 = "gc_debug"
),
globals.io_lookup_bool_option(profile_time, ProfTime, !IO),
globals.io_lookup_bool_option(profile_deep, ProfDeep, !IO),
Index: compiler/complexity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/complexity.m,v
retrieving revision 1.29
diff -u -r1.29 complexity.m
--- compiler/complexity.m 7 Aug 2007 07:09:49 -0000 1.29
+++ compiler/complexity.m 22 Nov 2007 01:38:05 -0000
@@ -538,11 +538,15 @@
allocate_slot_numbers_cl([Var - Info | VarInfos], Offset,
NumberedProfiledVars) :-
Info = complexity_arg_info(_, Kind),
- ( Kind = complexity_input_variable_size ->
+ (
+ Kind = complexity_input_variable_size,
allocate_slot_numbers_cl(VarInfos, Offset + 1,
NumberedProfiledVarsTail),
NumberedProfiledVars = [Var - Offset | NumberedProfiledVarsTail]
;
+ ( Kind = complexity_input_fixed_size
+ ; Kind = complexity_output
+ ),
allocate_slot_numbers_cl(VarInfos, Offset, NumberedProfiledVars)
).
Index: compiler/constraint.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/constraint.m,v
retrieving revision 1.86
diff -u -r1.86 constraint.m
--- compiler/constraint.m 7 Aug 2007 07:09:49 -0000 1.86
+++ compiler/constraint.m 22 Nov 2007 01:39:17 -0000
@@ -261,19 +261,26 @@
propagate_conj(Goals0, Constraints, Goals, !Info, !IO) :-
constraint_info_update_changed(Constraints, !Info),
- ( Goals0 = [] ->
+ (
+ Goals0 = [],
flatten_constraints(Constraints, Goals)
- ; Goals0 = [Goal0], Constraints = [] ->
- propagate_conj_sub_goal(Goal0, [], Goals, !Info, !IO)
;
- InstMap0 = !.Info ^ instmap,
- ModuleInfo = !.Info ^ module_info,
- VarTypes = !.Info ^ vartypes,
- annotate_conj_output_vars(Goals0, ModuleInfo,
- VarTypes, InstMap0, [], RevGoals1),
- annotate_conj_constraints(ModuleInfo, RevGoals1,
- Constraints, [], Goals2, !Info, !IO),
- propagate_conj_constraints(Goals2, [], Goals, !Info, !IO)
+ Goals0 = [Goal0 | GoalsTail0],
+ (
+ GoalsTail0 = [],
+ Constraints = []
+ ->
+ propagate_conj_sub_goal(Goal0, [], Goals, !Info, !IO)
+ ;
+ InstMap0 = !.Info ^ instmap,
+ ModuleInfo = !.Info ^ module_info,
+ VarTypes = !.Info ^ vartypes,
+ annotate_conj_output_vars(Goals0, ModuleInfo,
+ VarTypes, InstMap0, [], RevGoals1),
+ annotate_conj_constraints(ModuleInfo, RevGoals1,
+ Constraints, [], Goals2, !Info, !IO),
+ propagate_conj_constraints(Goals2, [], Goals, !Info, !IO)
+ )
).
% Annotate each conjunct with the variables it produces.
Index: compiler/continuation_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/continuation_info.m,v
retrieving revision 1.92
diff -u -r1.92 continuation_info.m
--- compiler/continuation_info.m 1 Oct 2007 04:06:47 -0000 1.92
+++ compiler/continuation_info.m 21 Nov 2007 10:17:56 -0000
@@ -624,10 +624,14 @@
; map.search(StackSlots, Var, Slot) ->
% On return, other live variables are in their stack slots.
VarLvals = [Var - stack_slot_to_lval(Slot) | TailVarLvals]
- ; OkToDeleteAny = yes ->
- VarLvals = TailVarLvals
;
- unexpected(this_file, "find_return_var_lvals: no slot")
+ (
+ OkToDeleteAny = yes,
+ VarLvals = TailVarLvals
+ ;
+ OkToDeleteAny = no,
+ unexpected(this_file, "find_return_var_lvals: no slot")
+ )
).
:- pred generate_temp_live_lvalues(assoc_list(lval, slot_contents)::in,
Index: compiler/deep_profiling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deep_profiling.m,v
retrieving revision 1.67
diff -u -r1.67 deep_profiling.m
--- compiler/deep_profiling.m 12 Nov 2007 03:52:40 -0000 1.67
+++ compiler/deep_profiling.m 21 Nov 2007 10:24:29 -0000
@@ -169,9 +169,13 @@
ModuleInfo, Outputs) :-
find_list_of_output_args_2(Vars, Modes, Types, ModuleInfo, Outputs1),
mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
- ( ArgMode = top_in ->
+ (
+ ArgMode = top_in,
Outputs = Outputs1
;
+ ( ArgMode = top_out
+ ; ArgMode = top_unused
+ ),
Outputs = [Var | Outputs1]
).
@@ -232,12 +236,16 @@
GoalExpr0 = unify(_, _, _, Unify0, _),
Goal = Goal0,
(
- Unify0 = assign(ToVar, FromVar)
- ->
+ Unify0 = assign(ToVar, FromVar),
apply_tail_recursion_process_assign(ApplyInfo ^ outputs,
ToVar, FromVar, Outputs),
Continue = yes(Outputs)
;
+ ( Unify0 = construct(_, _, _, _, _, __, _)
+ ; Unify0 = deconstruct(_, _, _, _, __, _)
+ ; Unify0 = simple_test(_, _)
+ ; Unify0 = complicated_unify(_, _, _)
+ ),
Continue = no
)
;
@@ -1253,7 +1261,8 @@
),
CodeModel = goal_info_get_code_model(GoalInfo0),
- ( CodeModel = model_det ->
+ (
+ CodeModel = model_det,
list.condense([
CallGoals,
[SiteNumVarGoal, PrepareGoal, Goal2],
@@ -1261,6 +1270,9 @@
], Goals),
GoalExpr = conj(plain_conj, Goals)
;
+ ( CodeModel = model_semi
+ ; CodeModel = model_non
+ ),
ExtraVars = list_to_set([MiddleCSD | SaveRestoreVars]),
WrappedGoalGoalInfo =
goal_info_add_nonlocals_make_impure(GoalInfo, ExtraVars),
@@ -1469,7 +1481,8 @@
:- func classify_call(module_info, hlds_goal_expr) = call_class.
classify_call(ModuleInfo, Expr) = Class :-
- ( Expr = plain_call(PredId, ProcId, Args, _, _, _) ->
+ (
+ Expr = plain_call(PredId, ProcId, Args, _, _, _),
(
lookup_builtin_pred_proc_id(ModuleInfo,
mercury_public_builtin_module, "unify",
@@ -1495,9 +1508,20 @@
;
Class = call_class_normal(proc(PredId, ProcId))
)
- ; Expr = generic_call(Generic, _, _, _) ->
+ ;
+ Expr = generic_call(Generic, _, _, _),
Class = call_class_generic(Generic)
;
+ ( Expr = call_foreign_proc(_, _, _, _, _, _, _)
+ ; Expr = unify(_, _, _, _, _)
+ ; Expr = conj(_, _)
+ ; Expr = disj(_)
+ ; Expr = switch(_, _, _)
+ ; Expr = if_then_else(_, _, _, _)
+ ; Expr = negation(_)
+ ; Expr = scope(_, _)
+ ; Expr = shorthand(_)
+ ),
unexpected(this_file, "unexpected goal type in classify_call/2")
).
Index: compiler/deforest.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deforest.m,v
retrieving revision 1.81
diff -u -r1.81 deforest.m
--- compiler/deforest.m 7 Aug 2007 07:09:50 -0000 1.81
+++ compiler/deforest.m 22 Nov 2007 01:48:27 -0000
@@ -429,9 +429,23 @@
deforest_get_branch_vars_goal(Goal, MaybeBranchInfo, !PDInfo) :-
Goal = hlds_goal(GoalExpr, _),
- ( goal_util.goal_is_branched(GoalExpr) ->
+ (
+ ( GoalExpr = disj(_)
+ ; GoalExpr = switch(_, _, _)
+ ; GoalExpr = if_then_else(_, _, _, _)
+ ),
pd_util.get_branch_vars_goal(Goal, MaybeBranchInfo, !PDInfo)
- ; GoalExpr = plain_call(PredId, ProcId, Args, _, _, _) ->
+ ;
+ ( GoalExpr = unify(_, _, _, _, _)
+ ; GoalExpr = generic_call(_, _, _, _)
+ ; GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
+ ; GoalExpr = conj(_, _)
+ ; GoalExpr = negation(_)
+ ; GoalExpr = scope(_, _)
+ ),
+ MaybeBranchInfo = no
+ ;
+ GoalExpr = plain_call(PredId, ProcId, Args, _, _, _),
pd_info_get_proc_arg_info(!.PDInfo, ProcBranchInfos),
( map.search(ProcBranchInfos, proc(PredId, ProcId), BranchInfo0) ->
% Rename the branch_info for the called procedure
@@ -442,7 +456,8 @@
MaybeBranchInfo = no
)
;
- MaybeBranchInfo = no
+ GoalExpr = shorthand(_),
+ unexpected(this_file, "deforest_get_branch_vars_goal: shorthand")
).
%-----------------------------------------------------------------------------%
@@ -647,75 +662,77 @@
should_try_deforestation(DeforestInfo, ShouldOptimize, !PDInfo, !IO),
(
- ShouldOptimize = no
- ->
+ ShouldOptimize = no,
Optimized0 = no,
Goals = []
;
- EarlierGoal = hlds_goal(plain_call(PredId1, _, _, _, _, _), _),
- LaterGoal = hlds_goal(plain_call(PredId2, _, _, _, _, _), _)
- ->
- % If both goals are calls create a new predicate for the conjunction
- % to be deforested and process it.
- pd_info_get_module_info(!.PDInfo, ModuleInfo0),
- PredName1 = predicate_name(ModuleInfo0, PredId1),
- PredName2 = predicate_name(ModuleInfo0, PredId2),
- pd_debug_message("deforesting calls to %s and %s\n",
- [s(PredName1), s(PredName2)], !IO),
- call_call(ConjNonLocals, EarlierGoal, BetweenGoals,
- yes(LaterGoal), MaybeGoal, !PDInfo, !IO),
+ ShouldOptimize = yes,
(
- MaybeGoal = yes(Goal),
- Optimized0 = yes,
- Goals = [Goal]
+ EarlierGoal = hlds_goal(plain_call(PredId1, _, _, _, _, _), _),
+ LaterGoal = hlds_goal(plain_call(PredId2, _, _, _, _, _), _)
+ ->
+ % If both goals are calls create a new predicate for the
+ % conjunction to be deforested and process it.
+ pd_info_get_module_info(!.PDInfo, ModuleInfo0),
+ PredName1 = predicate_name(ModuleInfo0, PredId1),
+ PredName2 = predicate_name(ModuleInfo0, PredId2),
+ pd_debug_message("deforesting calls to %s and %s\n",
+ [s(PredName1), s(PredName2)], !IO),
+ call_call(ConjNonLocals, EarlierGoal, BetweenGoals,
+ yes(LaterGoal), MaybeGoal, !PDInfo, !IO),
+ (
+ MaybeGoal = yes(Goal),
+ Optimized0 = yes,
+ Goals = [Goal]
+ ;
+ MaybeGoal = no,
+ Optimized0 = no,
+ Goals = []
+ )
;
- MaybeGoal = no,
- Optimized0 = no,
- Goals = []
+ % If the first goal is branched and the second goal is a call,
+ % attempt to push the call into the branches. Don't push a
+ % recursive call or a call to a predicate we have already pushed
+ % into a switch, since it is difficult to stop the process.
+ EarlierGoal = hlds_goal(EarlierGoalExpr, _),
+ goal_util.goal_is_branched(EarlierGoalExpr),
+ LaterGoal = hlds_goal(plain_call(PredId, ProcId, _, _, _, _), _),
+ PredProcId = proc(PredId, ProcId),
+ PredProcId \= CurrPredProcId,
+ \+ set.member(PredProcId, Parents0)
+ ->
+ CurrPredName = predicate_name(ModuleInfo, PredId),
+ pd_debug_message("Pushing call to %s into goal\n",
+ [s(CurrPredName)], !IO),
+ set.insert(Parents0, proc(PredId, ProcId), Parents),
+ pd_info_set_parents(Parents, !PDInfo),
+ push_goal_into_goal(ConjNonLocals, DeforestBranches,
+ EarlierGoal, BetweenGoals, LaterGoal, Goal, !PDInfo, !IO),
+ Goals = [Goal],
+ Optimized0 = yes
+ ;
+ % If both goals are branched, push the second into the branches
+ % of the first.
+ EarlierGoal = hlds_goal(EarlierGoalExpr, _),
+ LaterGoal = hlds_goal(LaterGoalExpr, _),
+ goal_util.goal_is_branched(EarlierGoalExpr),
+ goal_util.goal_is_branched(LaterGoalExpr)
+ ->
+ pd_debug_message("Pushing goal into goal\n", [], !IO),
+ push_goal_into_goal(ConjNonLocals, DeforestBranches,
+ EarlierGoal, BetweenGoals, LaterGoal, Goal, !PDInfo, !IO),
+ Goals = [Goal],
+ goals_size([EarlierGoal | BetweenGoals], ConjSize1),
+ goal_size(LaterGoal, ConjSize2),
+ goal_size(Goal, NewSize),
+ SizeDiff = NewSize - ConjSize1 - ConjSize2,
+ pd_info_incr_size_delta(SizeDiff, !PDInfo),
+ Optimized0 = yes
+ ;
+ pd_debug_message("not optimizing\n", [], !IO),
+ Goals = [],
+ Optimized0 = no
)
- ;
- % If the first goal is branched and the second goal is a call,
- % attempt to push the call into the branches. Don't push a recursive
- % call or a call to a predicate we have already pushed into a switch,
- % since it is difficult to stop the process.
- EarlierGoal = hlds_goal(EarlierGoalExpr, _),
- goal_util.goal_is_branched(EarlierGoalExpr),
- LaterGoal = hlds_goal(plain_call(PredId, ProcId, _, _, _, _), _),
- PredProcId = proc(PredId, ProcId),
- PredProcId \= CurrPredProcId,
- \+ set.member(PredProcId, Parents0)
- ->
- CurrPredName = predicate_name(ModuleInfo, PredId),
- pd_debug_message("Pushing call to %s into goal\n",
- [s(CurrPredName)], !IO),
- set.insert(Parents0, proc(PredId, ProcId), Parents),
- pd_info_set_parents(Parents, !PDInfo),
- push_goal_into_goal(ConjNonLocals, DeforestBranches,
- EarlierGoal, BetweenGoals, LaterGoal, Goal, !PDInfo, !IO),
- Goals = [Goal],
- Optimized0 = yes
- ;
- % If both goals are branched, push the second into the branches
- % of the first.
- EarlierGoal = hlds_goal(EarlierGoalExpr, _),
- LaterGoal = hlds_goal(LaterGoalExpr, _),
- goal_util.goal_is_branched(EarlierGoalExpr),
- goal_util.goal_is_branched(LaterGoalExpr)
- ->
- pd_debug_message("Pushing goal into goal\n", [], !IO),
- push_goal_into_goal(ConjNonLocals, DeforestBranches,
- EarlierGoal, BetweenGoals, LaterGoal, Goal, !PDInfo, !IO),
- Goals = [Goal],
- goals_size([EarlierGoal | BetweenGoals], ConjSize1),
- goal_size(LaterGoal, ConjSize2),
- goal_size(Goal, NewSize),
- SizeDiff = NewSize - ConjSize1 - ConjSize2,
- pd_info_incr_size_delta(SizeDiff, !PDInfo),
- Optimized0 = yes
- ;
- pd_debug_message("not optimizing\n", [], !IO),
- Goals = [],
- Optimized0 = no
),
check_improvement(Optimized0, CostDelta0, SizeDelta0, Optimized,
!.PDInfo, !IO),
@@ -1610,12 +1627,14 @@
BetweenGoals, LaterGoal, Goal, !PDInfo, !IO) :-
pd_info_get_instmap(!.PDInfo, InstMap0),
EarlierGoal = hlds_goal(EarlierGoalExpr, _),
- ( EarlierGoalExpr = switch(Var1, CanFail1, Cases1) ->
+ (
+ EarlierGoalExpr = switch(Var1, CanFail1, Cases1),
set.insert(NonLocals, Var1, CaseNonLocals),
append_goal_to_cases(Var1, BetweenGoals, LaterGoal,
CaseNonLocals, 1, DeforestInfo, Cases1, Cases, !PDInfo, !IO),
GoalExpr = switch(Var1, CanFail1, Cases)
- ; EarlierGoalExpr = if_then_else(Vars, Cond, Then0, Else0) ->
+ ;
+ EarlierGoalExpr = if_then_else(Vars, Cond, Then0, Else0),
pd_info_update_goal(Cond, !PDInfo),
Cond = hlds_goal(_, CondInfo),
CondNonLocals = goal_info_get_nonlocals(CondInfo),
@@ -1626,11 +1645,21 @@
append_goal(Else0, BetweenGoals, LaterGoal,
NonLocals, 2, DeforestInfo, Else, !PDInfo, !IO),
GoalExpr = if_then_else(Vars, Cond, Then, Else)
- ; EarlierGoalExpr = disj(Disjuncts0) ->
+ ;
+ EarlierGoalExpr = disj(Disjuncts0),
append_goal_to_disjuncts(BetweenGoals, LaterGoal,
NonLocals, 1, DeforestInfo, Disjuncts0, Disjuncts, !PDInfo, !IO),
GoalExpr = disj(Disjuncts)
;
+ ( EarlierGoalExpr = unify(_, _, _, _, _)
+ ; EarlierGoalExpr = plain_call(_, _, _, _, _, _)
+ ; EarlierGoalExpr = generic_call(_, _, _, _)
+ ; EarlierGoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
+ ; EarlierGoalExpr = conj(_, _)
+ ; EarlierGoalExpr = negation(_)
+ ; EarlierGoalExpr = scope(_, _)
+ ; EarlierGoalExpr = shorthand(_)
+ ),
unexpected(this_file, "push_goal_into_goal")
),
pd_info_set_instmap(InstMap0, !PDInfo),
Index: compiler/delay_partial_inst.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/delay_partial_inst.m,v
retrieving revision 1.3
diff -u -r1.3 delay_partial_inst.m
--- compiler/delay_partial_inst.m 28 Sep 2007 03:17:11 -0000 1.3
+++ compiler/delay_partial_inst.m 21 Nov 2007 06:31:20 -0000
@@ -336,21 +336,28 @@
% Mark the procedure as changed.
!DelayInfo ^ dpi_changed := yes
- else if
- % Tranform lambda goals as well. Non-local variables in lambda
- % goals must be ground so we don't carry the construct map into
- % the lambda goal.
- RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
- NonLocals, LambdaQuantVars, Modues, Detism, LambdaGoal0)
- then
- delay_partial_inst_in_goal(InstMap0, LambdaGoal0, LambdaGoal,
- map.init, _ConstructMap, !DelayInfo),
- RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
- NonLocals, LambdaQuantVars, Modues, Detism, LambdaGoal),
- GoalExpr = unify(LHS, RHS, Mode, Unify, Context),
- Goal = hlds_goal(GoalExpr, GoalInfo0)
else
- Goal = Goal0
+ (
+ % Tranform lambda goals as well. Non-local variables in
+ % lambda goals must be ground so we don't carry the
+ % construct map into the lambda goal.
+ RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ NonLocals, LambdaQuantVars, Modues, Detism,
+ LambdaGoal0),
+ delay_partial_inst_in_goal(InstMap0,
+ LambdaGoal0, LambdaGoal, map.init, _ConstructMap,
+ !DelayInfo),
+ RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ NonLocals, LambdaQuantVars, Modues, Detism,
+ LambdaGoal),
+ GoalExpr = unify(LHS, RHS, Mode, Unify, Context),
+ Goal = hlds_goal(GoalExpr, GoalInfo0)
+ ;
+ ( RHS0 = rhs_var(_)
+ ; RHS0 = rhs_functor(_, _, _)
+ ),
+ Goal = Goal0
+ )
)
;
Unify = deconstruct(Var, ConsId, DeconArgs, UniModes,
Index: compiler/dense_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dense_switch.m,v
retrieving revision 1.67
diff -u -r1.67 dense_switch.m
--- compiler/dense_switch.m 27 Sep 2007 10:42:05 -0000 1.67
+++ compiler/dense_switch.m 21 Nov 2007 10:21:14 -0000
@@ -80,7 +80,8 @@
Range = Span + 1,
Density = switch_density(NumCases, Range),
Density > ReqDensity,
- ( CanFail0 = can_fail ->
+ (
+ CanFail0 = can_fail,
% For semidet switches, we normally need to check that the variable
% is in range before we index into the jump table. However, if the
% range of the type is sufficiently small, we can make the jump table
@@ -102,7 +103,8 @@
LastVal = LastCaseVal
)
;
- CanFail = CanFail0,
+ CanFail0 = cannot_fail,
+ CanFail = cannot_fail,
FirstVal = FirstCaseVal,
LastVal = LastCaseVal
).
Index: compiler/dep_par_conj.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dep_par_conj.m,v
retrieving revision 1.21
diff -u -r1.21 dep_par_conj.m
--- compiler/dep_par_conj.m 7 Aug 2007 07:09:50 -0000 1.21
+++ compiler/dep_par_conj.m 22 Nov 2007 01:48:55 -0000
@@ -618,9 +618,13 @@
% by the addition of signal goals (which are impure) or calls to
% parallelised procs (which may be impure).
Purity = goal_info_get_purity(GoalInfo),
- ( Purity = purity_impure ->
+ (
+ Purity = purity_impure,
NewGoal = NewGoal0
;
+ ( Purity = purity_pure
+ ; Purity = purity_semipure
+ ),
Reason = promise_purity(dont_make_implicit_promises, Purity),
NewGoal = hlds_goal(scope(Reason, NewGoal0), GoalInfo)
).
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.208
diff -u -r1.208 det_analysis.m
--- compiler/det_analysis.m 7 Aug 2007 07:09:50 -0000 1.208
+++ compiler/det_analysis.m 21 Nov 2007 06:34:44 -0000
@@ -699,13 +699,22 @@
;
Context = goal_info_get_context(GoalInfo),
determinism_components(Detism, CanFail, MaxSoln),
- ( CanFail \= cannot_fail ->
+ (
+ CanFail = can_fail,
First = "Error: parallel conjunct may fail."
- ; MaxSoln = at_most_many ->
- First = "Error: parallel conjunct may have multiple solutions."
;
- unexpected(this_file,
- "strange determinism error for parallel conjunction")
+ CanFail = cannot_fail,
+ (
+ MaxSoln = at_most_many,
+ First = "Error: parallel conjunct may have multiple solutions."
+ ;
+ ( MaxSoln = at_most_zero
+ ; MaxSoln = at_most_one
+ ; MaxSoln = at_most_many_cc
+ ),
+ unexpected(this_file,
+ "strange determinism error for parallel conjunction")
+ )
),
Rest = "The current implementation supports only "
++ "single-solution non-failing parallel conjunctions.",
@@ -1052,11 +1061,15 @@
;
true
),
- ( PragmaCode = fc_impl_model_non(_, _, _, _, _, _, _, _, _) ->
+ (
+ PragmaCode = fc_impl_model_non(_, _, _, _, _, _, _, _, _),
% Foreign_procs codes of this form can have more than one
% solution.
NumSolns1 = at_most_many
;
+ ( PragmaCode = fc_impl_ordinary(_, _)
+ ; PragmaCode = fc_impl_import(_, _, _, _)
+ ),
NumSolns1 = NumSolns0
),
(
@@ -1161,11 +1174,15 @@
unexpected(this_file, "can_fail assign")
;
Unify = complicated_unify(_, _, _),
- ( RHS = rhs_var(RHSVar) ->
+ (
+ RHS = rhs_var(RHSVar),
FailingContext = failing_context(Context,
test_goal(LHS, RHSVar)),
GoalFailingContexts = [FailingContext]
;
+ ( RHS = rhs_functor(_, _, _)
+ ; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _)
+ ),
unexpected(this_file, "complicated_unify but no var")
)
;
@@ -1231,25 +1248,34 @@
determinism_components(ElseDetism, ElseCanFail, ElseMaxSoln),
% Finally combine the results from the three parts.
- ( CondCanFail = cannot_fail ->
+ (
+ CondCanFail = cannot_fail,
% A -> B ; C is equivalent to A, B if A cannot fail
det_conjunction_detism(CondDetism, ThenDetism, Detism)
- ; CondMaxSoln = at_most_zero ->
- % A -> B ; C is equivalent to ~A, C if A cannot succeed
- det_negation_det(CondDetism, MaybeNegDetism),
+ ;
+ CondCanFail = can_fail,
(
- MaybeNegDetism = no,
- unexpected(this_file,
- "cannot find determinism of negated condition")
+ CondMaxSoln = at_most_zero,
+ % A -> B ; C is equivalent to ~A, C if A cannot succeed
+ det_negation_det(CondDetism, MaybeNegDetism),
+ (
+ MaybeNegDetism = no,
+ unexpected(this_file,
+ "cannot find determinism of negated condition")
+ ;
+ MaybeNegDetism = yes(NegDetism)
+ ),
+ det_conjunction_detism(NegDetism, ElseDetism, Detism)
;
- MaybeNegDetism = yes(NegDetism)
- ),
- det_conjunction_detism(NegDetism, ElseDetism, Detism)
- ;
- det_conjunction_maxsoln(CondMaxSoln, ThenMaxSoln, CTMaxSoln),
- det_switch_maxsoln(CTMaxSoln, ElseMaxSoln, MaxSoln),
- det_switch_canfail(ThenCanFail, ElseCanFail, CanFail),
- determinism_components(Detism, CanFail, MaxSoln)
+ ( CondMaxSoln = at_most_one
+ ; CondMaxSoln = at_most_many
+ ; CondMaxSoln = at_most_many_cc
+ ),
+ det_conjunction_maxsoln(CondMaxSoln, ThenMaxSoln, CTMaxSoln),
+ det_switch_maxsoln(CTMaxSoln, ElseMaxSoln, MaxSoln),
+ det_switch_canfail(ThenCanFail, ElseCanFail, CanFail),
+ determinism_components(Detism, CanFail, MaxSoln)
+ )
),
% Failing contexts in the condition are ignored, since they can't lead
% to failure of the if-then-else as a whole without one or more failing
@@ -1562,7 +1588,8 @@
map.lookup(VarTypes, Var, Type),
det_type_has_user_defined_equality_pred(DetInfo, Type)
->
- ( CanFail = can_fail ->
+ (
+ CanFail = can_fail,
Context = goal_info_get_context(GoalInfo),
proc_info_get_varset(ProcInfo, VarSet),
(
@@ -1602,52 +1629,58 @@
[always(Pieces0 ++ Pieces1),
verbose_only(VerbosePieces)])]),
!:Specs = [Spec | !.Specs]
- ; SolnContext = all_solns ->
- Context = goal_info_get_context(GoalInfo),
- proc_info_get_varset(ProcInfo, VarSet),
- (
- GoalContext = ccuc_switch,
- VarStr = mercury_var_to_string(VarSet, no, Var),
- Pieces0 = [words("In switch on variable `" ++ VarStr ++ "':"),
- nl]
- ;
- GoalContext = ccuc_unify(UnifyContext),
- unify_context_first_to_pieces(yes, _, UnifyContext, [], Pieces0)
- ),
+ ;
+ CanFail = cannot_fail,
(
- Pieces0 = [],
- ErrorMsg = "Error:"
+ SolnContext = all_solns,
+ Context = goal_info_get_context(GoalInfo),
+ proc_info_get_varset(ProcInfo, VarSet),
+ (
+ GoalContext = ccuc_switch,
+ VarStr = mercury_var_to_string(VarSet, no, Var),
+ Pieces0 = [words("In switch on variable"), quote(VarStr),
+ suffix(":"), nl]
+ ;
+ GoalContext = ccuc_unify(UnifyContext),
+ unify_context_first_to_pieces(yes, _, UnifyContext, [],
+ Pieces0)
+ ),
+ (
+ Pieces0 = [],
+ ErrorMsg = "Error:"
+ ;
+ Pieces0 = [_ | _],
+ ErrorMsg = "error:"
+ ),
+ Pieces1 = [words(ErrorMsg),
+ words("unification for non-canonical type"),
+ top_ctor_of_type(Type),
+ words("occurs in a context which requires all solutions."),
+ nl],
+ VerbosePieces = [words("Since the type has a user-defined"),
+ words("equality predicate, I must presume that"),
+ words("there is more than one possible concrete"),
+ words("representation for each abstract value"),
+ words("of this type. The results of this unification"),
+ words("might depend on the choice of concrete"),
+ words("representation. Finding all possible"),
+ words("solutions to this unification would require"),
+ words("backtracking over all possible"),
+ words("representations, but I'm not going to do that"),
+ words("implicitly. (If that's really what you want,"),
+ words("you must do it explicitly.)")],
+ det_info_get_module_info(DetInfo, ModuleInfo),
+ ContextMsgs = failing_contexts_description(ModuleInfo, VarSet,
+ FailingContextsA ++ FailingContextsB),
+ Spec = error_spec(severity_error, phase_detism_check,
+ [simple_msg(Context,
+ [always(Pieces0 ++ Pieces1),
+ verbose_only(VerbosePieces)])]
+ ++ ContextMsgs),
+ !:Specs = [Spec | !.Specs]
;
- Pieces0 = [_ | _],
- ErrorMsg = "error:"
- ),
- Pieces1 = [words(ErrorMsg),
- words("unification for non-canonical type"),
- top_ctor_of_type(Type),
- words("occurs in a context which requires all solutions."),
- nl],
- VerbosePieces = [words("Since the type has a user-defined"),
- words("equality predicate, I must presume that"),
- words("there is more than one possible concrete"),
- words("representation for each abstract value"),
- words("of this type. The results of this unification"),
- words("might depend on the choice of concrete"),
- words("representation. Finding all possible"),
- words("solutions to this unification would require"),
- words("backtracking over all possible"),
- words("representations, but I'm not going to do that"),
- words("implicitly. (If that's really what you want,"),
- words("you must do it explicitly.)")],
- det_info_get_module_info(DetInfo, ModuleInfo),
- ContextMsgs = failing_contexts_description(ModuleInfo, VarSet,
- FailingContextsA ++ FailingContextsB),
- Spec = error_spec(severity_error, phase_detism_check,
- [simple_msg(Context,
- [always(Pieces0 ++ Pieces1), verbose_only(VerbosePieces)])]
- ++ ContextMsgs),
- !:Specs = [Spec | !.Specs]
- ;
- true
+ SolnContext = first_soln
+ )
),
(
SolnContext = first_soln,
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.138
diff -u -r1.138 det_report.m
--- compiler/det_report.m 7 Aug 2007 07:09:51 -0000 1.138
+++ compiler/det_report.m 21 Nov 2007 13:53:31 -0000
@@ -675,13 +675,18 @@
determinism_components(Desired, DesiredCanFail, DesiredSolns),
determinism_components(Actual, ActualCanFail, ActualSolns),
compare_canfails(DesiredCanFail, ActualCanFail, CmpCanFail),
- ( CmpCanFail = tighter ->
+ (
+ CmpCanFail = tighter,
CanFailPieces = [words("can fail")]
;
+ ( CmpCanFail = sameas
+ ; CmpCanFail = looser
+ ),
CanFailPieces = []
),
compare_solncounts(DesiredSolns, ActualSolns, CmpSolns),
- ( CmpSolns = tighter ->
+ (
+ CmpSolns = tighter,
(
CanFailPieces = [_ | _],
ConnectPieces = [words("and")]
@@ -689,12 +694,20 @@
CanFailPieces = [],
ConnectPieces = []
),
- ( DesiredSolns = at_most_one ->
+ (
+ DesiredSolns = at_most_one,
SolnsPieces = [words("can succeed more than once")]
;
+ ( DesiredSolns = at_most_zero
+ ; DesiredSolns = at_most_many
+ ; DesiredSolns = at_most_many_cc
+ ),
SolnsPieces = [words("can succeed")]
)
;
+ ( CmpSolns = sameas
+ ; CmpSolns = looser
+ ),
ConnectPieces = [],
SolnsPieces = []
),
@@ -821,7 +834,7 @@
ConsIdStr = cons_id_to_string(ConsId),
VarStr = mercury_var_to_string(VarSet, no, Var),
HeadPieces = [words("Inside the case"), fixed(ConsIdStr),
- words("of the switch on"), fixed(VarStr), words(":")],
+ words("of the switch on"), fixed(VarStr), suffix(":"), nl],
det_diagnose_switch_context(SwitchContexts, DetInfo, TailPieces).
%-----------------------------------------------------------------------------%
@@ -1019,12 +1032,18 @@
det_report_context_lines_2([], _) = "".
det_report_context_lines_2([Context | Contexts], First) = Str :-
term.context_line(Context, Line),
- ( First = yes ->
+ (
+ First = yes,
Punct = ""
- ; Contexts = [] ->
- Punct = " and "
;
- Punct = ", "
+ First = no,
+ (
+ Contexts = [_ | _],
+ Punct = ", "
+ ;
+ Contexts = [],
+ Punct = " and "
+ )
),
int_to_string(Line, This),
Later = det_report_context_lines_2(Contexts, no),
Index: compiler/distance_granularity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/distance_granularity.m,v
retrieving revision 1.4
diff -u -r1.4 distance_granularity.m
--- compiler/distance_granularity.m 7 Aug 2007 07:09:51 -0000 1.4
+++ compiler/distance_granularity.m 22 Nov 2007 02:49:21 -0000
@@ -5,23 +5,23 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: distance_granularity.m.
% Author: tannier.
%
-% This module contains a program transformation that adds a mechanism that
-% controls the granularity of parallel execution using the distance metric. For
-% more information, see:
-% K. Shen, V. Santos Costa, and A. King.
-% Distance: a New Metric for Controlling Granularity for Parallel Execution.
-% In Proceedings of the Joint International Conference and Symposium on Logic
-% Programming.
-% MIT Press, 1998.
-% http://www.cs.ukc.ac.uk/pubs/1998/588.
+% This module contains a program transformation that adds a mechanism that
+% controls the granularity of parallel execution using the distance metric. For
+% more information, see:
+% K. Shen, V. Santos Costa, and A. King.
+% Distance: a New Metric for Controlling Granularity for Parallel Execution.
+% In Proceedings of the Joint International Conference and Symposium on Logic
+% Programming.
+% MIT Press, 1998.
+% http://www.cs.ukc.ac.uk/pubs/1998/588.
% http://citeseer.ist.psu.edu/shen98distance.html.
%
% Example of the transformation:
-%
+%
% From the original version of fibonacci:
%
% :- pred fibonacci(int::in, int::out) is det.
@@ -35,10 +35,10 @@
% ;
% ( X > 1 ->
% J = X - 1,
-% K = X - 2,
-% (
-% fibonacci(J, Jout)
-% &
+% K = X - 2,
+% (
+% fibonacci(J, Jout)
+% &
% fibonacci(K, Kout)
% ),
% Y = Jout + Kout
@@ -48,10 +48,10 @@
% )
% ).
%
-% we create a specialized version (we assume that the distance which was
+% we create a specialized version (we assume that the distance which was
% given during compilation is 10):
-%
-% :- pred DistanceGranularityFor__pred__fibonacci__10(int::in, int::out,
+%
+% :- pred DistanceGranularityFor__pred__fibonacci__10(int::in, int::out,
% int::in) is det.
%
% DistanceGranularityFor__pred__fibonacci__10(X, Y, Distance) :-
@@ -63,19 +63,19 @@
% ;
% ( X > 1 ->
% J = X - 1,
-% K = X - 2,
+% K = X - 2,
% ( Distance = 0 ->
-% (
-% DistanceGranularityFor__pred__fibonacci__10i(J, Jout,
-% 10)
+% (
+% DistanceGranularityFor__pred__fibonacci__10i(J, Jout,
+% 10)
% &
-% DistanceGranularityFor__pred__fibonacci__10(K, Kout,
+% DistanceGranularityFor__pred__fibonacci__10(K, Kout,
% 10)
% )
% ;
-% DistanceGranularityFor__pred__fibonacci__10(J, Jout,
+% DistanceGranularityFor__pred__fibonacci__10(J, Jout,
% Distance - 1),
-% DistanceGranularityFor__pred__fibonacci__10(K, Kout,
+% DistanceGranularityFor__pred__fibonacci__10(K, Kout,
% Distance - 1)
% ),
% Y = Jout + Kout
@@ -86,7 +86,7 @@
% ).
%
% After which, the original version becomes:
-%
+%
% :- pred fibonacci(int::in, int::out) is det.
%
% fibonacci(X, Y) :-
@@ -98,27 +98,27 @@
% ;
% ( X > 1 ->
% J = X - 1,
-% K = X - 2,
-% (
-% DistanceGranularityFor__pred__fibonacci__10(J, Jout, 10)
-% &
+% K = X - 2,
+% (
+% DistanceGranularityFor__pred__fibonacci__10(J, Jout, 10)
+% &
% DistanceGranularityFor__pred__fibonacci__10(K, Kout, 10)
% ),
% Y = Jout + Kout
% ;
-% error("fibonacci: wrong value")
+% . error("fibonacci: wrong value")
% )
% )
% ).
%
-% The second part of the transformation makes the granularity control
-% transparent to the original procedure's callers by replacing the recursive
-% calls in the body of the original procedure with calls to the specialized
-% version. The original procedure's callers should never need to call the
-% specialized version directly.
+% The second part of the transformation makes the granularity control
+% transparent to the original procedure's callers by replacing the recursive
+% calls in the body of the original procedure with calls to the specialized
+% version. The original procedure's callers should never need to call the
+% specialized version directly.
%
% XXX For the time being, we assume that the int module was imported in the
-% source code of the program for which we apply the distance granularity
+% source code of the program for which we apply the distance granularity
% transformation.
%
%-----------------------------------------------------------------------------%
@@ -131,11 +131,11 @@
%-----------------------------------------------------------------------------%
% control_distance_granularity(!ModuleInfo, Distance)
- %
- % Control the granularity of parallelism of a module using the distance
+ %
+ % Control the granularity of parallelism of a module using the distance
% metric.
- %
-:- pred control_distance_granularity(module_info::in, module_info::out,
+ %
+:- pred control_distance_granularity(module_info::in, module_info::out,
int::in) is det.
%-----------------------------------------------------------------------------%
@@ -176,22 +176,22 @@
% This section contains predicates which apply the first part of the
% transformation i.e. creating the specialized version of the
% original predicate.
-
+
control_distance_granularity(!ModuleInfo, Distance) :-
module_info_predids(PredIds, !ModuleInfo),
apply_dg_to_preds(PredIds, Distance, !ModuleInfo).
- % Apply the distance granularity transformation to each predicate in the
+ % Apply the distance granularity transformation to each predicate in the
% list.
%
-:- pred apply_dg_to_preds(list(pred_id)::in, int::in,
+:- pred apply_dg_to_preds(list(pred_id)::in, int::in,
module_info::in, module_info::out) is det.
apply_dg_to_preds([], _Distance, !ModuleInfo).
apply_dg_to_preds([PredId | PredIdList], Distance, !ModuleInfo) :-
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
- % We need to know what the pred_id will be for the specified predicate
+ % We need to know what the pred_id will be for the specified predicate
% before we actually clone it (this avoids doing one more pass to update the
% pred_id in the recursive plain calls).
module_info_get_predicate_table(!.ModuleInfo, PredicateTable),
@@ -203,44 +203,44 @@
MaybePredOrFunc = yes(pf_predicate),
NewPredIdGranularity = newpred_distance_granularity(Distance),
PredName0 = pred_info_name(PredInfo),
- make_pred_name(ModuleName, Prefix, MaybePredOrFunc, PredName0,
+ make_pred_name(ModuleName, Prefix, MaybePredOrFunc, PredName0,
NewPredIdGranularity, NewCallSymName),
-
- ProcIds = pred_info_non_imported_procids(PredInfo),
- apply_dg_to_procs(PredId, ProcIds, Distance, NewPredId, NewCallSymName,
+
+ ProcIds = pred_info_non_imported_procids(PredInfo),
+ apply_dg_to_procs(PredId, ProcIds, Distance, NewPredId, NewCallSymName,
PredInfo, PredInfoClone0, no, Specialized, !ModuleInfo),
- (
+ (
Specialized = yes,
% The predicate has been specialized as it contains recursive calls.
-
- % Create the name of the specialized predicate out of the name of the
+
+ % Create the name of the specialized predicate out of the name of the
% original one.
create_specialized_pred_name(Prefix, Distance, PredName0, PredName),
pred_info_set_name(PredName, PredInfoClone0, PredInfoClone1),
-
- % If the original predicate was a function then the specialized version
+
+ % If the original predicate was a function then the specialized version
% is a predicate.
- pred_info_set_is_pred_or_func(pf_predicate, PredInfoClone1,
+ pred_info_set_is_pred_or_func(pf_predicate, PredInfoClone1,
PredInfoClone2),
-
- % The arity and the argument types of the specialized predicate must be
- % modified.
+
+ % The arity and the argument types of the specialized predicate must be
+ % modified.
Arity = pred_info_orig_arity(PredInfoClone2),
pred_info_set_orig_arity(Arity + 1, PredInfoClone2, PredInfoClone3),
pred_info_get_arg_types(PredInfoClone3, ArgTypes0),
list.append(ArgTypes0, [int_type], ArgTypes),
pred_info_get_typevarset(PredInfoClone3, Tvarset),
pred_info_get_exist_quant_tvars(PredInfoClone3, ExistqTvars),
- pred_info_set_arg_types(Tvarset, ExistqTvars, ArgTypes,
+ pred_info_set_arg_types(Tvarset, ExistqTvars, ArgTypes,
PredInfoClone3, PredInfoClone),
-
+
% Add the specialized predicate to the predicate table.
module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- predicate_table_insert(PredInfoClone, _, PredicateTable0,
+ predicate_table_insert(PredInfoClone, _, PredicateTable0,
PredicateTable1),
module_info_set_predicate_table(PredicateTable1, !ModuleInfo),
-
- update_original_predicate_procs(PredId, ProcIds, Distance, NewPredId,
+
+ update_original_predicate_procs(PredId, ProcIds, Distance, NewPredId,
NewCallSymName, PredInfo, PredInfoUpdated, !ModuleInfo),
module_info_set_pred_info(PredId, PredInfoUpdated, !ModuleInfo)
;
@@ -250,38 +250,38 @@
),
apply_dg_to_preds(PredIdList, Distance, !ModuleInfo).
- % Apply the distance granularity transformation to each procedure in the
+ % Apply the distance granularity transformation to each procedure in the
% list.
% PredIdSpecialized is the pred_id of the predicate to be specialized.
% SymNameSpecialized is the sym_name of the predicate to be specialized.
%
-:- pred apply_dg_to_procs(pred_id::in, list(proc_id)::in, int::in,
- pred_id::in, sym_name::in, pred_info::in, pred_info::out,
+:- pred apply_dg_to_procs(pred_id::in, list(proc_id)::in, int::in,
+ pred_id::in, sym_name::in, pred_info::in, pred_info::out,
bool::in, bool::out, module_info::in, module_info::out) is det.
-apply_dg_to_procs(_PredId, [], _Distance, _PredIdSpecialized,
+apply_dg_to_procs(_PredId, [], _Distance, _PredIdSpecialized,
_SymNameSpecialized, !PredInfo, !Specialized, !ModuleInfo).
-apply_dg_to_procs(PredId, [ProcId | ProcIds], Distance, PredIdSpecialized,
+apply_dg_to_procs(PredId, [ProcId | ProcIds], Distance, PredIdSpecialized,
SymNameSpecialized, !PredInfo, !Specialized, !ModuleInfo) :-
module_info_proc_info(!.ModuleInfo, proc(PredId, ProcId), ProcInfo0),
proc_info_get_has_parallel_conj(ProcInfo0, HasParallelConj),
- (
+ (
HasParallelConj = yes,
% The procedure contains parallel conjunction(s).
-
+
proc_info_get_goal(ProcInfo0, Body),
- apply_dg_to_goal(Body, BodyClone, PredId, ProcId, PredIdSpecialized,
+ apply_dg_to_goal(Body, BodyClone, PredId, ProcId, PredIdSpecialized,
SymNameSpecialized, ProcInfo0, ProcInfo1, !ModuleInfo, Distance, no,
no, MaybeGranularityVar, _),
- (
+ (
MaybeGranularityVar = yes(_),
- % The granularity variable has been created while the procedure was
+ % The granularity variable has been created while the procedure was
% processed. That means that the predicate must be specialized.
!:Specialized = yes,
proc_info_set_goal(BodyClone, ProcInfo1, ProcInfo2),
requantify_proc(ProcInfo2, ProcInfo3),
RecomputeAtomic = no,
- recompute_instmap_delta_proc(RecomputeAtomic, ProcInfo3,
+ recompute_instmap_delta_proc(RecomputeAtomic, ProcInfo3,
ProcInfo, !ModuleInfo),
pred_info_set_proc_info(ProcId, ProcInfo, !PredInfo)
;
@@ -292,18 +292,18 @@
% No need to apply the distance granularity transformation to this
% procedure as it does not contain any parallel conjunctions.
),
- apply_dg_to_procs(PredId, ProcIds, Distance, PredIdSpecialized,
+ apply_dg_to_procs(PredId, ProcIds, Distance, PredIdSpecialized,
SymNameSpecialized, !PredInfo, !Specialized, !ModuleInfo).
-
+
% Apply the distance granularity transformation to a goal.
% CallerPredId and CallerProcId are those of the original predicate.
%
-:- pred apply_dg_to_goal(hlds_goal::in, hlds_goal::out, pred_id::in,
- proc_id::in, pred_id::in, sym_name::in, proc_info::in, proc_info::out,
- module_info::in, module_info::out, int::in, bool::in,
+:- pred apply_dg_to_goal(hlds_goal::in, hlds_goal::out, pred_id::in,
+ proc_id::in, pred_id::in, sym_name::in, proc_info::in, proc_info::out,
+ module_info::in, module_info::out, int::in, bool::in,
maybe(prog_var)::in, maybe(prog_var)::out, bool::out) is det.
-apply_dg_to_goal(!Goal, CallerPredId, CallerProcId, PredIdSpecialized,
+apply_dg_to_goal(!Goal, CallerPredId, CallerProcId, PredIdSpecialized,
SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, IsInParallelConj,
!MaybeGranularityVar, IsRecursiveCallInParallelConj) :-
!.Goal = hlds_goal(GoalExpr0, GoalInfo),
@@ -312,9 +312,9 @@
IsRecursiveCallInParallelConj = no
;
GoalExpr0 = plain_call(_, _, _, _, _, _),
- apply_dg_to_plain_call(GoalExpr0, GoalExpr, CallerPredId,
- PredIdSpecialized, SymNameSpecialized, CallerProcId, !ProcInfo,
- !ModuleInfo, IsInParallelConj, !MaybeGranularityVar,
+ apply_dg_to_plain_call(GoalExpr0, GoalExpr, CallerPredId,
+ PredIdSpecialized, SymNameSpecialized, CallerProcId, !ProcInfo,
+ !ModuleInfo, IsInParallelConj, !MaybeGranularityVar,
IsRecursiveCallInParallelConj),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
@@ -325,8 +325,8 @@
IsRecursiveCallInParallelConj = no
;
GoalExpr0 = conj(Type, Goals0),
- apply_dg_to_conj(Goals0, [], Goals, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ apply_dg_to_conj(Goals0, [], Goals, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, yes, !MaybeGranularityVar, no, ContainRecursiveCalls),
(
Type = plain_conj,
@@ -334,10 +334,10 @@
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
Type = parallel_conj,
- (
+ (
ContainRecursiveCalls = yes,
create_if_then_else_goal(Goals, GoalInfo, !.MaybeGranularityVar,
- PredIdSpecialized, CallerProcId, Distance, !:Goal,
+ PredIdSpecialized, CallerProcId, Distance, !:Goal,
!ProcInfo, !.ModuleInfo)
;
ContainRecursiveCalls = no,
@@ -347,46 +347,46 @@
IsRecursiveCallInParallelConj = no
;
GoalExpr0 = disj(Goals0),
- apply_dg_to_disj(Goals0, [], Goals, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ apply_dg_to_disj(Goals0, [], Goals, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, !MaybeGranularityVar),
GoalExpr = disj(Goals),
!:Goal = hlds_goal(GoalExpr, GoalInfo),
IsRecursiveCallInParallelConj = no
;
GoalExpr0 = switch(Var, CanFail, Cases0),
- apply_dg_to_switch(Cases0, [], Cases, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ apply_dg_to_switch(Cases0, [], Cases, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, !MaybeGranularityVar),
GoalExpr = switch(Var, CanFail, Cases),
!:Goal = hlds_goal(GoalExpr, GoalInfo),
IsRecursiveCallInParallelConj = no
;
GoalExpr0 = negation(Goal0),
- apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
- Distance, IsInParallelConj, !MaybeGranularityVar,
+ apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ Distance, IsInParallelConj, !MaybeGranularityVar,
IsRecursiveCallInParallelConj),
GoalExpr = negation(Goal),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
GoalExpr0 = scope(Reason, Goal0),
- apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
- Distance, IsInParallelConj, !MaybeGranularityVar,
+ apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ Distance, IsInParallelConj, !MaybeGranularityVar,
IsRecursiveCallInParallelConj),
GoalExpr = scope(Reason, Goal),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
- apply_dg_to_goal(Cond0, Cond, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ apply_dg_to_goal(Cond0, Cond, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, no, !MaybeGranularityVar, _),
- apply_dg_to_goal(Then0, Then, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ apply_dg_to_goal(Then0, Then, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, no, !MaybeGranularityVar, _),
- apply_dg_to_goal(Else0, Else, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ apply_dg_to_goal(Else0, Else, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, no, !MaybeGranularityVar, _),
GoalExpr = if_then_else(Vars, Cond, Then, Else),
!:Goal = hlds_goal(GoalExpr, GoalInfo),
@@ -399,129 +399,128 @@
% Apply the distance granularity transformation to a plain call.
%
-:- pred apply_dg_to_plain_call(hlds_goal_expr::in, hlds_goal_expr::out,
- pred_id::in, pred_id::in, sym_name::in, proc_id::in, proc_info::in,
- proc_info::out, module_info::in, module_info::out, bool::in,
+:- pred apply_dg_to_plain_call(
+ hlds_goal_expr::in(plain_call_expr), hlds_goal_expr::out,
+ pred_id::in, pred_id::in, sym_name::in, proc_id::in, proc_info::in,
+ proc_info::out, module_info::in, module_info::out, bool::in,
maybe(prog_var)::in, maybe(prog_var)::out, bool::out) is det.
-apply_dg_to_plain_call(!CallExpr, CallerPredId, PredIdSpecialized,
- SymNameSpecialized, CallerProcId, !ProcInfo, !ModuleInfo,
- IsInParallelConj, !MaybeGranularityVar,
+apply_dg_to_plain_call(!GoalExpr, CallerPredId, PredIdSpecialized,
+ SymNameSpecialized, CallerProcId, !ProcInfo, !ModuleInfo,
+ IsInParallelConj, !MaybeGranularityVar,
IsRecursiveCallInParallelConj) :-
- ( !.CallExpr = plain_call(CalleePredId, CalleeProcId, CallArgs, CallBuiltin,
- CallUnifyContext, _) ->
- ( IsInParallelConj = yes, CalleePredId = CallerPredId,
- CalleeProcId = CallerProcId
- ->
- % That is a recursive plain call in a parallel conjunction.
- (
- !.MaybeGranularityVar = yes(_GranularityVar),
- % The variable Granularity has already been added to ProcInfo.
- true
- ;
- !.MaybeGranularityVar = no,
- % Add the variable Granularity to ProcInfo.
- proc_info_create_var_from_type(int_type, no, GranularityVar,
- !ProcInfo),
- !:MaybeGranularityVar = yes(GranularityVar),
-
- % XXX Check if the int module is imported (that is why
- % ModuleInfo can be modified).
-
- % Add the granularity variable to the head variables of the
- % procedure and update the argmodes.
- proc_info_get_argmodes(!.ProcInfo, ArgsModes0),
- proc_info_get_headvars(!.ProcInfo, HeadVars0),
- list.append(ArgsModes0, [in_mode], ArgsModes),
- list.append(HeadVars0, [GranularityVar], HeadVars),
- proc_info_set_argmodes(ArgsModes, !ProcInfo),
- proc_info_set_headvars(HeadVars, !ProcInfo)
- ),
-
- % Change the pred_id and the sym_name. We will deal with the
- % arguments later as they are not identical for the then and the
- % else part of the if_then_else goal introduced by the
- % transformation.
- !:CallExpr = plain_call(PredIdSpecialized, CallerProcId,
- CallArgs, CallBuiltin, CallUnifyContext, SymNameSpecialized),
- IsRecursiveCallInParallelConj = yes
- ;
- IsRecursiveCallInParallelConj = no
- )
+ !.GoalExpr = plain_call(CalleePredId, CalleeProcId, CallArgs, CallBuiltin,
+ CallUnifyContext, _),
+ (
+ IsInParallelConj = yes,
+ CalleePredId = CallerPredId,
+ CalleeProcId = CallerProcId
+ ->
+ % That is a recursive plain call in a parallel conjunction.
+ (
+ !.MaybeGranularityVar = yes(_GranularityVar),
+ % The variable Granularity has already been added to ProcInfo.
+ true
+ ;
+ !.MaybeGranularityVar = no,
+ % Add the variable Granularity to ProcInfo.
+ proc_info_create_var_from_type(int_type, no, GranularityVar,
+ !ProcInfo),
+ !:MaybeGranularityVar = yes(GranularityVar),
+
+ % XXX Check if the int module is imported (that is why
+ % ModuleInfo can be modified).
+
+ % Add the granularity variable to the head variables of the
+ % procedure and update the argmodes.
+ proc_info_get_argmodes(!.ProcInfo, ArgsModes0),
+ proc_info_get_headvars(!.ProcInfo, HeadVars0),
+ list.append(ArgsModes0, [in_mode], ArgsModes),
+ list.append(HeadVars0, [GranularityVar], HeadVars),
+ proc_info_set_argmodes(ArgsModes, !ProcInfo),
+ proc_info_set_headvars(HeadVars, !ProcInfo)
+ ),
+
+ % Change the pred_id and the sym_name. We will deal with the
+ % arguments later as they are not identical for the then and the
+ % else part of the if_then_else goal introduced by the
+ % transformation.
+ !:GoalExpr = plain_call(PredIdSpecialized, CallerProcId,
+ CallArgs, CallBuiltin, CallUnifyContext, SymNameSpecialized),
+ IsRecursiveCallInParallelConj = yes
;
- % Not a plain call.
- unexpected(this_file, "apply_dg_to_plain_call")
+ IsRecursiveCallInParallelConj = no
).
% Apply the distance granularity transformation to a conjunction.
%
-:- pred apply_dg_to_conj(hlds_goals::in, hlds_goals::in, hlds_goals::out,
- pred_id::in, proc_id::in, pred_id::in, sym_name::in,
- proc_info::in, proc_info::out, module_info::in, module_info::out, int::in,
- bool::in, maybe(prog_var)::in, maybe(prog_var)::out,
+:- pred apply_dg_to_conj(hlds_goals::in, hlds_goals::in, hlds_goals::out,
+ pred_id::in, proc_id::in, pred_id::in, sym_name::in,
+ proc_info::in, proc_info::out, module_info::in, module_info::out, int::in,
+ bool::in, maybe(prog_var)::in, maybe(prog_var)::out,
bool::in, bool::out) is det.
-apply_dg_to_conj([], !GoalsAcc, _CallerPredId, _CallerProcId,
- _PredIdSpecialized, _SymNameSpecialized, !ProcInfo, !ModuleInfo,
- _Distance, _IsInParallelConj,
+apply_dg_to_conj([], !GoalsAcc, _CallerPredId, _CallerProcId,
+ _PredIdSpecialized, _SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ _Distance, _IsInParallelConj,
!MaybeGranularityVar, !HasRecursiveCallsInParallelConj).
-apply_dg_to_conj([Goal0 | Goals], !GoalsAcc, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
- Distance, IsInParallelConj, !MaybeGranularityVar,
+apply_dg_to_conj([Goal0 | Goals], !GoalsAcc, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+ Distance, IsInParallelConj, !MaybeGranularityVar,
!HasRecursiveCallsInParallelConj) :-
apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId, PredIdSpecialized,
- SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, IsInParallelConj,
+ SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, IsInParallelConj,
!MaybeGranularityVar, IsRecursiveCall),
list.append(!.GoalsAcc, [Goal], !:GoalsAcc),
- (
+ (
IsRecursiveCall = yes,
- % The goal we just processed is a recursive call in a parallel
+ % The goal we just processed is a recursive call in a parallel
% conjunction. Therefore, the conjunction contains recursive calls.
!:HasRecursiveCallsInParallelConj = yes
;
IsRecursiveCall = no,
!:HasRecursiveCallsInParallelConj = !.HasRecursiveCallsInParallelConj
),
- apply_dg_to_conj(Goals, !GoalsAcc, CallerPredId, CallerProcId,
+ apply_dg_to_conj(Goals, !GoalsAcc, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance,
- IsInParallelConj, !MaybeGranularityVar,
+ IsInParallelConj, !MaybeGranularityVar,
!HasRecursiveCallsInParallelConj).
- % Create the if_then_else goal surrounding the recursive plain call as
+ % Create the if_then_else goal surrounding the recursive plain call as
% shown in the example.
%
-:- pred create_if_then_else_goal(hlds_goals::in, hlds_goal_info::in,
- maybe(prog_var)::in, pred_id::in, proc_id::in, int::in, hlds_goal::out,
+:- pred create_if_then_else_goal(hlds_goals::in, hlds_goal_info::in,
+ maybe(prog_var)::in, pred_id::in, proc_id::in, int::in, hlds_goal::out,
proc_info::in, proc_info::out, module_info::in) is det.
-create_if_then_else_goal(GoalsInConj, ConjInfo, MaybeGranularityVar,
- PredIdSpecialized, CallerProcId, Distance, IfThenElseGoal, !ProcInfo,
+create_if_then_else_goal(GoalsInConj, ConjInfo, MaybeGranularityVar,
+ PredIdSpecialized, CallerProcId, Distance, IfThenElseGoal, !ProcInfo,
ModuleInfo) :-
proc_info_create_var_from_type(int_type, no, Var, !ProcInfo),
make_int_const_construction(Var, 0, UnifyGoal),
- (
+ (
MaybeGranularityVar = yes(GranularityVar),
% Create the condition.
- make_simple_test(GranularityVar, Var,
+ make_simple_test(GranularityVar, Var,
umc_implicit("distance_granularity"), [], Test),
create_conj(UnifyGoal, Test, plain_conj, Cond),
-
+
% Create the then.
Then0 = hlds_goal(conj(parallel_conj, GoalsInConj), ConjInfo),
- apply_dg_to_then(Then0, Then, GranularityVar, PredIdSpecialized,
+ apply_dg_to_then(Then0, Then, GranularityVar, PredIdSpecialized,
CallerProcId, Distance, !ProcInfo),
-
+
% Create the else.
Else0 = hlds_goal(conj(plain_conj, GoalsInConj), ConjInfo),
- apply_dg_to_else(Else0, Else, GranularityVar, PredIdSpecialized,
+ apply_dg_to_else(Else0, Else, GranularityVar, PredIdSpecialized,
CallerProcId, ModuleInfo, !ProcInfo),
-
- % The non-locals of the hlds_goal_info of the if_then_else goal must
- % contain the variable controlling the granularity.
+
+ % The non-locals of the hlds_goal_info of the if_then_else goal must
+ % contain the variable controlling the granularity.
NonLocals0 = goal_info_get_nonlocals(ConjInfo),
set.insert(NonLocals0, GranularityVar, NonLocals),
goal_info_set_nonlocals(NonLocals, ConjInfo, IfThenElseInfo),
- IfThenElseGoal = hlds_goal(if_then_else([], Cond, Then, Else),
+ IfThenElseGoal = hlds_goal(if_then_else([], Cond, Then, Else),
IfThenElseInfo)
;
MaybeGranularityVar = no,
@@ -530,27 +529,27 @@
unexpected(this_file, "apply_dg_to_goal")
).
- % Update the then part of the new if_then_else goal introduced by the
+ % Update the then part of the new if_then_else goal introduced by the
% transformation as shown in the example. It creates a variable Granularity
- % containing the value Distance and uses it as the last argument of the
+ % containing the value Distance and uses it as the last argument of the
% calls of the recursive procedure.
%
-:- pred apply_dg_to_then(hlds_goal::in, hlds_goal::out, prog_var::in,
+:- pred apply_dg_to_then(hlds_goal::in, hlds_goal::out, prog_var::in,
pred_id::in, proc_id::in, int::in, proc_info::in, proc_info::out) is det.
-apply_dg_to_then(!Goal, GranularityVar, CallerPredId, CallerProcId, Distance,
+apply_dg_to_then(!Goal, GranularityVar, CallerPredId, CallerProcId, Distance,
!ProcInfo) :-
!.Goal = hlds_goal(GoalExpr0, GoalInfo),
- apply_dg_to_then2(GoalExpr0, GoalExpr, 1, _, GranularityVar, CallerPredId,
+ apply_dg_to_then2(GoalExpr0, GoalExpr, 1, _, GranularityVar, CallerPredId,
CallerProcId, Distance, !ProcInfo),
Goal0 = hlds_goal(GoalExpr, GoalInfo),
recompute_conj_info(Goal0, !:Goal).
-:- pred apply_dg_to_then2(hlds_goal_expr::in, hlds_goal_expr::out,
+:- pred apply_dg_to_then2(hlds_goal_expr::in, hlds_goal_expr::out,
int::in, int::out, prog_var::in, pred_id::in, proc_id::in, int::in,
proc_info::in, proc_info::out) is det.
-apply_dg_to_then2(!GoalExpr, !IndexInConj, GranularityVar, CallerPredId,
+apply_dg_to_then2(!GoalExpr, !IndexInConj, GranularityVar, CallerPredId,
CallerProcId, Distance, !ProcInfo) :-
( !.GoalExpr = conj(parallel_conj, Goals0) ->
list.length(Goals0, Length),
@@ -559,54 +558,55 @@
;
list.index1_det(Goals0, !.IndexInConj, Goal0),
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
- ( GoalExpr0 = plain_call(CalleePredId, CalleeProcId, CallArgs0,
- CallBuiltin, _, CallSymName)
+ (
+ GoalExpr0 = plain_call(CalleePredId, CalleeProcId, CallArgs0,
+ CallBuiltin, _, CallSymName)
->
( CalleePredId = CallerPredId, CalleeProcId = CallerProcId ->
% That is a recursive plain call.
-
+
% Create granularity variable containing value Distance.
- proc_info_create_var_from_type(int_type, no,
+ proc_info_create_var_from_type(int_type, no,
Var, !ProcInfo),
make_int_const_construction(Var, Distance, UnifyGoal),
-
+
% Use that variable as the last argument of the call.
list.append(CallArgs0, [Var], CallArgs),
-
- % If the original predicate is a function then the
+
+ % If the original predicate is a function then the
% specialized version is a predicate. Therefore, there is no
% need for the unify context anymore.
CallUnifyContext = no,
- GoalExpr = plain_call(CalleePredId, CalleeProcId, CallArgs,
+ GoalExpr = plain_call(CalleePredId, CalleeProcId, CallArgs,
CallBuiltin, CallUnifyContext, CallSymName),
-
+
% Var has instmap bound(Distance).
InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
- MerInst = bound(shared, [bound_functor(int_const(Distance),
- [])]),
- instmap_delta_insert(Var, MerInst, InstMapDelta0,
+ MerInst = bound(shared, [bound_functor(int_const(Distance),
+ [])]),
+ instmap_delta_insert(Var, MerInst, InstMapDelta0,
InstMapDelta),
- goal_info_set_instmap_delta(InstMapDelta, GoalInfo0,
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo0,
GoalInfo),
-
+
Goal = hlds_goal(GoalExpr, GoalInfo),
-
+
create_conj(UnifyGoal, Goal, plain_conj, PlainConj),
-
+
% Replace the call by the newly created conjunction.
- list.replace_nth_det(Goals0, !.IndexInConj, PlainConj,
+ list.replace_nth_det(Goals0, !.IndexInConj, PlainConj,
Goals),
!:GoalExpr = conj(parallel_conj, Goals)
;
% Not a recursive call.
true
),
- !:IndexInConj = !.IndexInConj + 1
+ !:IndexInConj = !.IndexInConj + 1
;
!:IndexInConj = !.IndexInConj + 1
),
- apply_dg_to_then2(!GoalExpr, !IndexInConj, GranularityVar,
+ apply_dg_to_then2(!GoalExpr, !IndexInConj, GranularityVar,
CallerPredId, CallerProcId, Distance, !ProcInfo)
)
;
@@ -623,7 +623,7 @@
goal_list_nonlocals(Goals, NonLocals),
goal_list_instmap_delta(Goals, InstMapDelta),
goal_list_determinism(Goals, Detism),
- goal_list_purity(Goals, Purity),
+ goal_list_purity(Goals, Purity),
goal_info_set_nonlocals(NonLocals, ConjInfo0, ConjInfo1),
goal_info_set_instmap_delta(InstMapDelta, ConjInfo1, ConjInfo2),
goal_info_set_determinism(Detism, ConjInfo2, ConjInfo3),
@@ -634,28 +634,28 @@
unexpected(this_file, "recompute_conj_info")
).
- % Update the else part of the new if_then_else goal introduced by the
- % transformation as shown in the example. It decrements the value of
- % GranularityVar and uses it as the last argument of the calls of the
+ % Update the else part of the new if_then_else goal introduced by the
+ % transformation as shown in the example. It decrements the value of
+ % GranularityVar and uses it as the last argument of the calls of the
% recursive procedure.
%
-:- pred apply_dg_to_else(hlds_goal::in, hlds_goal::out, prog_var::in,
- pred_id::in, proc_id::in, module_info::in,
+:- pred apply_dg_to_else(hlds_goal::in, hlds_goal::out, prog_var::in,
+ pred_id::in, proc_id::in, module_info::in,
proc_info::in, proc_info::out) is det.
-apply_dg_to_else(!Goal, GranularityVar, CallerPredId, CallerProcId,
+apply_dg_to_else(!Goal, GranularityVar, CallerPredId, CallerProcId,
ModuleInfo, !ProcInfo) :-
!.Goal = hlds_goal(GoalExpr0, GoalInfo),
- apply_dg_to_else2(GoalExpr0, GoalExpr, 1, _, GranularityVar, CallerPredId,
+ apply_dg_to_else2(GoalExpr0, GoalExpr, 1, _, GranularityVar, CallerPredId,
CallerProcId, ModuleInfo, !ProcInfo),
Goal0 = hlds_goal(GoalExpr, GoalInfo),
recompute_conj_info(Goal0, !:Goal).
-:- pred apply_dg_to_else2(hlds_goal_expr::in, hlds_goal_expr::out,
- int::in, int::out, prog_var::in, pred_id::in, proc_id::in,
+:- pred apply_dg_to_else2(hlds_goal_expr::in, hlds_goal_expr::out,
+ int::in, int::out, prog_var::in, pred_id::in, proc_id::in,
module_info::in, proc_info::in, proc_info::out) is det.
-apply_dg_to_else2(!GoalExpr, !IndexInConj, GranularityVar, CallerPredId,
+apply_dg_to_else2(!GoalExpr, !IndexInConj, GranularityVar, CallerPredId,
CallerProcId, ModuleInfo, !ProcInfo) :-
( !.GoalExpr = conj(plain_conj, Goals0) ->
list.length(Goals0, Length),
@@ -664,41 +664,45 @@
;
list.index1_det(Goals0, !.IndexInConj, Goal0),
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
- ( GoalExpr0 = plain_call(CalleePredId, CalleeProcId, CallArgs0,
- CallBuiltin, _, CallSymName)
+ (
+ GoalExpr0 = plain_call(CalleePredId, CalleeProcId, CallArgs0,
+ CallBuiltin, _, CallSymName)
->
- ( CalleePredId = CallerPredId, CalleeProcId = CallerProcId ->
+ (
+ CalleePredId = CallerPredId,
+ CalleeProcId = CallerProcId
+ ->
% That is a recursive plain call.
-
+
% Create an int variable containing the value 1.
- proc_info_create_var_from_type(int_type, no,
+ proc_info_create_var_from_type(int_type, no,
Var, !ProcInfo),
make_int_const_construction(Var, 1, UnifyGoal),
-
- % Create a variable which will contain the decremented
+
+ % Create a variable which will contain the decremented
% granularity distance.
- proc_info_create_var_from_type(int_type, no,
+ proc_info_create_var_from_type(int_type, no,
VarResult, !ProcInfo),
-
+
% Decrement GranularityVar before the call.
- lookup_builtin_pred_proc_id(ModuleInfo,
- unqualified("int"), "minus", pf_function, 2, only_mode,
+ lookup_builtin_pred_proc_id(ModuleInfo,
+ unqualified("int"), "minus", pf_function, 2, only_mode,
MinusPredId, MinusProcId),
MinusCallArgs = [GranularityVar, Var, VarResult],
MinusCallBuiltin = inline_builtin,
MinusCallSymName = qualified(unqualified("int"),"-"),
- Rhs = rhs_functor(cons(MinusCallSymName, 2), no,
+ Rhs = rhs_functor(cons(MinusCallSymName, 2), no,
[GranularityVar, Var]),
- MinusCallUnifyContext = yes(call_unify_context(VarResult,
+ MinusCallUnifyContext = yes(call_unify_context(VarResult,
Rhs, unify_context(
umc_implicit("distance_granularity"), []))),
- DecrementGoalExpr = plain_call(MinusPredId, MinusProcId,
- MinusCallArgs, MinusCallBuiltin, MinusCallUnifyContext,
+ DecrementGoalExpr = plain_call(MinusPredId, MinusProcId,
+ MinusCallArgs, MinusCallBuiltin, MinusCallUnifyContext,
MinusCallSymName),
- set.list_to_set([GranularityVar, Var, VarResult],
+ set.list_to_set([GranularityVar, Var, VarResult],
NonLocals),
- VarResultDelta = VarResult - ground(unique, none),
- VarDelta = Var - bound(shared, [bound_functor(int_const(1),
+ VarResultDelta = VarResult - ground(unique, none),
+ VarDelta = Var - bound(shared, [bound_functor(int_const(1),
[])]),
instmap_delta_from_assoc_list([VarDelta, VarResultDelta],
InstMapDeltaDecrement),
@@ -708,36 +712,36 @@
list.index1_det(Goals0, 1, FirstGoal),
FirstGoal = hlds_goal(_, FirstGoalInfo),
Context = goal_info_get_context(FirstGoalInfo),
- goal_info_init(NonLocals, InstMapDeltaDecrement, Detism,
+ goal_info_init(NonLocals, InstMapDeltaDecrement, Detism,
Purity, Context, DecrementGoalInfo),
- DecrementGoal = hlds_goal(DecrementGoalExpr,
+ DecrementGoal = hlds_goal(DecrementGoalExpr,
DecrementGoalInfo),
-
- % Use the decremented value of GranularityVar as the
+
+ % Use the decremented value of GranularityVar as the
% last argument of the call.
list.append(CallArgs0, [VarResult], CallArgs),
- % If the original predicate is a function then the
- % specialized version is a predicate. Therefore, there is no
- % need for the unify context anymore.
+ % If the original predicate is a function then the
+ % specialized version is a predicate. Therefore, there is
+ % no need for the unify context anymore.
CallUnifyContext = no,
-
- GoalExpr = plain_call(CalleePredId, CalleeProcId, CallArgs,
+
+ GoalExpr = plain_call(CalleePredId, CalleeProcId, CallArgs,
CallBuiltin, CallUnifyContext, CallSymName),
InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
- MerInst = ground(shared, none),
- instmap_delta_insert(Var, MerInst, InstMapDelta0,
+ MerInst = ground(shared, none),
+ instmap_delta_insert(Var, MerInst, InstMapDelta0,
InstMapDelta),
- goal_info_set_instmap_delta(InstMapDelta, GoalInfo0,
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo0,
GoalInfo),
Goal = hlds_goal(GoalExpr, GoalInfo),
list.replace_nth_det(Goals0, !.IndexInConj, Goal, Goals1),
-
+
% Append the goals in the right order.
- list.det_split_list(!.IndexInConj - 1, Goals1, StartGoals,
+ list.det_split_list(!.IndexInConj - 1, Goals1, StartGoals,
EndGoals),
list.append(StartGoals, [UnifyGoal], GoalsAppend0),
- list.append(GoalsAppend0, [DecrementGoal],
+ list.append(GoalsAppend0, [DecrementGoal],
GoalsAppend1),
list.append(GoalsAppend1, EndGoals, Goals),
!:GoalExpr = conj(plain_conj, Goals)
@@ -745,11 +749,11 @@
% Not a recursive call.
true
),
- !:IndexInConj = !.IndexInConj + 3
+ !:IndexInConj = !.IndexInConj + 3
;
!:IndexInConj = !.IndexInConj + 1
),
- apply_dg_to_else2(!GoalExpr, !IndexInConj, GranularityVar,
+ apply_dg_to_else2(!GoalExpr, !IndexInConj, GranularityVar,
CallerPredId, CallerProcId, ModuleInfo, !ProcInfo)
)
;
@@ -758,53 +762,53 @@
% Apply the distance granularity transformation to a disjunction.
%
-:- pred apply_dg_to_disj(list(hlds_goal)::in,
- list(hlds_goal)::in, list(hlds_goal)::out, pred_id::in, proc_id::in,
- pred_id::in, sym_name::in, proc_info::in, proc_info::out,
- module_info::in, module_info::out, int::in,
+:- pred apply_dg_to_disj(list(hlds_goal)::in,
+ list(hlds_goal)::in, list(hlds_goal)::out, pred_id::in, proc_id::in,
+ pred_id::in, sym_name::in, proc_info::in, proc_info::out,
+ module_info::in, module_info::out, int::in,
maybe(prog_var)::in, maybe(prog_var)::out) is det.
-apply_dg_to_disj([], !GoalsAcc, _CallerPredId, _CallerProcId,
- _PredIdSpecialized, _SymNameSpecialized, !ProcInfo, !ModuleInfo,
+apply_dg_to_disj([], !GoalsAcc, _CallerPredId, _CallerProcId,
+ _PredIdSpecialized, _SymNameSpecialized, !ProcInfo, !ModuleInfo,
_Distance, !MaybeGranularityVar).
-apply_dg_to_disj([Goal0 | Goals], !GoalsAcc, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+apply_dg_to_disj([Goal0 | Goals], !GoalsAcc, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, !MaybeGranularityVar) :-
apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId, PredIdSpecialized,
- SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, no,
+ SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, no,
!MaybeGranularityVar, _),
list.append( !.GoalsAcc, [Goal], !:GoalsAcc),
- apply_dg_to_disj(Goals, !GoalsAcc, CallerPredId, CallerProcId,
+ apply_dg_to_disj(Goals, !GoalsAcc, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance,
!MaybeGranularityVar).
% Apply the distance granularity transformation to a switch.
%
:- pred apply_dg_to_switch(
- list(case)::in, list(case)::in, list(case)::out, pred_id::in,
- proc_id::in, pred_id::in, sym_name::in, proc_info::in, proc_info::out,
+ list(case)::in, list(case)::in, list(case)::out, pred_id::in,
+ proc_id::in, pred_id::in, sym_name::in, proc_info::in, proc_info::out,
module_info::in, module_info::out, int::in,
maybe(prog_var)::in, maybe(prog_var)::out) is det.
-apply_dg_to_switch([], !CasesAcc, _CallerPredId, _CallerProcId,
- _PredIdSpecialized, _SymNameSpecialized, !ProcInfo, !ModuleInfo,
+apply_dg_to_switch([], !CasesAcc, _CallerPredId, _CallerProcId,
+ _PredIdSpecialized, _SymNameSpecialized, !ProcInfo, !ModuleInfo,
_Distance, !MaybeGranularityVar).
-apply_dg_to_switch([Case | Cases], !CasesAcc, CallerPredId, CallerProcId,
- PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
+apply_dg_to_switch([Case | Cases], !CasesAcc, CallerPredId, CallerProcId,
+ PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo,
Distance, !MaybeGranularityVar) :-
- Case = case(Functor, Goal0),
+ Case = case(Functor, Goal0),
apply_dg_to_goal(Goal0, Goal, CallerPredId, CallerProcId, PredIdSpecialized,
- SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, no,
+ SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance, no,
!MaybeGranularityVar, _),
!:CasesAcc = [case(Functor, Goal) | !.CasesAcc],
- apply_dg_to_switch(Cases, !CasesAcc, CallerPredId, CallerProcId,
+ apply_dg_to_switch(Cases, !CasesAcc, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, !ModuleInfo, Distance,
!MaybeGranularityVar).
- % Create the string name of the specialized predicate (same format as
+ % Create the string name of the specialized predicate (same format as
% make_pred_name in prog_util) out of the name of the original one.
%
-:- pred create_specialized_pred_name(string::in, int::in,
+:- pred create_specialized_pred_name(string::in, int::in,
string::in, string::out) is det.
create_specialized_pred_name(Prefix, Distance, !PredName) :-
@@ -819,52 +823,55 @@
%-----------------------------------------------------------------------------%
- % This section contains predicates that make the granularity control
+ % This section contains predicates that make the granularity control
% transparent to the original procedure's callers by replacing the recursive
% calls in the body of the original procedure with calls to the specialized
- % version.
+ % version.
- % Update the recursive calls in each procedure in the list so that the
+ % Update the recursive calls in each procedure in the list so that the
% pred_id called is the one of the specialized procedure.
%
:- pred update_original_predicate_procs(pred_id::in, list(proc_id)::in, int::in,
- pred_id::in, sym_name::in, pred_info::in, pred_info::out,
+ pred_id::in, sym_name::in, pred_info::in, pred_info::out,
module_info::in, module_info::out) is det.
-update_original_predicate_procs(_PredId, [], _Distance, _PredIdSpecialized,
+update_original_predicate_procs(_PredId, [], _Distance, _PredIdSpecialized,
_SymNameSpecialized, !PredInfo, !ModuleInfo).
-update_original_predicate_procs(PredId, [ProcId | ProcIds], Distance,
- PredIdSpecialized, SymNameSpecialized, !PredInfo,
+update_original_predicate_procs(PredId, [ProcId | ProcIds], Distance,
+ PredIdSpecialized, SymNameSpecialized, !PredInfo,
!ModuleInfo) :-
module_info_proc_info(!.ModuleInfo, proc(PredId, ProcId), ProcInfo0),
proc_info_get_goal(ProcInfo0, Body0),
- update_original_predicate_goal(Body0, Body, PredId, ProcId,
+ update_original_predicate_goal(Body0, Body, PredId, ProcId,
PredIdSpecialized, SymNameSpecialized, ProcInfo0, ProcInfo1, Distance),
proc_info_set_goal(Body, ProcInfo1, ProcInfo2),
requantify_proc(ProcInfo2, ProcInfo3),
RecomputeAtomic = no,
- recompute_instmap_delta_proc(RecomputeAtomic, ProcInfo3,
+ recompute_instmap_delta_proc(RecomputeAtomic, ProcInfo3,
ProcInfo, !ModuleInfo),
pred_info_set_proc_info(ProcId, ProcInfo, !PredInfo),
- update_original_predicate_procs(PredId, ProcIds, Distance,
+ update_original_predicate_procs(PredId, ProcIds, Distance,
PredIdSpecialized, SymNameSpecialized, !PredInfo, !ModuleInfo).
% Update the recursive calls of a goal so that the pred_id called is the one
% of the specialized procedure.
%
-:- pred update_original_predicate_goal(hlds_goal::in, hlds_goal::out,
- pred_id::in, proc_id::in, pred_id::in, sym_name::in,
+:- pred update_original_predicate_goal(hlds_goal::in, hlds_goal::out,
+ pred_id::in, proc_id::in, pred_id::in, sym_name::in,
proc_info::in, proc_info::out, int::in) is det.
-update_original_predicate_goal(!Goal, CallerPredId, CallerProcId,
+update_original_predicate_goal(!Goal, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance) :-
!.Goal = hlds_goal(GoalExpr0, GoalInfo),
(
GoalExpr0 = unify(_, _, _, _, _)
;
GoalExpr0 = plain_call(_, _, _, _, _, _),
- update_original_predicate_plain_call(!Goal, CallerPredId, CallerProcId,
+ % XXX Due to the absence of alias tracking, passing !.Goal instead of
+ % !.Goal would result in a mode error.
+ !:Goal = hlds_goal(GoalExpr0, GoalInfo),
+ update_original_predicate_plain_call(!Goal, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance)
;
GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _)
@@ -872,8 +879,8 @@
GoalExpr0 = generic_call(_, _, _, _)
;
GoalExpr0 = conj(Type, Goals0),
- update_original_predicate_goals(Goals0, [], Goals1, CallerPredId,
- CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
+ update_original_predicate_goals(Goals0, [], Goals1, CallerPredId,
+ CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
Distance),
(
Type = plain_conj,
@@ -881,7 +888,7 @@
;
Type = parallel_conj,
% No need to flatten parallel conjunctions as the transformation may
- % only create plain conjunctions
+ % only create plain conjunctions
% (see update_original_predicate_plain_call).
Goals = Goals1
),
@@ -889,37 +896,37 @@
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
GoalExpr0 = disj(Goals0),
- update_original_predicate_goals(Goals0, [], Goals, CallerPredId,
- CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
+ update_original_predicate_goals(Goals0, [], Goals, CallerPredId,
+ CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
Distance),
GoalExpr = disj(Goals),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
GoalExpr0 = switch(Var, CanFail, Cases0),
- update_original_predicate_switch(Cases0, [], Cases, CallerPredId,
- CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
+ update_original_predicate_switch(Cases0, [], Cases, CallerPredId,
+ CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
Distance),
GoalExpr = switch(Var, CanFail, Cases),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
GoalExpr0 = negation(Goal0),
- update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
+ update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance),
GoalExpr = negation(Goal),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
GoalExpr0 = scope(Reason, Goal0),
- update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
+ update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance),
GoalExpr = scope(Reason, Goal),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
- update_original_predicate_goal(Cond0, Cond, CallerPredId, CallerProcId,
+ update_original_predicate_goal(Cond0, Cond, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance),
- update_original_predicate_goal(Then0, Then, CallerPredId, CallerProcId,
+ update_original_predicate_goal(Then0, Then, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance),
- update_original_predicate_goal(Else0, Else, CallerPredId, CallerProcId,
+ update_original_predicate_goal(Else0, Else, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance),
GoalExpr = if_then_else(Vars, Cond, Then, Else),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
@@ -929,98 +936,98 @@
unexpected(this_file, "update_original_predicate_goal")
).
- % Update the plain call so that the pred_id called is the one of the
+ % Update the plain call so that the pred_id called is the one of the
% specialized procedure.
%
-:- pred update_original_predicate_plain_call(hlds_goal::in, hlds_goal::out,
- pred_id::in, proc_id::in, pred_id::in, sym_name::in,
+:- pred update_original_predicate_plain_call(
+ hlds_goal::in(plain_call), hlds_goal::out,
+ pred_id::in, proc_id::in, pred_id::in, sym_name::in,
proc_info::in, proc_info::out, int::in) is det.
-update_original_predicate_plain_call(!Call, CallerPredId, CallerProcId,
+update_original_predicate_plain_call(!Goal, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance) :-
- !.Call = hlds_goal(CallExpr0, CallInfo0),
- ( CallExpr0 = plain_call(CalleePredId, CalleeProcId, CallArgs0,
- CallBuiltin, _, _) ->
- ( CalleePredId = CallerPredId, CalleeProcId = CallerProcId ->
- % That is a recursive plain call.
-
- % Create the int variable which will be used as the last argument of
- % the call.
- proc_info_create_var_from_type(int_type, no, Var, !ProcInfo),
- make_int_const_construction(Var, Distance, UnifyGoal),
- list.append(CallArgs0, [Var], CallArgs),
-
- % If the original predicate is a function then the specialized
- % version is a predicate. Therefore, there is no need for the unify
- % context anymore.
- CallUnifyContext = no,
-
- % Update the pred_id to the pred_id of the specialized pred.
- CallExpr = plain_call(PredIdSpecialized, CalleeProcId, CallArgs,
- CallBuiltin, CallUnifyContext, SymNameSpecialized),
-
- % Update the nonlocals and the instmap_delta of the hlds_goal_info
- % of the recursive plain call for Var.
- NonLocals0 = goal_info_get_nonlocals(CallInfo0),
- set.insert(NonLocals0, Var, NonLocals),
- goal_info_set_nonlocals(NonLocals, CallInfo0, CallInfo1),
- InstMapDelta0 = goal_info_get_instmap_delta(CallInfo1),
- MerInst = ground(shared, none),
- instmap_delta_insert(Var, MerInst, InstMapDelta0, InstMapDelta),
- goal_info_set_instmap_delta(InstMapDelta, CallInfo1, CallInfo),
- Call = hlds_goal(CallExpr, CallInfo),
-
- % The resuling conjunction may not be flat. We deal with that after
- % the conjunction has been processed
- % (see update_original_predicate_goal).
- create_conj(UnifyGoal, Call, plain_conj, !:Call)
- ;
- true
- )
+ !.Goal = hlds_goal(CallExpr0, CallInfo0),
+ CallExpr0 = plain_call(CalleePredId, CalleeProcId, CallArgs0,
+ CallBuiltin, _, _),
+ (
+ CalleePredId = CallerPredId,
+ CalleeProcId = CallerProcId
+ ->
+ % That is a recursive plain call.
+
+ % Create the int variable which will be used as the last argument of
+ % the call.
+ proc_info_create_var_from_type(int_type, no, Var, !ProcInfo),
+ make_int_const_construction(Var, Distance, UnifyGoal),
+ list.append(CallArgs0, [Var], CallArgs),
+
+ % If the original predicate is a function then the specialized
+ % version is a predicate. Therefore, there is no need for the unify
+ % context anymore.
+ CallUnifyContext = no,
+
+ % Update the pred_id to the pred_id of the specialized pred.
+ CallExpr = plain_call(PredIdSpecialized, CalleeProcId, CallArgs,
+ CallBuiltin, CallUnifyContext, SymNameSpecialized),
+
+ % Update the nonlocals and the instmap_delta of the hlds_goal_info
+ % of the recursive plain call for Var.
+ NonLocals0 = goal_info_get_nonlocals(CallInfo0),
+ set.insert(NonLocals0, Var, NonLocals),
+ goal_info_set_nonlocals(NonLocals, CallInfo0, CallInfo1),
+ InstMapDelta0 = goal_info_get_instmap_delta(CallInfo1),
+ MerInst = ground(shared, none),
+ instmap_delta_insert(Var, MerInst, InstMapDelta0, InstMapDelta),
+ goal_info_set_instmap_delta(InstMapDelta, CallInfo1, CallInfo),
+ Call = hlds_goal(CallExpr, CallInfo),
+
+ % The resuling conjunction may not be flat. We deal with that after
+ % the conjunction has been processed
+ % (see update_original_predicate_goal).
+ create_conj(UnifyGoal, Call, plain_conj, !:Goal)
;
- % Not a plain call.
- unexpected(this_file, "update_original_predicate_plain_call")
+ true
).
- % Update the recursive calls of each goal in the list so that the pred_id
+ % Update the recursive calls of each goal in the list so that the pred_id
% called is the one of the specialized procedure.
%
-:- pred update_original_predicate_goals(list(hlds_goal)::in,
- list(hlds_goal)::in, list(hlds_goal)::out, pred_id::in, proc_id::in,
+:- pred update_original_predicate_goals(list(hlds_goal)::in,
+ list(hlds_goal)::in, list(hlds_goal)::out, pred_id::in, proc_id::in,
pred_id::in, sym_name::in, proc_info::in, proc_info::out, int::in) is det.
-update_original_predicate_goals([], !GoalsAcc, _CallerPredId,
- _CallerProcId, _PredIdSpecialized, _SymNameSpecialized, !ProcInfo,
+update_original_predicate_goals([], !GoalsAcc, _CallerPredId,
+ _CallerProcId, _PredIdSpecialized, _SymNameSpecialized, !ProcInfo,
_Distance).
-update_original_predicate_goals([Goal0 | Goals], !GoalsAcc, CallerPredId,
- CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
+update_original_predicate_goals([Goal0 | Goals], !GoalsAcc, CallerPredId,
+ CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
Distance) :-
- update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
+ update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance),
list.append(!.GoalsAcc, [Goal], !:GoalsAcc),
- update_original_predicate_goals(Goals, !GoalsAcc, CallerPredId,
- CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
+ update_original_predicate_goals(Goals, !GoalsAcc, CallerPredId,
+ CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
Distance).
% Update the recursive calls of a switch so that the pred_id called is the
% one of the specialized procedure.
%
:- pred update_original_predicate_switch(
- list(case)::in, list(case)::in, list(case)::out, pred_id::in,
- proc_id::in, pred_id::in, sym_name::in, proc_info::in, proc_info::out,
+ list(case)::in, list(case)::in, list(case)::out, pred_id::in,
+ proc_id::in, pred_id::in, sym_name::in, proc_info::in, proc_info::out,
int::in) is det.
-update_original_predicate_switch([], !CasesAcc, _CallerPredId, _CallerProcId,
+update_original_predicate_switch([], !CasesAcc, _CallerPredId, _CallerProcId,
_PredIdSpecialized, _SymNameSpecialized, !ProcInfo, _Distance).
-update_original_predicate_switch([Case | Cases], !CasesAcc, CallerPredId,
- CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
+update_original_predicate_switch([Case | Cases], !CasesAcc, CallerPredId,
+ CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
Distance) :-
- Case = case(Functor, Goal0),
- update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
+ Case = case(Functor, Goal0),
+ update_original_predicate_goal(Goal0, Goal, CallerPredId, CallerProcId,
PredIdSpecialized, SymNameSpecialized, !ProcInfo, Distance),
!:CasesAcc = [ case(Functor, Goal) | !.CasesAcc ],
- update_original_predicate_switch(Cases, !CasesAcc, CallerPredId,
- CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
+ update_original_predicate_switch(Cases, !CasesAcc, CallerPredId,
+ CallerProcId, PredIdSpecialized, SymNameSpecialized, !ProcInfo,
Distance).
%-----------------------------------------------------------------------------%
Index: compiler/elds_to_erlang.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/elds_to_erlang.m,v
retrieving revision 1.31
diff -u -r1.31 elds_to_erlang.m
--- compiler/elds_to_erlang.m 4 Oct 2007 00:36:52 -0000 1.31
+++ compiler/elds_to_erlang.m 21 Nov 2007 08:21:50 -0000
@@ -979,10 +979,10 @@
PredArity, ProcId, PredIsImported, MaybeExtModule, ProcNameStr) :-
(
% XXX not completely sure this is right
- PredIsImported = yes
- ->
+ PredIsImported = yes,
MaybeExtModule = yes(erlang_module_name_to_str(PredModule))
;
+ PredIsImported = no,
MaybeExtModule = no
),
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.45
diff -u -r1.45 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 28 Sep 2007 03:17:11 -0000 1.45
+++ compiler/equiv_type_hlds.m 22 Nov 2007 01:51:09 -0000
@@ -89,7 +89,8 @@
add_type_to_eqv_map(TypeCtor, Defn, !EqvMap, !EqvExportTypes) :-
hlds_data.get_type_defn_body(Defn, Body),
- ( Body = hlds_eqv_type(EqvType) ->
+ (
+ Body = hlds_eqv_type(EqvType),
hlds_data.get_type_defn_tvarset(Defn, TVarSet),
hlds_data.get_type_defn_tparams(Defn, Params),
hlds_data.get_type_defn_status(Defn, Status),
@@ -103,7 +104,11 @@
IsExported = no
)
;
- true
+ ( Body = hlds_du_type(_, _, _, _, _, _, _)
+ ; Body = hlds_foreign_type(_)
+ ; Body = hlds_solver_type(_, _)
+ ; Body = hlds_abstract_type(_)
+ )
).
:- pred add_type_ctors_to_set(mer_type::in,
@@ -844,9 +849,13 @@
create_poly_info(!.Info ^ module_info, PredInfo0, !.Info ^ proc_info,
PolyInfo0),
rtti_varmaps_var_info(RttiVarMaps, Var, VarInfo),
- ( VarInfo = type_info_var(TypeInfoType0) ->
+ (
+ VarInfo = type_info_var(TypeInfoType0),
TypeInfoType = TypeInfoType0
;
+ ( VarInfo = typeclass_info_var(_)
+ ; VarInfo = non_rtti_var
+ ),
unexpected(this_file, "replace_in_goal_expr: info not found")
),
polymorphism_make_type_info_var(TypeInfoType,
Index: compiler/erl_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_util.m,v
retrieving revision 1.15
diff -u -r1.15 erl_code_util.m
--- compiler/erl_code_util.m 17 Aug 2007 02:08:38 -0000 1.15
+++ compiler/erl_code_util.m 21 Nov 2007 08:23:55 -0000
@@ -350,24 +350,28 @@
VarNames1, ArgTypes1, ArgModes1, Inputs1, Outputs1),
(
OptDummyArgs = opt_dummy_args,
+ % Exclude arguments of type io.state etc.
+ % Also exclude those with arg_mode `top_unused'.
( is_dummy_argument_type(ModuleInfo, ArgType)
; ArgMode = top_unused
)
->
- % Exclude arguments of type io.state etc.
- % Also exclude those with arg_mode `top_unused'.
Inputs = Inputs1,
Outputs = Outputs1
;
- ArgMode = top_in
- ->
- % It's an input argument.
- Inputs = [VarName | Inputs1],
- Outputs = Outputs1
- ;
- % It's an output argument.
- Inputs = Inputs1,
- Outputs = [VarName | Outputs1]
+ (
+ ArgMode = top_in,
+ % It's an input argument.
+ Inputs = [VarName | Inputs1],
+ Outputs = Outputs1
+ ;
+ ( ArgMode = top_out
+ ; ArgMode = top_unused
+ ),
+ % It's an output argument.
+ Inputs = Inputs1,
+ Outputs = [VarName | Outputs1]
+ )
)
;
unexpected(this_file, "erl_gen_arg_list_arg_modes: length mismatch")
Index: compiler/erl_rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_rtti.m,v
retrieving revision 1.18
diff -u -r1.18 erl_rtti.m
--- compiler/erl_rtti.m 11 Sep 2007 03:12:28 -0000 1.18
+++ compiler/erl_rtti.m 21 Nov 2007 08:24:18 -0000
@@ -128,13 +128,15 @@
erlang_type_ctor_details_2(enum(_, Functors, _, _, IsDummy, FunctorNums))
= Details :-
- ( IsDummy = yes ->
+ (
+ IsDummy = yes,
( Functors = [F] ->
Details = erlang_dummy(F ^ enum_name)
;
unexpected(this_file, "dummy type with more than one functor")
)
;
+ IsDummy = no,
list.map_corresponding(convert_enum_functor, Functors, FunctorNums,
ErlFunctors),
Details = erlang_du(ErlFunctors)
Index: compiler/exception_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exception_analysis.m,v
retrieving revision 1.40
diff -u -r1.40 exception_analysis.m
--- compiler/exception_analysis.m 20 Aug 2007 03:35:53 -0000 1.40
+++ compiler/exception_analysis.m 22 Nov 2007 02:00:28 -0000
@@ -1300,10 +1300,14 @@
!AnalysisInfo, !IO),
(
MaybeBestStatus = yes({_Call, Answer, AnalysisStatus}),
- ( AnalysisStatus = invalid ->
+ (
+ AnalysisStatus = invalid,
unexpected(this_file,
"invalid exception_analysis answer")
;
+ ( AnalysisStatus = optimal
+ ; AnalysisStatus = suboptimal
+ ),
Answer = exception_analysis_answer(ExceptionStatus)
)
;
Index: compiler/export.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.117
diff -u -r1.117 export.m
--- compiler/export.m 25 Sep 2007 04:56:38 -0000 1.117
+++ compiler/export.m 21 Nov 2007 05:27:32 -0000
@@ -507,10 +507,14 @@
ArgName = ""
),
TypeString0 = mercury_exported_type_to_string(ModuleInfo, lang_c, Type),
- ( Mode = top_out ->
+ (
+ Mode = top_out,
% output variables are passed as pointers
TypeString = TypeString0 ++ " *"
;
+ ( Mode = top_in
+ ; Mode = top_unused
+ ),
TypeString = TypeString0
).
@@ -596,7 +600,8 @@
).
convert_type_to_mercury(Rval, Type, ConvertedRval) :-
- ( Type = builtin_type(BuiltinType) ->
+ (
+ Type = builtin_type(BuiltinType),
(
BuiltinType = builtin_type_string,
ConvertedRval = "(MR_Word) " ++ Rval
@@ -614,15 +619,39 @@
ConvertedRval = Rval
)
;
+ ( Type = type_variable(_, _)
+ ; Type = defined_type(_, _, _)
+ ; Type = higher_order_type(_, _, _, _)
+ ; Type = tuple_type(_, _)
+ ; Type = apply_n_type(_, _, _)
+ ; Type = kinded_type(_, _)
+ ),
ConvertedRval = Rval
).
convert_type_from_mercury(Rval, Type, ConvertedRval) :-
- ( Type = builtin_type(builtin_type_string) ->
- ConvertedRval = "(MR_String) " ++ Rval
- ; Type = builtin_type(builtin_type_float) ->
- ConvertedRval = "MR_word_to_float(" ++ Rval ++ ")"
+ (
+ Type = builtin_type(BuiltinType),
+ (
+ BuiltinType = builtin_type_string,
+ ConvertedRval = "(MR_String) " ++ Rval
+ ;
+ BuiltinType = builtin_type_float,
+ ConvertedRval = "MR_word_to_float(" ++ Rval ++ ")"
+ ;
+ ( BuiltinType = builtin_type_int
+ ; BuiltinType = builtin_type_character
+ ),
+ ConvertedRval = Rval
+ )
;
+ ( Type = type_variable(_, _)
+ ; Type = defined_type(_, _, _)
+ ; Type = higher_order_type(_, _, _, _)
+ ; Type = tuple_type(_, _)
+ ; Type = apply_n_type(_, _, _)
+ ; Type = kinded_type(_, _)
+ ),
ConvertedRval = Rval
).
@@ -643,8 +672,7 @@
module_name_to_file_name(ModuleName, HeaderExt, yes, FileName, !IO),
io.open_output(FileName ++ ".tmp", Result, !IO),
(
- Result = ok(FileStream)
- ->
+ Result = ok(FileStream),
io.set_output_stream(FileStream, OutputStream, !IO),
module_name_to_file_name(ModuleName, ".m", no, SourceFileName, !IO),
library.version(Version),
@@ -699,6 +727,7 @@
% rename "<ModuleName>.mh.tmp" to "<ModuleName>.mh".
update_interface(FileName, !IO)
;
+ Result = error(_),
io.progname_base("export.m", ProgName, !IO),
io.write_string("\n", !IO),
io.write_string(ProgName, !IO),
Index: compiler/exprn_aux.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exprn_aux.m,v
retrieving revision 1.85
diff -u -r1.85 exprn_aux.m
--- compiler/exprn_aux.m 11 Oct 2007 11:45:17 -0000 1.85
+++ compiler/exprn_aux.m 21 Nov 2007 14:55:39 -0000
@@ -20,7 +20,6 @@
:- import_module assoc_list.
:- import_module bool.
:- import_module list.
-:- import_module maybe.
%-----------------------------------------------------------------------------%
@@ -39,16 +38,6 @@
%
:- pred const_is_constant(rval_const::in, exprn_opts::in, bool::out) is det.
-:- pred rval_contains_lval(rval::in, lval::in) is semidet.
-
-:- pred rval_contains_rval(rval, rval).
-:- mode rval_contains_rval(in, in) is semidet.
-:- mode rval_contains_rval(in, out) is multidet.
-
-:- pred args_contain_rval(list(maybe(rval)), rval).
-:- mode args_contain_rval(in, in) is semidet.
-:- mode args_contain_rval(in, out) is nondet.
-
% transform_lval_in_instr(Transform, !Instr, !Acc):
%
% Transform all lvals in !.Instr with the predicate Transform.
@@ -126,6 +115,7 @@
:- import_module getopt_io.
:- import_module int.
+:- import_module maybe.
:- import_module pair.
:- import_module set.
@@ -200,82 +190,6 @@
%-----------------------------------------------------------------------------%
-rval_contains_lval(lval(Lval0), Lval) :-
- lval_contains_lval(Lval0, Lval).
-rval_contains_lval(mkword(_, Rval), Lval) :-
- rval_contains_lval(Rval, Lval).
-rval_contains_lval(unop(_, Rval), Lval) :-
- rval_contains_lval(Rval, Lval).
-rval_contains_lval(binop(_, Rval0, Rval1), Lval) :-
- (
- rval_contains_lval(Rval0, Lval)
- ;
- rval_contains_lval(Rval1, Lval)
- ).
-
-:- pred lval_contains_lval(lval::in, lval::in) is semidet.
-
-lval_contains_lval(Lval0, Lval) :-
- ( Lval0 = Lval ->
- true
- ; Lval0 = field(_MaybeTag, Rval0, Rval1) ->
- (
- rval_contains_lval(Rval0, Lval)
- ;
- rval_contains_lval(Rval1, Lval)
- )
- ; Lval0 = lvar(_Var) ->
- unexpected(this_file, "lval_contains_lval: var! I can't tell")
- ;
- fail
- ).
-
-%-----------------------------------------------------------------------------%
-
-rval_contains_rval(Rval0, Rval) :-
- (
- Rval0 = Rval
- ;
- (
- Rval0 = lval(Lval),
- lval_contains_rval(Lval, Rval)
- ;
- Rval0 = mkword(_, Rval1),
- rval_contains_rval(Rval1, Rval)
- ;
- Rval0 = unop(_Unop, Rval1),
- rval_contains_rval(Rval1, Rval)
- ;
- Rval0 = binop(_Binop, Rval1, Rval2),
- (
- rval_contains_rval(Rval1, Rval)
- ;
- rval_contains_rval(Rval2, Rval)
- )
- )
- ).
-
-:- pred lval_contains_rval(lval, rval).
-:- mode lval_contains_rval(in, in) is semidet.
-:- mode lval_contains_rval(in, out) is nondet.
-
-lval_contains_rval(field(_MaybeTag, Rval0, Rval1), Rval) :-
- (
- rval_contains_rval(Rval0, Rval)
- ;
- rval_contains_rval(Rval1, Rval)
- ).
-
-args_contain_rval([M | Ms], Rval) :-
- (
- M = yes(Rval0),
- rval_contains_rval(Rval0, Rval)
- ;
- args_contain_rval(Ms, Rval)
- ).
-
-%-----------------------------------------------------------------------------%
-
vars_in_rval(lval(Lval), Vars) :-
vars_in_lval(Lval, Vars).
vars_in_rval(var(Var), [Var]).
Index: compiler/follow_code.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/follow_code.m,v
retrieving revision 1.91
diff -u -r1.91 follow_code.m
--- compiler/follow_code.m 7 Aug 2007 10:03:47 -0000 1.91
+++ compiler/follow_code.m 21 Nov 2007 10:33:44 -0000
@@ -337,9 +337,14 @@
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
Detism0 = goal_info_get_determinism(GoalInfo0),
determinism_components(Detism0, _CanFail0, MaxSolns0),
- ( MaxSolns0 = at_most_zero ->
+ (
+ MaxSolns0 = at_most_zero,
Goal = Goal0
;
+ ( MaxSolns0 = at_most_one
+ ; MaxSolns0 = at_most_many
+ ; MaxSolns0 = at_most_many_cc
+ ),
check_follow_code_detism(FollowGoals, Detism0),
( GoalExpr0 = conj(plain_conj, GoalList0) ->
list.append(GoalList0, FollowGoals, GoalList),
Index: compiler/follow_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/follow_vars.m,v
retrieving revision 1.88
diff -u -r1.88 follow_vars.m
--- compiler/follow_vars.m 10 Oct 2007 14:35:26 -0000 1.88
+++ compiler/follow_vars.m 21 Nov 2007 10:35:35 -0000
@@ -83,12 +83,15 @@
find_final_follow_vars_2([], !FollowMap, !NextNonReserved).
find_final_follow_vars_2([arg_info(RegNum, Mode) - Var | ArgInfoVars],
!FollowVarsMap, !NextNonReserved) :-
- ( Mode = top_out ->
+ (
+ Mode = top_out,
Locn = abs_reg(RegNum),
svmap.det_insert(Var, Locn, !FollowVarsMap),
int.max(RegNum + 1, !NextNonReserved)
;
- true
+ Mode = top_in
+ ;
+ Mode = top_unused
),
find_final_follow_vars_2(ArgInfoVars, !FollowVarsMap, !NextNonReserved).
@@ -223,10 +226,14 @@
Call @ generic_call(GenericCall, Args, Modes, Det), Call,
GoalInfo, GoalInfo, VarTypes, ModuleInfo,
!FollowVarsMap, !NextNonReserved) :-
- % Casts are generated inline.
- ( GenericCall = cast(_) ->
- true
+ (
+ GenericCall = cast(_)
+ % Casts are generated inline.
;
+ ( GenericCall = higher_order(_, _, _, _)
+ ; GenericCall = class_method(_, _, _, _)
+ ; GenericCall = event_call(_)
+ ),
determinism_to_code_model(Det, CodeModel),
map.apply_to_list(Args, VarTypes, Types),
make_arg_infos(Types, Modes, CodeModel, ModuleInfo, ArgInfos),
@@ -276,7 +283,8 @@
find_follow_vars_from_arginfo([], !FollowVarsMap, !NextNonReserved).
find_follow_vars_from_arginfo([ArgVar - arg_info(RegNum, Mode) | ArgsInfos],
!FollowVarsMap, !NextNonReserved) :-
- ( Mode = top_in ->
+ (
+ Mode = top_in,
Locn = abs_reg(RegNum),
( svmap.insert(ArgVar, Locn, !FollowVarsMap) ->
true % FollowVarsMap is updated
@@ -290,7 +298,9 @@
),
int.max(RegNum + 1, !NextNonReserved)
;
- true
+ ( Mode = top_out
+ ; Mode = top_unused
+ )
),
find_follow_vars_from_arginfo(ArgsInfos,
!FollowVarsMap, !NextNonReserved).
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.75
diff -u -r1.75 foreign.m
--- compiler/foreign.m 13 Aug 2007 01:27:42 -0000 1.75
+++ compiler/foreign.m 21 Nov 2007 05:28:43 -0000
@@ -545,11 +545,17 @@
map.search(Types, TypeCtor, TypeDefn)
->
hlds_data.get_type_defn_body(TypeDefn, Body),
- ( Body = hlds_foreign_type(ForeignTypeBody) ->
+ (
+ Body = hlds_foreign_type(ForeignTypeBody),
foreign_type_body_to_exported_type(ModuleInfo, ForeignTypeBody,
ForeignTypeName, _, Assertions),
ExportType = exported_type_foreign(ForeignTypeName, Assertions)
;
+ ( Body = hlds_du_type(_, _, _, _, _, _, _)
+ ; Body = hlds_eqv_type(_)
+ ; Body = hlds_solver_type(_, _)
+ ; Body = hlds_abstract_type(_)
+ ),
ExportType = exported_type_mercury(Type)
)
;
Index: compiler/frameopt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/frameopt.m,v
retrieving revision 1.112
diff -u -r1.112 frameopt.m
--- compiler/frameopt.m 31 Jul 2007 01:56:35 -0000 1.112
+++ compiler/frameopt.m 21 Nov 2007 10:39:43 -0000
@@ -1186,10 +1186,14 @@
map.lookup(!.BlockMap, Label, BlockInfo0),
BlockInfo0 = frame_block_info(BlockLabel, BlockInstrs0, FallInto,
_, _, Type),
- ( Type = ordinary_block(block_needs_frame(_), _) ->
+ (
+ Type = ordinary_block(block_needs_frame(_), _),
!:AnyBlockNeedsFrame = yes
;
- true
+ ( Type = ordinary_block(block_doesnt_need_frame, _)
+ ; Type = entry_block(_)
+ ; Type = exit_block(_)
+ )
),
(
Label = BlockLabel, % sanity check
@@ -1695,44 +1699,47 @@
propagate_frame_requirement_to_successors(!.Queue, BlockMap, !OrdNeedsFrame,
!.AlreadyProcessed, !PropagationStepsLeft, !CanTransform) :-
- ( !.CanTransform = cannot_transform ->
- true
- ; !.PropagationStepsLeft < 0 ->
- !:CanTransform = cannot_transform
- ; svqueue.get(Reason - Label, !Queue) ->
- !:PropagationStepsLeft = !.PropagationStepsLeft - 1,
- svset.insert(Label, !AlreadyProcessed),
- map.lookup(BlockMap, Label, BlockInfo),
- BlockType = BlockInfo ^ fb_type,
- (
- BlockType = ordinary_block(_, _MaybeDummy),
- ord_needs_frame(Label, Reason, !OrdNeedsFrame),
- % Putting an already processed label into the queue could
- % lead to an infinite loop. However, we cannot decide whether
- % a label has been processed by checking whether
- % !.OrdNeedsFrame maps Label to yes, since !.OrdNeedsFrame
- % doesn't mention setup frames, and we want to set
- % !:CanTransform to no if any successor is a setup frame.
- % We cannot assume that successors not in !.OrdNeedsFrame
- % should set !:CanTransform to no either, since we don't want
- % to do that for exit frames.
- list.filter(set.contains(!.AlreadyProcessed),
- successors(BlockInfo), _, UnprocessedSuccessors),
- list.map(pair_with(succ_propagated(Label, Reason)),
- UnprocessedSuccessors, PairedUnprocessedSuccessors),
- svqueue.put_list(PairedUnprocessedSuccessors, !Queue)
- ;
- BlockType = entry_block(_),
+ (
+ !.CanTransform = cannot_transform
+ ;
+ !.CanTransform = can_transform,
+ ( !.PropagationStepsLeft < 0 ->
!:CanTransform = cannot_transform
+ ; svqueue.get(Reason - Label, !Queue) ->
+ !:PropagationStepsLeft = !.PropagationStepsLeft - 1,
+ svset.insert(Label, !AlreadyProcessed),
+ map.lookup(BlockMap, Label, BlockInfo),
+ BlockType = BlockInfo ^ fb_type,
+ (
+ BlockType = ordinary_block(_, _MaybeDummy),
+ ord_needs_frame(Label, Reason, !OrdNeedsFrame),
+ % Putting an already processed label into the queue could
+ % lead to an infinite loop. However, we cannot decide whether
+ % a label has been processed by checking whether
+ % !.OrdNeedsFrame maps Label to yes, since !.OrdNeedsFrame
+ % doesn't mention setup frames, and we want to set
+ % !:CanTransform to no if any successor is a setup frame.
+ % We cannot assume that successors not in !.OrdNeedsFrame
+ % should set !:CanTransform to no either, since we don't want
+ % to do that for exit frames.
+ list.filter(set.contains(!.AlreadyProcessed),
+ successors(BlockInfo), _, UnprocessedSuccessors),
+ list.map(pair_with(succ_propagated(Label, Reason)),
+ UnprocessedSuccessors, PairedUnprocessedSuccessors),
+ svqueue.put_list(PairedUnprocessedSuccessors, !Queue)
+ ;
+ BlockType = entry_block(_),
+ !:CanTransform = cannot_transform
+ ;
+ BlockType = exit_block(_)
+ % Exit blocks never *need* stack frames.
+ ),
+ propagate_frame_requirement_to_successors(!.Queue, BlockMap,
+ !OrdNeedsFrame, !.AlreadyProcessed, !PropagationStepsLeft,
+ !CanTransform)
;
- BlockType = exit_block(_)
- % Exit blocks never *need* stack frames.
- ),
- propagate_frame_requirement_to_successors(!.Queue, BlockMap,
- !OrdNeedsFrame, !.AlreadyProcessed, !PropagationStepsLeft,
- !CanTransform)
- ;
- true
+ true
+ )
).
% This predicate implements the third part of the first phase of
@@ -1745,35 +1752,39 @@
propagate_frame_requirement_to_predecessors(!.Queue, BlockMap, RevMap,
!OrdNeedsFrame, !PropagationStepsLeft, !CanTransform) :-
- ( !.CanTransform = cannot_transform ->
- true
- ; !.PropagationStepsLeft < 0 ->
- !:CanTransform = cannot_transform
- ; svqueue.get(Reason - Label, !Queue) ->
- !:PropagationStepsLeft = !.PropagationStepsLeft - 1,
- ( map.search(RevMap, Label, PredecessorsPrime) ->
- Predecessors = PredecessorsPrime
- ;
- % We get here if Label cannot be reached by a fallthrough or an
- % explicit jump, but only by backtracking. In that case, the code
- % that sets up the resumption point saves the address of Label on
- % the stack, and thus is already known to need a stack frame.
- Predecessors = [],
- ord_needs_frame(Label, Reason, !OrdNeedsFrame)
- ),
- list.filter(all_successors_need_frame(BlockMap, !.OrdNeedsFrame),
- Predecessors, NowNeedFrameLabels),
- list.foldl2(record_frame_need(BlockMap, Reason), NowNeedFrameLabels,
- !OrdNeedsFrame, !CanTransform),
- % XXX map.lookup(BlockMap, Label, BlockInfo),
- % XXX Successors = successors(BlockInfo),
- list.map(pair_with(pred_propagated(Label, Reason)), NowNeedFrameLabels,
- PairedNowNeedFrameLabels),
- svqueue.put_list(PairedNowNeedFrameLabels, !Queue),
- propagate_frame_requirement_to_predecessors(!.Queue, BlockMap,
- RevMap, !OrdNeedsFrame, !PropagationStepsLeft, !CanTransform)
+ (
+ !.CanTransform = cannot_transform
;
- true
+ !.CanTransform = can_transform,
+ ( !.PropagationStepsLeft < 0 ->
+ !:CanTransform = cannot_transform
+ ; svqueue.get(Reason - Label, !Queue) ->
+ !:PropagationStepsLeft = !.PropagationStepsLeft - 1,
+ ( map.search(RevMap, Label, PredecessorsPrime) ->
+ Predecessors = PredecessorsPrime
+ ;
+ % We get here if Label cannot be reached by a fallthrough or an
+ % explicit jump, but only by backtracking. In that case, the
+ % code that sets up the resumption point saves the address of
+ % Label on the stack, and thus is already known to need
+ % a stack frame.
+ Predecessors = [],
+ ord_needs_frame(Label, Reason, !OrdNeedsFrame)
+ ),
+ list.filter(all_successors_need_frame(BlockMap, !.OrdNeedsFrame),
+ Predecessors, NowNeedFrameLabels),
+ list.foldl2(record_frame_need(BlockMap, Reason), NowNeedFrameLabels,
+ !OrdNeedsFrame, !CanTransform),
+ % XXX map.lookup(BlockMap, Label, BlockInfo),
+ % XXX Successors = successors(BlockInfo),
+ list.map(pair_with(pred_propagated(Label, Reason)),
+ NowNeedFrameLabels, PairedNowNeedFrameLabels),
+ svqueue.put_list(PairedNowNeedFrameLabels, !Queue),
+ propagate_frame_requirement_to_predecessors(!.Queue, BlockMap,
+ RevMap, !OrdNeedsFrame, !PropagationStepsLeft, !CanTransform)
+ ;
+ true
+ )
).
:- pred record_frame_need(frame_block_map(En, Ex)::in, needs_frame_reason::in,
@@ -2069,7 +2080,8 @@
++ dump_labels(yes(ProcLabel), SideLabels)), "")]
),
PrevNeedsFrame = prev_block_needs_frame(OrdNeedsFrame, BlockInfo0),
- ( Type = exit_block(ExitInfo) ->
+ (
+ Type = exit_block(ExitInfo),
LabelInstr = llds_instr(label(ParallelLabel),
"non-teardown parallel"),
ReplacementCode = [LabelInstr] ++ Comments ++
@@ -2090,6 +2102,9 @@
no, ordinary_block(block_doesnt_need_frame, is_not_dummy)),
svmap.det_insert(ParallelLabel, ParallelBlockInfo, !BlockMap)
;
+ ( Type = entry_block(_)
+ ; Type = ordinary_block(_, _)
+ ),
unexpected(this_file, "block in exit_par_map is not exit")
)
; search_setup_par_map(SetupParMap, Label0, SetupLabel) ->
Index: compiler/goal_form.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_form.m,v
retrieving revision 1.40
diff -u -r1.40 goal_form.m
--- compiler/goal_form.m 10 Oct 2007 14:35:26 -0000 1.40
+++ compiler/goal_form.m 21 Nov 2007 08:27:33 -0000
@@ -216,9 +216,13 @@
Goal = plain_call(PredId, ProcId, _, _, _, _),
lookup_exception_analysis_result(proc(PredId, ProcId), Status,
!ModuleInfo, !IO),
- ( Status = will_not_throw ->
+ (
+ Status = will_not_throw,
Result = cannot_throw
;
+ ( Status = may_throw(_)
+ ; Status = throw_conditional
+ ),
Result = can_throw
).
goal_can_throw_2(Goal, _GoalInfo, Result, !ModuleInfo, !IO) :-
@@ -231,9 +235,15 @@
goal_can_throw_2(Goal, _GoalInfo, Result, !ModuleInfo, !IO) :-
Goal = unify(_, _, _, Uni, _),
% Complicated unifies are _non_builtin_
- ( Uni = complicated_unify(_, _, _) ->
+ (
+ Uni = complicated_unify(_, _, _),
Result = can_throw
;
+ ( Uni = construct(_, _, _, _, _, _, _)
+ ; Uni = deconstruct(_, _, _, _, _, _)
+ ; Uni = assign(_, _)
+ ; Uni = simple_test(_, _)
+ ),
Result = cannot_throw
).
goal_can_throw_2(OuterGoal, _, Result, !ModuleInfo, !IO) :-
Index: compiler/goal_path.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_path.m,v
retrieving revision 1.45
diff -u -r1.45 goal_path.m
--- compiler/goal_path.m 12 Nov 2007 03:52:40 -0000 1.45
+++ compiler/goal_path.m 21 Nov 2007 06:37:44 -0000
@@ -191,10 +191,14 @@
Goal = if_then_else(A, Cond, Then, Else)
;
Goal0 = unify(LHS, RHS0, Mode, Kind, Context),
- ( RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, LambdaGoal0) ->
+ (
+ RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, LambdaGoal0),
fill_goal_slots(Path0, SlotInfo, LambdaGoal0, LambdaGoal),
RHS = rhs_lambda_goal(A, B, C, D, E, F, G, LambdaGoal)
;
+ ( RHS0 = rhs_var(_)
+ ; RHS0 = rhs_functor(_, _, _)
+ ),
RHS = RHS0
),
Goal = unify(LHS, RHS, Mode, Kind, Context)
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.151
diff -u -r1.151 goal_util.m
--- compiler/goal_util.m 7 Aug 2007 07:09:53 -0000 1.151
+++ compiler/goal_util.m 21 Nov 2007 09:09:53 -0000
@@ -462,14 +462,21 @@
goal_vars_2(unify(Var, RHS, _, Unif, _), !Set) :-
svset.insert(Var, !Set),
- ( Unif = construct(_, _, _, _, CellToReuse, _, _) ->
+ (
+ Unif = construct(_, _, _, _, CellToReuse, _, _),
( CellToReuse = reuse_cell(cell_to_reuse(Var, _, _)) ->
svset.insert(Var, !Set)
;
true
)
;
- true
+ Unif = deconstruct(_, _, _, _, _, _)
+ ;
+ Unif = assign(_, _)
+ ;
+ Unif = simple_test(_, _)
+ ;
+ Unif = complicated_unify(_, _, _)
),
rhs_goal_vars(RHS, !Set).
@@ -1162,12 +1169,17 @@
% Add a commit inside the negation of the condition in the else branch
% if the condition can succeed more than once.
- ( CondMaxSoln0 = at_most_many ->
+ (
+ CondMaxSoln0 = at_most_many,
CondMaxSoln = at_most_one,
determinism_components(CondDetism, CondCanFail0, CondMaxSoln),
goal_info_set_determinism(CondDetism, CondInfo0, CondInfo),
Cond = hlds_goal(scope(commit(dont_force_pruning), Cond0), CondInfo)
;
+ ( CondMaxSoln0 = at_most_zero
+ ; CondMaxSoln0 = at_most_one
+ ; CondMaxSoln0 = at_most_many_cc
+ ),
CondDetism = CondDetism0,
CondInfo = CondInfo0,
Cond = Cond0
@@ -1184,9 +1196,14 @@
++ "inappropriate determinism in a negation.")
),
determinism_components(NegCondDet, _, NegCondMaxSoln),
- ( NegCondMaxSoln = at_most_zero ->
+ (
+ NegCondMaxSoln = at_most_zero,
instmap_delta_init_unreachable(NegCondDelta)
;
+ ( NegCondMaxSoln = at_most_one
+ ; NegCondMaxSoln = at_most_many
+ ; NegCondMaxSoln = at_most_many_cc
+ ),
instmap_delta_init_reachable(NegCondDelta)
),
CondNonLocals = goal_info_get_nonlocals(CondInfo),
@@ -1365,10 +1382,11 @@
),
% Don't convert (can_fail, can_loop) into (can_loop, can_fail), since
% this could worsen the termination properties of the program.
- ( EarlierCanFail = can_fail ->
+ (
+ EarlierCanFail = can_fail,
goal_cannot_loop_or_throw(ModuleInfo, LaterGoal)
;
- true
+ EarlierCanFail = cannot_fail
).
reordering_maintains_termination(FullyStrict, EarlierGoal, LaterGoal,
@@ -1450,9 +1468,14 @@
set.init(NonLocals0),
set.insert_list(NonLocals0, Args, NonLocals),
determinism_components(Detism, _CanFail, NumSolns),
- ( NumSolns = at_most_zero ->
+ (
+ NumSolns = at_most_zero,
instmap_delta_init_unreachable(InstMapDelta)
;
+ ( NumSolns = at_most_one
+ ; NumSolns = at_most_many
+ ; NumSolns = at_most_many_cc
+ ),
instmap_delta_from_assoc_list(InstMap, InstMapDelta)
),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
@@ -1478,9 +1501,14 @@
Vars = ArgVars ++ ExtraArgVars,
set.list_to_set(Vars, NonLocals),
determinism_components(Detism, _CanFail, NumSolns),
- ( NumSolns = at_most_zero ->
+ (
+ NumSolns = at_most_zero,
instmap_delta_init_unreachable(InstMapDelta)
;
+ ( NumSolns = at_most_one
+ ; NumSolns = at_most_many
+ ; NumSolns = at_most_many_cc
+ ),
instmap_delta_from_assoc_list(InstMap, InstMapDelta)
),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.312
diff -u -r1.312 handle_options.m
--- compiler/handle_options.m 12 Nov 2007 03:52:41 -0000 1.312
+++ compiler/handle_options.m 21 Nov 2007 09:35:26 -0000
@@ -1823,16 +1823,22 @@
%
globals.lookup_bool_option(!.Globals, use_subdirs, UseSubdirs),
(
- ( UseGradeSubdirs = yes ->
+ (
+ UseGradeSubdirs = yes,
ToMihsSubdir =
(func(Dir) = ToGradeSubdir(Dir)/"Mercury"/"mihs"),
ToHrlsSubdir =
(func(Dir) = ToGradeSubdir(Dir)/"Mercury"/"hrls")
- ; UseSubdirs = yes ->
- ToMihsSubdir = (func(Dir) = Dir/"Mercury"/"mihs"),
- ToHrlsSubdir = (func(Dir) = Dir/"Mercury"/"hrls")
;
- fail
+ UseGradeSubdirs = no,
+ (
+ UseSubdirs = yes,
+ ToMihsSubdir = (func(Dir) = Dir/"Mercury"/"mihs"),
+ ToHrlsSubdir = (func(Dir) = Dir/"Mercury"/"hrls")
+ ;
+ UseSubdirs = no,
+ fail
+ )
)
->
globals.lookup_accumulating_option(!.Globals, c_include_directory,
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.169
diff -u -r1.169 higher_order.m
--- compiler/higher_order.m 20 Aug 2007 03:35:54 -0000 1.169
+++ compiler/higher_order.m 22 Nov 2007 02:48:51 -0000
@@ -576,8 +576,12 @@
traverse_goal_2(Goal0, Goal, !Info) :-
% Check whether this call can be specialized.
%
- Goal0 = hlds_goal(plain_call(_, _, _, _, _, _), _),
- maybe_specialize_call(Goal0, Goal, !Info).
+ Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
+ GoalExpr0 = plain_call(_, _, _, _, _, _),
+ % XXX Due to the absence of alias tracking, assing Goal0 instead of Goal1
+ % would result in a mode error.
+ Goal1 = hlds_goal(GoalExpr0, GoalInfo0),
+ maybe_specialize_call(Goal1, Goal, !Info).
traverse_goal_2(Goal0, Goal, !Info) :-
% if-then-elses are handled as disjunctions.
@@ -1141,18 +1145,14 @@
maybe_specialize_call(hlds_goal(GoalExpr1, GoalInfo),
hlds_goal(GoalExpr, _), !Info).
-:- pred maybe_specialize_call(hlds_goal::in, hlds_goal::out,
+:- pred maybe_specialize_call(hlds_goal::in(plain_call), hlds_goal::out,
higher_order_info::in, higher_order_info::out) is det.
maybe_specialize_call(hlds_goal(GoalExpr0, GoalInfo),
hlds_goal(GoalExpr, GoalInfo), !Info) :-
ModuleInfo0 = !.Info ^ global_info ^ module_info,
- ( GoalExpr0 = plain_call(_, _, _, _, _, _) ->
- GoalExpr0 = plain_call(CalledPred, CalledProc, Args0, IsBuiltin,
- MaybeContext, _SymName0)
- ;
- unexpected(this_file, "maybe_specialize_call: expected call")
- ),
+ GoalExpr0 = plain_call(CalledPred, CalledProc, Args0, IsBuiltin,
+ MaybeContext, _SymName0),
module_info_pred_proc_info(ModuleInfo0, CalledPred, CalledProc,
CalleePredInfo, CalleeProcInfo),
module_info_get_globals(ModuleInfo0, Globals),
@@ -1732,22 +1732,23 @@
Match = Match1
;
(
- MaybeMatch0 = no
- ->
+ MaybeMatch0 = no,
MaybeMatch2 = yes(Match1)
;
- % Pick the best match.
MaybeMatch0 = yes(Match0),
- Match0 = match(_, yes(NumMatches0), _, _),
- Match1 = match(_, yes(NumMatches1), _, _)
- ->
- ( NumMatches0 > NumMatches1 ->
- MaybeMatch2 = MaybeMatch0
+ (
+ % Pick the best match.
+ Match0 = match(_, yes(NumMatches0), _, _),
+ Match1 = match(_, yes(NumMatches1), _, _)
+ ->
+ ( NumMatches0 > NumMatches1 ->
+ MaybeMatch2 = MaybeMatch0
+ ;
+ MaybeMatch2 = yes(Match1)
+ )
;
- MaybeMatch2 = yes(Match1)
+ unexpected(this_file, "search_for_version")
)
- ;
- unexpected(this_file, "search_for_version")
),
search_for_version(Info, Params, ModuleInfo, Request,
Versions, MaybeMatch2, Match)
@@ -3180,11 +3181,18 @@
rtti_varmaps::in, rtti_varmaps::out) is det.
update_type_info_locn(Var, ConstraintType, Index, Index + 1, !RttiVarMaps) :-
- ( ConstraintType = type_variable(ConstraintTVar, _) ->
+ (
+ ConstraintType = type_variable(ConstraintTVar, _),
maybe_set_typeinfo_locn(ConstraintTVar,
typeclass_info(Var, Index), !RttiVarMaps)
;
- true
+ ( ConstraintType = defined_type(_, _, _)
+ ; ConstraintType = builtin_type(_)
+ ; ConstraintType = tuple_type(_, _)
+ ; ConstraintType = higher_order_type(_, _, _, _)
+ ; ConstraintType = apply_n_type(_, _, _)
+ ; ConstraintType = kinded_type(_, _)
+ )
).
:- pred maybe_set_typeinfo_locn(tvar::in, type_info_locn::in,
@@ -3202,7 +3210,8 @@
remove_const_higher_order_args(_, [], _, []).
remove_const_higher_order_args(Index, [Arg | Args0], HOArgs0, Args) :-
- ( HOArgs0 = [HOArg | HOArgs] ->
+ (
+ HOArgs0 = [HOArg | HOArgs],
HOArg = higher_order_arg(_, HOIndex, _, _, _, _, _, IsConst),
( HOIndex = Index ->
remove_const_higher_order_args(Index + 1, Args0, HOArgs, Args1),
@@ -3220,6 +3229,7 @@
unexpected(this_file, "remove_const_higher_order_args")
)
;
+ HOArgs0 = [],
Args = [Arg | Args0]
).
@@ -3299,15 +3309,16 @@
find_class_context(ModuleInfo, [VarInfo | VarInfos], [Mode | Modes],
!.Univ, !.Exist, Constraints) :-
(
- VarInfo = typeclass_info_var(Constraint)
- ->
+ VarInfo = typeclass_info_var(Constraint),
( mode_is_input(ModuleInfo, Mode) ->
maybe_add_constraint(Constraint, !Univ)
;
maybe_add_constraint(Constraint, !Exist)
)
;
- true
+ VarInfo = type_info_var(_)
+ ;
+ VarInfo = non_rtti_var
),
find_class_context(ModuleInfo, VarInfos, Modes, !.Univ, !.Exist,
Constraints).
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.34
diff -u -r1.34 hlds_code_util.m
--- compiler/hlds_code_util.m 25 Sep 2007 04:56:38 -0000 1.34
+++ compiler/hlds_code_util.m 21 Nov 2007 09:10:58 -0000
@@ -120,14 +120,19 @@
module_info_get_type_table(ModuleInfo, TypeTable),
map.lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- ( ConsTable0 = TypeBody ^ du_type_cons_tag_values ->
- ConsTable = ConsTable0
+ (
+ TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _)
;
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
unexpected(this_file, "cons_id_to_tag: type is not d.u. type?")
),
% Finally look up the cons_id in the table.
- map.lookup(ConsTable, cons(Name, Arity), Tag)
+ map.lookup(ConsTagTable, cons(Name, Arity), Tag)
).
%-----------------------------------------------------------------------------%
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.118
diff -u -r1.118 hlds_data.m
--- compiler/hlds_data.m 12 Nov 2007 03:52:41 -0000 1.118
+++ compiler/hlds_data.m 21 Nov 2007 08:31:21 -0000
@@ -1177,9 +1177,13 @@
compare_hlds_constraints(constraint(_, NA, TA), constraint(_, NB, TB), R) :-
compare(R0, NA, NB),
- ( R0 = (=) ->
+ (
+ R0 = (=),
compare(R, TA, TB)
;
+ ( R0 = (<)
+ ; R0 = (>)
+ ),
R = R0
).
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.183
diff -u -r1.183 hlds_goal.m
--- compiler/hlds_goal.m 12 Nov 2007 03:52:41 -0000 1.183
+++ compiler/hlds_goal.m 22 Nov 2007 02:29:27 -0000
@@ -221,6 +221,11 @@
% the construction of the HLDS, so most passes of the compiler
% will just call error/1 if they occur.
+:- inst plain_call_expr
+ ---> plain_call(ground, ground, ground, ground, ground, ground).
+:- inst plain_call
+ ---> hlds_goal(plain_call_expr, ground).
+
:- type conj_type
---> plain_conj
; parallel_conj.
@@ -2602,8 +2607,22 @@
goal_is_atomic(generic_call(_, _, _, _)) = yes.
goal_is_atomic(plain_call(_, _, _, _, _, _)) = yes.
goal_is_atomic(call_foreign_proc(_, _, _, _, _, _, _)) = yes.
-goal_is_atomic(conj(_, Conj)) = ( Conj = [] -> yes ; no ).
-goal_is_atomic(disj(Disj)) = ( Disj = [] -> yes ; no ).
+goal_is_atomic(conj(_, Conj)) = IsAtomic :-
+ (
+ Conj = [],
+ IsAtomic = yes
+ ;
+ Conj = [_ | _],
+ IsAtomic = no
+ ).
+goal_is_atomic(disj(Disj)) = IsAtomic :-
+ (
+ Disj = [],
+ IsAtomic = yes
+ ;
+ Disj = [_ | _],
+ IsAtomic = no
+ ).
goal_is_atomic(if_then_else(_, _, _, _)) = no.
goal_is_atomic(negation(_)) = no.
goal_is_atomic(switch(_, _, _)) = no.
Index: compiler/hlds_llds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_llds.m,v
retrieving revision 1.20
diff -u -r1.20 hlds_llds.m
--- compiler/hlds_llds.m 28 Sep 2007 03:17:12 -0000 1.20
+++ compiler/hlds_llds.m 21 Nov 2007 08:34:11 -0000
@@ -428,9 +428,14 @@
goal_info_get_maybe_need_across_call(GoalInfo, MaybeNeedAtCall) :-
CodeGenInfo = goal_info_get_code_gen_info(GoalInfo),
( MaybeNeed = CodeGenInfo ^ llds_code_gen ^ maybe_need ->
- ( MaybeNeed = need_call(NeedAtCall) ->
+ (
+ MaybeNeed = need_call(NeedAtCall),
MaybeNeedAtCall = yes(NeedAtCall)
;
+ ( MaybeNeed = need_resume(_)
+ ; MaybeNeed = need_par_conj(_)
+ ; MaybeNeed = no_need
+ ),
MaybeNeedAtCall = no
)
;
@@ -440,9 +445,14 @@
goal_info_get_maybe_need_in_resume(GoalInfo, MaybeNeedInResume) :-
CodeGenInfo = goal_info_get_code_gen_info(GoalInfo),
( MaybeNeed = CodeGenInfo ^ llds_code_gen ^ maybe_need ->
- ( MaybeNeed = need_resume(NeedInResume) ->
+ (
+ MaybeNeed = need_resume(NeedInResume),
MaybeNeedInResume = yes(NeedInResume)
;
+ ( MaybeNeed = need_call(_)
+ ; MaybeNeed = need_par_conj(_)
+ ; MaybeNeed = no_need
+ ),
MaybeNeedInResume = no
)
;
@@ -452,9 +462,14 @@
goal_info_get_maybe_need_in_par_conj(GoalInfo, MaybeNeedInParConj) :-
CodeGenInfo = goal_info_get_code_gen_info(GoalInfo),
( MaybeNeed = CodeGenInfo ^ llds_code_gen ^ maybe_need ->
- ( MaybeNeed = need_par_conj(NeedInParConj) ->
+ (
+ MaybeNeed = need_par_conj(NeedInParConj),
MaybeNeedInParConj = yes(NeedInParConj)
;
+ ( MaybeNeed = need_call(_)
+ ; MaybeNeed = need_resume(_)
+ ; MaybeNeed = no_need
+ ),
MaybeNeedInParConj = no
)
;
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.438
diff -u -r1.438 hlds_out.m
--- compiler/hlds_out.m 16 Nov 2007 03:44:51 -0000 1.438
+++ compiler/hlds_out.m 21 Nov 2007 09:12:32 -0000
@@ -1040,11 +1040,16 @@
write_indent(Indent, !IO),
% Print initial formatting differently for assertions.
- ( PromiseType = promise_type_true ->
+ (
+ PromiseType = promise_type_true,
io.write_string(":- promise all [", !IO),
io.write_list(HeadVars, ", ", PrintVar, !IO),
io.write_string("] (\n", !IO)
;
+ ( PromiseType = promise_type_exclusive
+ ; PromiseType = promise_type_exhaustive
+ ; PromiseType = promise_type_exclusive_exhaustive
+ ),
io.write_string(":- all [", !IO),
io.write_list(HeadVars, ", ", PrintVar, !IO),
io.write_string("]", !IO),
@@ -1071,8 +1076,7 @@
write_clauses_2(Indent, ModuleInfo, PredId, VarSet, AppendVarNums,
HeadVars, PredOrFunc, Clauses0, TypeQual, ClauseNum, !IO) :-
(
- Clauses0 = [Clause | Clauses]
- ->
+ Clauses0 = [Clause | Clauses],
term.var_list_to_term_list(HeadVars, HeadTerms),
UseDeclaredModes = no,
io.write_string("% clause ", !IO),
@@ -1083,7 +1087,7 @@
write_clauses_2(Indent, ModuleInfo, PredId, VarSet, AppendVarNums,
HeadVars, PredOrFunc, Clauses, TypeQual, ClauseNum + 1, !IO)
;
- true
+ Clauses0 = []
).
write_clause(Indent, ModuleInfo, PredId, VarSet, AppendVarNums, HeadTerms,
@@ -1757,7 +1761,8 @@
write_goal_2(disj(List), ModuleInfo, VarSet, AppendVarNums,
Indent, Follow, TypeQual, !IO) :-
write_indent(Indent, !IO),
- ( List = [Goal | Goals] ->
+ (
+ List = [Goal | Goals],
io.write_string("( % disjunction\n", !IO),
write_goal_a(Goal, ModuleInfo, VarSet, AppendVarNums, Indent + 1, "\n",
TypeQual, !IO),
@@ -1767,6 +1772,7 @@
io.write_string(")", !IO),
io.write_string(Follow, !IO)
;
+ List = [],
io.write_string("fail", !IO),
io.write_string(Follow, !IO)
).
@@ -3855,9 +3861,14 @@
io.write_string("% does not contain user event\n", !IO)
),
- ( EvalMethod = eval_normal ->
- true
+ (
+ EvalMethod = eval_normal
;
+ ( EvalMethod = eval_loop_check
+ ; EvalMethod = eval_memo
+ ; EvalMethod = eval_minimal(_)
+ ; EvalMethod = eval_table_io(_, _)
+ ),
io.write_string("% eval method: ", !IO),
write_eval_method(EvalMethod, !IO),
io.write_string("\n", !IO)
@@ -4332,23 +4343,23 @@
Context, Term).
inst_name_to_term(unify_inst(Liveness, InstA, InstB, Real), Context) = Term :-
construct_qualified_term(unqualified("$unify"),
- [make_atom((Liveness = is_live -> "live" ; "dead"), Context)] ++
+ [make_atom(is_live_to_str(Liveness), Context)] ++
list.map(map_inst_to_term(Context), [InstA, InstB]) ++
- [make_atom((Real = real_unify -> "real" ; "fake"), Context)],
+ [make_atom(unify_is_real_to_str(Real), Context)],
Context, Term).
inst_name_to_term(ground_inst(InstName, IsLive, Uniq, Real), Context) = Term :-
construct_qualified_term(unqualified("$ground"),
[inst_name_to_term(InstName, Context),
- make_atom((IsLive = is_live -> "live" ; "dead"), Context),
+ make_atom(is_live_to_str(IsLive), Context),
make_atom(inst_uniqueness(Uniq, "shared"), Context),
- make_atom((Real = real_unify -> "real" ; "fake"), Context)],
+ make_atom(unify_is_real_to_str(Real), Context)],
Context, Term).
inst_name_to_term(any_inst(InstName, IsLive, Uniq, Real), Context) = Term :-
construct_qualified_term(unqualified("$any"),
[inst_name_to_term(InstName, Context),
- make_atom((IsLive = is_live -> "live" ; "dead"), Context),
+ make_atom(is_live_to_str(IsLive), Context),
make_atom(inst_uniqueness(Uniq, "shared"), Context),
- make_atom((Real = real_unify -> "real" ; "fake"), Context)],
+ make_atom(unify_is_real_to_str(Real), Context)],
Context, Term).
inst_name_to_term(typed_ground(Uniq, Type), Context) = Term :-
unparse_type(Type, Term0),
@@ -4363,6 +4374,16 @@
inst_name_to_term(InstName, Context)],
Context, Term).
+:- func is_live_to_str(is_live) = string.
+
+is_live_to_str(is_live) = "live".
+is_live_to_str(is_dead) = "dead".
+
+:- func unify_is_real_to_str(unify_is_real) = string.
+
+unify_is_real_to_str(real_unify) = "real".
+unify_is_real_to_str(fake_unify) = "fake".
+
:- func any_inst_uniqueness(uniqueness) = string.
any_inst_uniqueness(shared) = "any".
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.233
diff -u -r1.233 hlds_pred.m
--- compiler/hlds_pred.m 11 Sep 2007 01:41:10 -0000 1.233
+++ compiler/hlds_pred.m 21 Nov 2007 09:14:31 -0000
@@ -2528,18 +2528,23 @@
% Return Result = yes if the called predicate is known to never succeed.
%
-proc_info_never_succeeds(ProcInfo, Result) :-
+proc_info_never_succeeds(ProcInfo, NeverSucceeds) :-
proc_info_get_declared_determinism(ProcInfo, DeclaredDeterminism),
(
DeclaredDeterminism = no,
- Result = no
+ NeverSucceeds = no
;
DeclaredDeterminism = yes(Determinism),
- determinism_components(Determinism, _, HowMany),
- ( HowMany = at_most_zero ->
- Result = yes
+ determinism_components(Determinism, _, MaxSoln),
+ (
+ MaxSoln = at_most_zero,
+ NeverSucceeds = yes
;
- Result = no
+ ( MaxSoln = at_most_one
+ ; MaxSoln = at_most_many
+ ; MaxSoln = at_most_many_cc
+ ),
+ NeverSucceeds = no
)
).
@@ -3049,16 +3054,26 @@
valid_determinism_for_eval_method(eval_normal, _) = yes.
valid_determinism_for_eval_method(eval_loop_check, Detism) = Valid :-
determinism_components(Detism, _, MaxSoln),
- ( MaxSoln = at_most_zero ->
+ (
+ MaxSoln = at_most_zero,
Valid = no
;
+ ( MaxSoln = at_most_one
+ ; MaxSoln = at_most_many
+ ; MaxSoln = at_most_many_cc
+ ),
Valid = yes
).
valid_determinism_for_eval_method(eval_memo, Detism) = Valid :-
determinism_components(Detism, _, MaxSoln),
- ( MaxSoln = at_most_zero ->
+ (
+ MaxSoln = at_most_zero,
Valid = no
;
+ ( MaxSoln = at_most_one
+ ; MaxSoln = at_most_many
+ ; MaxSoln = at_most_many_cc
+ ),
Valid = yes
).
valid_determinism_for_eval_method(eval_table_io(_, _), _) = _ :-
Index: compiler/hlds_rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_rtti.m,v
retrieving revision 1.12
diff -u -r1.12 hlds_rtti.m
--- compiler/hlds_rtti.m 13 Aug 2007 03:01:41 -0000 1.12
+++ compiler/hlds_rtti.m 21 Nov 2007 09:15:24 -0000
@@ -613,12 +613,18 @@
(
% If the tvar is still a variable, insert it into the map with the
% new var.
- NewType = type_variable(NewTVar, _)
- ->
+ NewType = type_variable(NewTVar, _),
% Don't abort if two old type variables map to the same new type
% variable.
svmap.set(NewTVar, NewLocn, !Map)
;
+ ( NewType = builtin_type(_)
+ ; NewType = defined_type(_, _, _)
+ ; NewType = tuple_type(_, _)
+ ; NewType = higher_order_type(_, _, _, _)
+ ; NewType = apply_n_type(_, _, _)
+ ; NewType = kinded_type(_, _)
+ ),
true
).
Index: compiler/ilasm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ilasm.m,v
retrieving revision 1.52
diff -u -r1.52 ilasm.m
--- compiler/ilasm.m 31 Aug 2007 07:35:14 -0000 1.52
+++ compiler/ilasm.m 22 Nov 2007 00:31:58 -0000
@@ -1689,11 +1689,15 @@
MaybeOwner = no
),
output_custom_type(Type, !Info, !IO),
- ( StringOrBytes = bytes(Bytes) ->
+ (
+ StringOrBytes = bytes(Bytes),
io.write_string(" = (", !IO),
io.write_list(Bytes, " ", output_hexbyte, !IO),
io.write_string(")", !IO)
;
+ ( StringOrBytes = qstring(_)
+ ; StringOrBytes = no_initalizer
+ ),
sorry(this_file, "custom_decl of this sort")
),
io.write_string("\n", !IO).
Index: compiler/implicit_parallelism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/implicit_parallelism.m,v
retrieving revision 1.4
diff -u -r1.4 implicit_parallelism.m
--- compiler/implicit_parallelism.m 7 Aug 2007 07:09:56 -0000 1.4
+++ compiler/implicit_parallelism.m 22 Nov 2007 02:30:14 -0000
@@ -5,21 +5,24 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File : implicit_parallelism.m.
% Author: tannier.
-%
-% This module uses deep profiling feedback information generated by
-% mdprof_feedback to introduce parallel conjunctions where it could be
-% worthwhile (implicit parallelism). It deals with both independent and
+%
+% This module uses deep profiling feedback information generated by
+% mdprof_feedback to introduce parallel conjunctions where it could be
+% worthwhile (implicit parallelism). It deals with both independent and
% dependent parallelism.
%
-% TODO
-% - Once a call which is a candidate for implicit parallelism is found,
-% search forward AND backward for the closest goal which is also a
-% candidate for implicit parallelism/parallel conjunction and determine
+% TODO
+% - Once a call which is a candidate for implicit parallelism is found,
+% search forward AND backward for the closest goal which is also a
+% candidate for implicit parallelism/parallel conjunction and determine
% which side is the best (on the basis of the number of shared variables).
%
+% XXX Several predicates in this module repeatedly add goals to the ends of
+% lists of goals, yielding quadratic behavior. This should be fixed.
+%
%-----------------------------------------------------------------------------%
:- module transform_hlds.implicit_parallelism.
@@ -88,7 +91,7 @@
; csk_special
; csk_higher_order
; csk_method
- ; csk_callback.
+ ; csk_callback.
% Construct a call_site_kind from its string representation.
%
@@ -104,7 +107,7 @@
apply_implicit_parallelism_transformation(!ModuleInfo, FeedbackFile, !IO) :-
parse_feedback_file(FeedbackFile, MaybeCandidateCallSites, !IO),
- (
+ (
MaybeCandidateCallSites = error(Error),
io.stderr_stream(Stderr, !IO),
io.write_string(Stderr, Error ++ "\n", !IO)
@@ -118,15 +121,14 @@
% Process predicates for implicit parallelism.
%
:- pred process_preds_for_implicit_parallelism(list(pred_id)::in,
- list(candidate_call_site)::in, module_info::in, module_info::out)
- is det.
+ list(candidate_call_site)::in, module_info::in, module_info::out) is det.
-process_preds_for_implicit_parallelism([], _ListCandidateCallSite,
+process_preds_for_implicit_parallelism([], _ListCandidateCallSite,
!ModuleInfo).
-process_preds_for_implicit_parallelism([ PredId | PredIdList ],
+process_preds_for_implicit_parallelism([PredId | PredIdList],
ListCandidateCallSite, !ModuleInfo) :-
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
- ProcIds = pred_info_non_imported_procids(PredInfo),
+ ProcIds = pred_info_non_imported_procids(PredInfo),
process_procs_for_implicit_parallelism(PredId, ProcIds,
ListCandidateCallSite, !ModuleInfo),
process_preds_for_implicit_parallelism(PredIdList,
@@ -135,34 +137,34 @@
% Process procedures for implicit parallelism.
%
:- pred process_procs_for_implicit_parallelism(pred_id::in,
- list(proc_id)::in, list(candidate_call_site)::in,
+ list(proc_id)::in, list(candidate_call_site)::in,
module_info::in, module_info::out) is det.
process_procs_for_implicit_parallelism(_PredId, [],
_ListCandidateCallSite, !ModuleInfo).
-process_procs_for_implicit_parallelism(PredId, [ ProcId | ProcIds ],
+process_procs_for_implicit_parallelism(PredId, [ProcId | ProcIds],
ListCandidateCallSite, !ModuleInfo) :-
module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
PredInfo0, ProcInfo0),
% Initialize the counter for the slot number.
SiteNumCounter = counter.init(0),
pred_proc_id_to_raw_id(PredInfo0, ProcId, CallerRawId),
- get_callees_feedback(CallerRawId, ListCandidateCallSite, [],
+ get_callees_feedback(CallerRawId, ListCandidateCallSite, [],
CallSites),
list.length(CallSites, NumCallSites),
- ( NumCallSites = 0 ->
+ ( NumCallSites = 0 ->
% No candidate calls for implicit parallelism in this procedure.
process_procs_for_implicit_parallelism(PredId, ProcIds,
ListCandidateCallSite, !ModuleInfo)
;
proc_info_get_goal(ProcInfo0, Body0),
- process_goal_for_implicit_parallelism(Body0, Body, ProcInfo0,
+ process_goal_for_implicit_parallelism(Body0, Body, ProcInfo0,
!ModuleInfo, no, _, 0, _, CallSites, _, SiteNumCounter, _),
- proc_info_set_goal(Body, ProcInfo0, ProcInfo1),
- proc_info_set_has_parallel_conj(yes, ProcInfo1, ProcInfo2),
+ proc_info_set_goal(Body, ProcInfo0, ProcInfo1),
+ proc_info_set_has_parallel_conj(yes, ProcInfo1, ProcInfo2),
requantify_proc(ProcInfo2, ProcInfo3),
RecomputeAtomic = no,
- recompute_instmap_delta_proc(RecomputeAtomic, ProcInfo3, ProcInfo,
+ recompute_instmap_delta_proc(RecomputeAtomic, ProcInfo3, ProcInfo,
!ModuleInfo),
pred_info_set_proc_info(ProcId, ProcInfo, PredInfo0, PredInfo),
module_info_set_pred_info(PredId, PredInfo, !ModuleInfo),
@@ -170,19 +172,19 @@
ListCandidateCallSite, !ModuleInfo)
).
- % Filter the list of call site information from the feedback file so that
+ % Filter the list of call site information from the feedback file so that
% the resulting list only contains those call sites that belong to the first
- % argument, e.g. the caller.
+ % argument, e.g. the caller.
%
:- pred get_callees_feedback(string::in, list(candidate_call_site)::in,
list(candidate_call_site)::in, list(candidate_call_site)::out) is det.
get_callees_feedback(_Caller, [], !ResultAcc).
-get_callees_feedback(Caller, [ CandidateCallSite | ListCandidateCallSite ],
+get_callees_feedback(Caller, [CandidateCallSite | ListCandidateCallSite],
!ResultAcc) :-
CandidateCallSite = candidate_call_site(CSSCaller, _, _, _),
( Caller = CSSCaller ->
- !:ResultAcc = [ CandidateCallSite | !.ResultAcc ],
+ !:ResultAcc = [CandidateCallSite | !.ResultAcc],
get_callees_feedback(Caller, ListCandidateCallSite, !ResultAcc)
;
get_callees_feedback(Caller, ListCandidateCallSite, !ResultAcc)
@@ -193,102 +195,102 @@
%
:- pred process_goal_for_implicit_parallelism(hlds_goal::in, hlds_goal::out,
proc_info::in, module_info::in, module_info::out,
- maybe(hlds_goal_expr)::in, maybe(hlds_goal_expr)::out, int ::in, int::out,
- list(candidate_call_site)::in, list(candidate_call_site)::out,
+ maybe(hlds_goal_expr)::in, maybe(hlds_goal_expr)::out, int ::in, int::out,
+ list(candidate_call_site)::in, list(candidate_call_site)::out,
counter::in, counter::out) is det.
-process_goal_for_implicit_parallelism(!Goal, ProcInfo, !ModuleInfo,
- !MaybeConj, !IndexInConj, !CalleeListToBeParallelized, !SiteNumCounter) :-
+process_goal_for_implicit_parallelism(!Goal, ProcInfo, !ModuleInfo,
+ !MaybeConj, !IndexInConj, !CalleeListToBeParallelized, !SiteNumCounter) :-
!.Goal = hlds_goal(GoalExpr0, GoalInfo),
(
GoalExpr0 = unify(_, _, _, _, _),
- increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
+ increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
;
GoalExpr0 = plain_call(_, _, _, _, _, _),
process_call_for_implicit_parallelism(!.Goal, ProcInfo, !ModuleInfo,
- !IndexInConj, !MaybeConj, !CalleeListToBeParallelized,
+ !IndexInConj, !MaybeConj, !CalleeListToBeParallelized,
!SiteNumCounter)
- % We deal with the index in the conjunction in
+ % We deal with the index in the conjunction in
% process_call_for_implicit_parallelism.
;
GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _),
process_call_for_implicit_parallelism(!.Goal, ProcInfo, !ModuleInfo,
- !IndexInConj, !MaybeConj, !CalleeListToBeParallelized,
+ !IndexInConj, !MaybeConj, !CalleeListToBeParallelized,
!SiteNumCounter)
;
GoalExpr0 = generic_call(Details, _, _, _),
(
Details = higher_order(_, _, _, _),
- process_call_for_implicit_parallelism(!.Goal, ProcInfo,
- !ModuleInfo, !IndexInConj, !MaybeConj,
- !CalleeListToBeParallelized, !SiteNumCounter)
+ process_call_for_implicit_parallelism(!.Goal, ProcInfo,
+ !ModuleInfo, !IndexInConj, !MaybeConj,
+ !CalleeListToBeParallelized, !SiteNumCounter)
;
Details = class_method(_, _, _, _),
- process_call_for_implicit_parallelism(!.Goal, ProcInfo,
- !ModuleInfo, !IndexInConj, !MaybeConj,
+ process_call_for_implicit_parallelism(!.Goal, ProcInfo,
+ !ModuleInfo, !IndexInConj, !MaybeConj,
!CalleeListToBeParallelized, !SiteNumCounter)
;
Details = event_call(_),
- increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
+ increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
;
Details = cast(_),
- increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
+ increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
)
;
- % No distinction is made between plain conjunctions and parallel
- % conjunctions. We have to process the parallel conjunction for the
+ % No distinction is made between plain conjunctions and parallel
+ % conjunctions. We have to process the parallel conjunction for the
% slot number.
GoalExpr0 = conj(_, _),
- process_conj_for_implicit_parallelism(GoalExpr0, GoalExpr, 1,
- ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
+ process_conj_for_implicit_parallelism(GoalExpr0, GoalExpr, 1,
+ ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
!SiteNumCounter),
- % A plain conjunction will never be contained in an other plain
- % conjunction. As for parallel conjunctions, they will not
- % be modified. Therefore, incrementing the index suffices (no need to
+ % A plain conjunction will never be contained in an other plain
+ % conjunction. As for parallel conjunctions, they will not
+ % be modified. Therefore, incrementing the index suffices (no need to
% call update_conj_and_index).
!:Goal = hlds_goal(GoalExpr, GoalInfo),
increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
;
GoalExpr0 = disj(Goals0),
- process_disj_for_implicit_parallelism(Goals0, [], Goals,
- ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
+ process_disj_for_implicit_parallelism(Goals0, [], Goals,
+ ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
!SiteNumCounter),
GoalProcessed = hlds_goal(disj(Goals), GoalInfo),
update_conj_and_index(!MaybeConj, GoalProcessed, !IndexInConj),
- % If we are not in a conjunction, then we need to return the modified
+ % If we are not in a conjunction, then we need to return the modified
% value of Goal. In we are in a conjunction, that information is not
- % read (see process_conj_for_implicit_parallelism).
+ % read (see process_conj_for_implicit_parallelism).
!:Goal = GoalProcessed
;
GoalExpr0 = switch(Var, CanFail, Cases0),
- process_switch_cases_for_implicit_parallelism(Cases0, [], Cases,
- ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
+ process_switch_cases_for_implicit_parallelism(Cases0, [], Cases,
+ ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
!SiteNumCounter),
GoalProcessed = hlds_goal(switch(Var, CanFail, Cases), GoalInfo),
update_conj_and_index(!MaybeConj, GoalProcessed, !IndexInConj),
!:Goal = GoalProcessed
;
GoalExpr0 = negation(Goal0),
- process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
- !ModuleInfo, !MaybeConj, !IndexInConj, !CalleeListToBeParallelized,
+ process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
+ !ModuleInfo, !MaybeConj, !IndexInConj, !CalleeListToBeParallelized,
!SiteNumCounter),
GoalProcessed = hlds_goal(negation(Goal), GoalInfo),
update_conj_and_index(!MaybeConj, GoalProcessed, !IndexInConj),
!:Goal = GoalProcessed
;
GoalExpr0 = scope(Reason, Goal0),
- % 0 is the default value when we are not in a conjunction (in this case
+ % 0 is the default value when we are not in a conjunction (in this case
% a scope).
- process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
- !ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized,
+ process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
+ !ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized,
!SiteNumCounter),
GoalProcessed = hlds_goal(scope(Reason, Goal), GoalInfo),
update_conj_and_index(!MaybeConj, GoalProcessed, !IndexInConj),
!:Goal = GoalProcessed
;
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
- process_goal_for_implicit_parallelism(Cond0, Cond, ProcInfo,
- !ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized,
+ process_goal_for_implicit_parallelism(Cond0, Cond, ProcInfo,
+ !ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized,
!SiteNumCounter),
process_goal_for_implicit_parallelism(Then0, Then, ProcInfo,
!ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized,
@@ -297,12 +299,12 @@
!ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized,
!SiteNumCounter),
GoalProcessed = hlds_goal(if_then_else(Vars, Cond, Then, Else),
- GoalInfo),
- update_conj_and_index(!MaybeConj, GoalProcessed, !IndexInConj),
+ GoalInfo),
+ update_conj_and_index(!MaybeConj, GoalProcessed, !IndexInConj),
!:Goal = GoalProcessed
;
GoalExpr0 = shorthand(_),
- increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
+ increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
).
% Increment the index if we are in a conjunction.
@@ -311,8 +313,8 @@
is det.
increment_index_if_in_conj(MaybeConj, !IndexInConj) :-
- (
- MaybeConj = yes(_),
+ (
+ MaybeConj = yes(_),
!:IndexInConj = !.IndexInConj + 1
;
MaybeConj = no
@@ -321,33 +323,34 @@
% Process a call for implicit parallelism.
%
:- pred process_call_for_implicit_parallelism(hlds_goal::in, proc_info::in,
- module_info::in, module_info::out, int::in, int::out,
- maybe(hlds_goal_expr)::in, maybe(hlds_goal_expr)::out,
- list(candidate_call_site)::in, list(candidate_call_site)::out,
+ module_info::in, module_info::out, int::in, int::out,
+ maybe(hlds_goal_expr)::in, maybe(hlds_goal_expr)::out,
+ list(candidate_call_site)::in, list(candidate_call_site)::out,
counter::in, counter::out) is det.
-
+
process_call_for_implicit_parallelism(Call, ProcInfo, !ModuleInfo,
!IndexInConj, !MaybeConj, !CalleeListToBeParallelized, !SiteNumCounter) :-
counter.allocate(SlotNumber, !SiteNumCounter),
get_call_kind_and_callee(!.ModuleInfo, Call, Kind, CalleeRawId),
(
- !.MaybeConj = yes(Conj0), Conj0 = conj(plain_conj, ConjGoals0)
+ !.MaybeConj = yes(Conj0),
+ Conj0 = conj(plain_conj, ConjGoals0)
->
(
- is_in_css_list_to_be_parallelized(Kind, SlotNumber, CalleeRawId,
+ is_in_css_list_to_be_parallelized(Kind, SlotNumber, CalleeRawId,
!.CalleeListToBeParallelized, [], !:CalleeListToBeParallelized)
- ->
+ ->
(
- build_goals_surrounded_by_calls_to_be_parallelized(ConjGoals0,
- !.ModuleInfo, [ Call ], Goals, !.IndexInConj + 1, End,
+ build_goals_surrounded_by_calls_to_be_parallelized(ConjGoals0,
+ !.ModuleInfo, [Call], Goals, !.IndexInConj + 1, End,
!SiteNumCounter, !CalleeListToBeParallelized)
->
- parallelize_calls(Goals, !.IndexInConj, End, Conj0, Conj,
+ parallelize_calls(Goals, !.IndexInConj, End, Conj0, Conj,
ProcInfo, !ModuleInfo),
!:IndexInConj = End,
!:MaybeConj = yes(Conj)
;
- % The next call is not in the feedback file or we've hit a
+ % The next call is not in the feedback file or we've hit a
% plain conjunction/disjunction/switch/if then else.
!:IndexInConj = !.IndexInConj + 1
)
@@ -356,60 +359,63 @@
!:IndexInConj = !.IndexInConj + 1
)
;
- % Call is not in a conjunction or the call is already in a parallel
+ % Call is not in a conjunction or the call is already in a parallel
% conjunction.
true
- ).
+ ).
- % Give the raw id (the same as in the deep profiler) of a callee contained
+ % Give the raw id (the same as in the deep profiler) of a callee contained
% in a call.
%
-:- pred get_call_kind_and_callee(module_info::in, hlds_goal::in,
+:- pred get_call_kind_and_callee(module_info::in, hlds_goal::in,
call_site_kind::out, string::out) is det.
get_call_kind_and_callee(ModuleInfo, Call, Kind, CalleeRawId) :-
GoalExpr = Call ^ hlds_goal_expr,
(
- GoalExpr = plain_call(PredId, ProcId, _, _, _, _)
- ->
+ GoalExpr = plain_call(PredId, ProcId, _, _, _, _),
module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
PredInfo, _),
pred_proc_id_to_raw_id(PredInfo, ProcId, CalleeRawId),
Kind = csk_normal
;
+ GoalExpr = call_foreign_proc(_, PredId, ProcId, _, _, _, _),
+ module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
+ PredInfo, _),
+ pred_proc_id_to_raw_id(PredInfo, ProcId, CalleeRawId),
+ Kind = csk_special
+ ;
+ GoalExpr = generic_call(Details, _, _, _),
(
- GoalExpr = call_foreign_proc(_, PredId, ProcId, _, _, _, _)
- ->
- module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
- PredInfo, _),
- pred_proc_id_to_raw_id(PredInfo, ProcId, CalleeRawId),
- Kind = csk_special
+ Details = higher_order(_, _, _, _),
+ CalleeRawId = "",
+ Kind = csk_higher_order
;
- (
- GoalExpr = generic_call(Details, _, _, _)
- ->
- (
- Details = higher_order(_, _, _, _),
- CalleeRawId = "",
- Kind = csk_higher_order
- ;
- Details = class_method(_, _, _, _),
- CalleeRawId = "",
- Kind = csk_method
- ;
- Details = event_call(_),
- unexpected(this_file, "get_call_kind_and_callee")
- ;
- Details = cast(_),
- unexpected(this_file, "get_call_kind_and_callee")
- )
- ;
- unexpected(this_file, "get_call_kind_and_callee")
- )
+ Details = class_method(_, _, _, _),
+ CalleeRawId = "",
+ Kind = csk_method
+ ;
+ Details = event_call(_),
+ unexpected(this_file, "get_call_kind_and_callee")
+ ;
+ Details = cast(_),
+ unexpected(this_file, "get_call_kind_and_callee")
)
+ ;
+ % XXX Some of our callers can call us with these kinds of goals.
+ ( GoalExpr = unify(_, _, _, _, _)
+ ; GoalExpr = conj(_, _)
+ ; GoalExpr = disj(_)
+ ; GoalExpr = switch(_, _, _)
+ ; GoalExpr = if_then_else(_, _, _, _)
+ ; GoalExpr = negation(_)
+ ; GoalExpr = scope(_, _)
+ ; GoalExpr = shorthand(_)
+ ),
+ unexpected(this_file, "get_call_kind_and_callee")
).
- % Convert a pred_info and a proc_id to the raw procedure id (the same used
+ % Convert a pred_info and a proc_id to the raw procedure id (the same used
% in the deep profiler).
%
:- pred pred_proc_id_to_raw_id(pred_info::in, proc_id::in, string::out) is det.
@@ -421,57 +427,58 @@
IsPredOrFunc = pred_info_is_pred_or_func(PredInfo),
ModuleString = sym_name_to_string(ModuleName),
ProcIdInt = proc_id_to_int(ProcId),
- RawId = string.append_list([ ModuleString, ".", Name, "/",
- string.int_to_string(OrigArity),
- ( IsPredOrFunc = pf_function -> "+1" ; ""), "-",
- string.from_int(ProcIdInt) ]).
+ RawId = string.append_list([ModuleString, ".", Name, "/",
+ string.int_to_string(OrigArity),
+ ( IsPredOrFunc = pf_function -> "+1" ; ""), "-",
+ string.from_int(ProcIdInt)]).
- % Succeeds if the caller, slot number and callee correspond to a
- % candidate_call_site in the list given as a parameter.
+ % Succeeds if the caller, slot number and callee correspond to a
+ % candidate_call_site in the list given as a parameter.
% Fail otherwise.
%
-:- pred is_in_css_list_to_be_parallelized(call_site_kind::in, int::in,
+:- pred is_in_css_list_to_be_parallelized(call_site_kind::in, int::in,
string::in, list(candidate_call_site)::in,
- list(candidate_call_site)::in, list(candidate_call_site)::out)
- is semidet.
+ list(candidate_call_site)::in, list(candidate_call_site)::out) is semidet.
-is_in_css_list_to_be_parallelized(Kind, SlotNumber, CalleeRawId,
- ListCandidateCallSite, !ResultAcc) :-
- (
- ListCandidateCallSite = [],
+is_in_css_list_to_be_parallelized(Kind, SlotNumber, CalleeRawId,
+ CandidateCallSites, !ResultAcc) :-
+ (
+ CandidateCallSites = [],
fail
;
- ListCandidateCallSite = [ CandidateCallSite |
- ListCandidateCallSite0 ],
- CandidateCallSite = candidate_call_site(_, CSSSlotNumber, CSSKind,
+ CandidateCallSites = [CandidateCallSite | CandidateCallSitesTail],
+ CandidateCallSite = candidate_call_site(_, CSSSlotNumber, CSSKind,
CSSCallee),
- % =< because there is not a one to one correspondance with the source
- % code. New calls might have been added by the previous passes of the
+ % =< because there is not a one to one correspondance with the source
+ % code. New calls might have been added by the previous passes of the
% compiler.
- ( CSSSlotNumber =< SlotNumber, CSSKind = Kind, CSSCallee = CalleeRawId
+ (
+ CSSSlotNumber =< SlotNumber,
+ CSSKind = Kind,
+ CSSCallee = CalleeRawId
->
- list.append(!.ResultAcc, ListCandidateCallSite0, !:ResultAcc)
+ !:ResultAcc = !.ResultAcc ++ CandidateCallSitesTail
;
- list.append(!.ResultAcc, [ CandidateCallSite ], !:ResultAcc),
- is_in_css_list_to_be_parallelized(Kind, SlotNumber, CalleeRawId,
- ListCandidateCallSite0, !ResultAcc)
+ !:ResultAcc = !.ResultAcc ++ [CandidateCallSite],
+ is_in_css_list_to_be_parallelized(Kind, SlotNumber, CalleeRawId,
+ CandidateCallSitesTail, !ResultAcc)
)
).
- % Build a list of goals surrounded by two calls which are in the feedback
- % file or by a call which is in the feedback file and a parallel
+ % Build a list of goals surrounded by two calls which are in the feedback
+ % file or by a call which is in the feedback file and a parallel
% conjunction.
- %
+ %
% Succeed if we can build that list of goals.
% Fail otherwise.
%
:- pred build_goals_surrounded_by_calls_to_be_parallelized(list(hlds_goal)::in,
- module_info::in, list(hlds_goal)::in, list(hlds_goal)::out,
- int::in, int::out, counter::in, counter::out,
- list(candidate_call_site)::in, list(candidate_call_site)::out)
+ module_info::in, list(hlds_goal)::in, list(hlds_goal)::out,
+ int::in, int::out, counter::in, counter::out,
+ list(candidate_call_site)::in, list(candidate_call_site)::out)
is semidet.
-build_goals_surrounded_by_calls_to_be_parallelized(ConjGoals, ModuleInfo,
+build_goals_surrounded_by_calls_to_be_parallelized(ConjGoals, ModuleInfo,
!ResultAcc, !Index, !SiteNumCounter, !CalleeListToBeParallelized) :-
list.length(ConjGoals, Length),
( !.Index > Length ->
@@ -479,7 +486,7 @@
;
list.index1_det(ConjGoals, !.Index, Goal),
GoalExpr = Goal ^ hlds_goal_expr,
- (
+ (
( GoalExpr = disj(_)
; GoalExpr = switch(_, _, _)
; GoalExpr = if_then_else(_, _, _, _)
@@ -488,30 +495,30 @@
->
fail
;
+ !:ResultAcc = !.ResultAcc ++ [Goal],
( goal_is_conjunction(Goal, parallel_conj) ->
- list.append(!.ResultAcc, [ Goal ], !:ResultAcc)
+ true
;
- ( goal_is_call_or_negated_call(Goal) ->
+ ( goal_is_call_or_negated_call(Goal) ->
counter.allocate(SlotNumber, !SiteNumCounter),
- get_call_kind_and_callee(ModuleInfo, Goal, Kind,
+ get_call_kind_and_callee(ModuleInfo, Goal, Kind,
CalleeRawId),
- ( is_in_css_list_to_be_parallelized(Kind, SlotNumber,
- CalleeRawId, !.CalleeListToBeParallelized, [],
- !:CalleeListToBeParallelized)
+ (
+ is_in_css_list_to_be_parallelized(Kind, SlotNumber,
+ CalleeRawId, !.CalleeListToBeParallelized, [],
+ !:CalleeListToBeParallelized)
->
- list.append(!.ResultAcc, [ Goal ], !:ResultAcc)
+ true
;
- list.append(!.ResultAcc, [ Goal ], !:ResultAcc),
!:Index = !.Index + 1,
build_goals_surrounded_by_calls_to_be_parallelized(
- ConjGoals, ModuleInfo, !ResultAcc, !Index,
+ ConjGoals, ModuleInfo, !ResultAcc, !Index,
!SiteNumCounter, !CalleeListToBeParallelized)
)
;
- list.append(!.ResultAcc, [ Goal ], !:ResultAcc),
!:Index = !.Index + 1,
build_goals_surrounded_by_calls_to_be_parallelized(
- ConjGoals, ModuleInfo, !ResultAcc, !Index,
+ ConjGoals, ModuleInfo, !ResultAcc, !Index,
!SiteNumCounter, !CalleeListToBeParallelized)
)
)
@@ -532,7 +539,7 @@
% Fail otherwise.
%
:- pred goal_is_call_or_negated_call(hlds_goal::in) is semidet.
-
+
goal_is_call_or_negated_call(Goal) :-
GoalExpr = Goal ^ hlds_goal_expr,
(
@@ -563,26 +570,27 @@
)
).
- % Parallelize two calls/a call and a parallel conjunction which might have
+ % Parallelize two calls/a call and a parallel conjunction which might have
% goals between them. If these have no dependencies with the first call then
- % we move them before the first call and parallelize the two calls/call and
+ % we move them before the first call and parallelize the two calls/call and
% parallel conjunction.
%
% Goals is contained in Conj.
%
-:- pred parallelize_calls(list(hlds_goal)::in, int::in, int::in,
- hlds_goal_expr::in, hlds_goal_expr::out, proc_info::in,
+:- pred parallelize_calls(list(hlds_goal)::in, int::in, int::in,
+ hlds_goal_expr::in, hlds_goal_expr::out, proc_info::in,
module_info::in, module_info::out) is det.
parallelize_calls(Goals, Start, End, !Conj, ProcInfo, !ModuleInfo) :-
( !.Conj = conj(plain_conj, ConjGoals0) ->
- ( ConjGoals0 = [ FirstGoal, LastGoal ] ->
- ( is_worth_parallelizing(FirstGoal, LastGoal, ProcInfo,
- !.ModuleInfo)
+ ( ConjGoals0 = [FirstGoal, LastGoal] ->
+ (
+ is_worth_parallelizing(FirstGoal, LastGoal, ProcInfo,
+ !.ModuleInfo)
->
( goal_is_conjunction(LastGoal, parallel_conj) ->
% The parallel conjunction has to remain flatened.
- add_call_to_parallel_conjunction(FirstGoal, LastGoal,
+ add_call_to_parallel_conjunction(FirstGoal, LastGoal,
ParallelGoal),
!:Conj = ParallelGoal ^ hlds_goal_expr
;
@@ -597,44 +605,41 @@
list.length(Goals, Length),
list.index1_det(Goals, 1, FirstGoal),
list.index1_det(Goals, Length, LastGoal),
- ( is_worth_parallelizing(FirstGoal, LastGoal, ProcInfo,
- !.ModuleInfo)
+ (
+ is_worth_parallelizing(FirstGoal, LastGoal, ProcInfo,
+ !.ModuleInfo)
->
GoalsInBetweenAndLast = list.det_tail(Goals),
- list.delete_all(GoalsInBetweenAndLast, LastGoal,
- GoalsInBetween),
+ list.delete_all(GoalsInBetweenAndLast, LastGoal,
+ GoalsInBetween),
% Check the dependencies of GoalsInBetween with FirstGoal.
- list.filter(goal_depends_on_goal(FirstGoal),
+ list.filter(goal_depends_on_goal(FirstGoal),
GoalsInBetween, GoalsFiltered),
( list.is_empty(GoalsFiltered) ->
( goal_is_conjunction(LastGoal, parallel_conj) ->
- add_call_to_parallel_conjunction(FirstGoal, LastGoal,
+ add_call_to_parallel_conjunction(FirstGoal, LastGoal,
ParallelGoal)
;
- create_conj(FirstGoal, LastGoal, parallel_conj,
+ create_conj(FirstGoal, LastGoal, parallel_conj,
ParallelGoal)
),
( Start = 1 ->
GoalsFront = []
;
- list.det_split_list(Start - 1, ConjGoals0,
+ list.det_split_list(Start - 1, ConjGoals0,
GoalsFront, _)
),
list.length(ConjGoals0, ConjLength),
( End = ConjLength ->
GoalsBack = []
;
- list.det_split_list(End, ConjGoals0, _,
- GoalsBack)
+ list.det_split_list(End, ConjGoals0, _, GoalsBack)
),
- list.append(GoalsFront, GoalsInBetween,
- GoalsFrontWithBetween),
- list.append(GoalsFrontWithBetween, [ ParallelGoal ],
- GoalsWithoutBack),
- list.append(GoalsWithoutBack, GoalsBack, ConjGoals),
+ ConjGoals = GoalsFront ++ GoalsInBetween ++
+ [ParallelGoal] ++ GoalsBack,
!:Conj = conj(plain_conj, ConjGoals)
;
- % The goals between the two calls/call and parallel
+ % The goals between the two calls/call and parallel
% conjunction can't be moved before the first call.
true
)
@@ -648,23 +653,23 @@
unexpected(this_file, "parallelize_calls")
).
- % Two calls are worth parallelizing if the number of shared variables is
- % smaller than the number of argument variables of at least one of the two
+ % Two calls are worth parallelizing if the number of shared variables is
+ % smaller than the number of argument variables of at least one of the two
% calls.
%
% A call and a parallel conjunction are worth parallelizing if the number of
- % shared variables is smaller than the number of argument variables of the
+ % shared variables is smaller than the number of argument variables of the
% call.
- %
+ %
% Succeed if it is worth parallelizing the two goals.
% Fail otherwise.
%
-:- pred is_worth_parallelizing(hlds_goal::in, hlds_goal::in, proc_info::in,
+:- pred is_worth_parallelizing(hlds_goal::in, hlds_goal::in, proc_info::in,
module_info::in) is semidet.
is_worth_parallelizing(GoalA, GoalB, ProcInfo, ModuleInfo) :-
proc_info_get_initial_instmap(ProcInfo, ModuleInfo, InstMap),
- SharedVars = find_shared_variables(ModuleInfo, InstMap, [ GoalA, GoalB ]),
+ SharedVars = find_shared_variables(ModuleInfo, InstMap, [GoalA, GoalB]),
set.to_sorted_list(SharedVars, SharedVarsList),
list.length(SharedVarsList, NbSharedVars),
( NbSharedVars = 0 ->
@@ -673,16 +678,16 @@
;
( goal_is_conjunction(GoalB, parallel_conj) ->
get_number_args(GoalA, NbArgsA),
- NbSharedVars < NbArgsA
+ NbSharedVars < NbArgsA
;
(
get_number_args(GoalA, NbArgsA),
- get_number_args(GoalB, NbArgsB)
+ get_number_args(GoalB, NbArgsB)
->
( NbSharedVars < NbArgsA, NbSharedVars < NbArgsB
; NbSharedVars = NbArgsA, NbSharedVars < NbArgsB
; NbSharedVars < NbArgsA, NbSharedVars = NbArgsB
- )
+ )
;
unexpected(this_file, "is_worth_parallelizing")
)
@@ -721,14 +726,14 @@
ParallelGoalExpr0 = ParallelGoal0 ^ hlds_goal_expr,
ParallelGoalInfo0 = ParallelGoal0 ^ hlds_goal_info,
( ParallelGoalExpr0 = conj(parallel_conj, GoalList0) ->
- GoalList = [ Call | GoalList0 ],
+ GoalList = [Call | GoalList0],
goal_list_nonlocals(GoalList, NonLocals),
goal_list_instmap_delta(GoalList, InstMapDelta),
goal_list_determinism(GoalList, Detism),
- goal_list_purity(GoalList, Purity),
- goal_info_set_nonlocals(NonLocals, ParallelGoalInfo0,
+ goal_list_purity(GoalList, Purity),
+ goal_info_set_nonlocals(NonLocals, ParallelGoalInfo0,
ParallelGoalInfo1),
- goal_info_set_instmap_delta(InstMapDelta, ParallelGoalInfo1,
+ goal_info_set_instmap_delta(InstMapDelta, ParallelGoalInfo1,
ParallelGoalInfo2),
goal_info_set_determinism(Detism, ParallelGoalInfo2, ParallelGoalInfo3),
goal_info_set_purity(Purity, ParallelGoalInfo3, ParallelGoalInfo),
@@ -753,12 +758,12 @@
% Process a conjunction for implicit parallelism.
%
:- pred process_conj_for_implicit_parallelism(
- hlds_goal_expr::in, hlds_goal_expr::out, int::in,
+ hlds_goal_expr::in, hlds_goal_expr::out, int::in,
proc_info::in, module_info::in, module_info::out,
list(candidate_call_site)::in, list(candidate_call_site)::out,
counter::in, counter::out) is det.
-process_conj_for_implicit_parallelism(!GoalExpr, IndexInConj, ProcInfo,
+process_conj_for_implicit_parallelism(!GoalExpr, IndexInConj, ProcInfo,
!ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter) :-
( !.GoalExpr = conj(_, GoalsConj) ->
list.length(GoalsConj, Length),
@@ -767,18 +772,18 @@
;
MaybeConj0 = yes(!.GoalExpr),
list.index1_det(GoalsConj, IndexInConj, GoalInConj),
- % We are not interested in the return value of GoalInConj, only
+ % We are not interested in the return value of GoalInConj, only
% MaybeConj matters.
- process_goal_for_implicit_parallelism(GoalInConj, _, ProcInfo,
- !ModuleInfo, MaybeConj0, MaybeConj, IndexInConj, IndexInConj0,
+ process_goal_for_implicit_parallelism(GoalInConj, _, ProcInfo,
+ !ModuleInfo, MaybeConj0, MaybeConj, IndexInConj, IndexInConj0,
!CalleeListToBeParallelized, !SiteNumCounter),
( MaybeConj = yes(GoalExprProcessed) ->
!:GoalExpr = GoalExprProcessed
;
unexpected(this_file, "process_conj_for_implicit_parallelism")
),
- process_conj_for_implicit_parallelism(!GoalExpr, IndexInConj0,
- ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
+ process_conj_for_implicit_parallelism(!GoalExpr, IndexInConj0,
+ ProcInfo, !ModuleInfo, !CalleeListToBeParallelized,
!SiteNumCounter)
)
;
@@ -788,30 +793,30 @@
% Process a disjunction for implicit parallelism.
%
:- pred process_disj_for_implicit_parallelism(
- list(hlds_goal)::in, list(hlds_goal)::in, list(hlds_goal)::out,
+ list(hlds_goal)::in, list(hlds_goal)::in, list(hlds_goal)::out,
proc_info::in, module_info::in, module_info::out,
list(candidate_call_site)::in, list(candidate_call_site)::out,
counter::in, counter::out) is det.
process_disj_for_implicit_parallelism([], !GoalsAcc, _ProcInfo,
!ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter).
-process_disj_for_implicit_parallelism([ Goal0 | Goals ], !GoalsAcc,
+process_disj_for_implicit_parallelism([Goal0 | Goals], !GoalsAcc,
ProcInfo, !ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter) :-
- process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
+ process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
!ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized, !SiteNumCounter),
- list.append(!.GoalsAcc, [ Goal ], !:GoalsAcc),
- process_disj_for_implicit_parallelism(Goals, !GoalsAcc, ProcInfo,
+ !:GoalsAcc = !.GoalsAcc ++ [Goal],
+ process_disj_for_implicit_parallelism(Goals, !GoalsAcc, ProcInfo,
!ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter).
- % If we are in a conjunction, update it by replacing the goal at index by
+ % If we are in a conjunction, update it by replacing the goal at index by
% Goal and increment the index.
%
:- pred update_conj_and_index(
- maybe(hlds_goal_expr)::in, maybe(hlds_goal_expr)::out,
+ maybe(hlds_goal_expr)::in, maybe(hlds_goal_expr)::out,
hlds_goal::in, int::in, int::out) is det.
update_conj_and_index(!MaybeConj, Goal, !IndexInConj) :-
- ( !.MaybeConj = yes(conj(Type, Goals0)) ->
+ ( !.MaybeConj = yes(conj(Type, Goals0)) ->
list.replace_nth_det(Goals0, !.IndexInConj, Goal, Goals),
!:IndexInConj = !.IndexInConj + 1,
!:MaybeConj = yes(conj(Type, Goals))
@@ -824,25 +829,25 @@
:- pred process_switch_cases_for_implicit_parallelism(
list(case)::in, list(case)::in, list(case)::out, proc_info::in,
module_info::in, module_info::out,
- list(candidate_call_site)::in, list(candidate_call_site)::out,
+ list(candidate_call_site)::in, list(candidate_call_site)::out,
counter::in, counter::out) is det.
process_switch_cases_for_implicit_parallelism([], !CasesAcc, _ProcInfo,
!ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter).
-process_switch_cases_for_implicit_parallelism([ Case0 | Cases ], !CasesAcc,
+process_switch_cases_for_implicit_parallelism([Case0 | Cases], !CasesAcc,
ProcInfo, !ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter) :-
- Case0 = case(Functor, Goal0),
- process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
+ Case0 = case(Functor, Goal0),
+ process_goal_for_implicit_parallelism(Goal0, Goal, ProcInfo,
!ModuleInfo, no, _, 0, _, !CalleeListToBeParallelized, !SiteNumCounter),
- list.append(!.CasesAcc, [ case(Functor, Goal) ], !:CasesAcc),
- process_switch_cases_for_implicit_parallelism(Cases, !CasesAcc,
+ !:CasesAcc = !.CasesAcc ++ [case(Functor, Goal)],
+ process_switch_cases_for_implicit_parallelism(Cases, !CasesAcc,
ProcInfo, !ModuleInfo, !CalleeListToBeParallelized, !SiteNumCounter).
%-----------------------------------------------------------------------------%
% Parse the feedback file (header and body).
%
-:- pred parse_feedback_file(string::in,
+:- pred parse_feedback_file(string::in,
maybe_error(list(candidate_call_site))::out, io::di, io::uo) is det.
parse_feedback_file(InputFile, MaybeListCandidateCallSite, !IO) :-
@@ -855,7 +860,7 @@
io.read_file_as_string(Stream, MaybeFileAsString, !IO),
(
MaybeFileAsString = ok(FileAsString),
- LineList = string.words_separator(is_carriage_return,
+ LineList = string.words_separator(is_carriage_return,
FileAsString),
process_header(LineList, MaybeBodyFileAsListString, !IO),
(
@@ -867,7 +872,7 @@
)
;
MaybeFileAsString = error(_, ErrReadFileAsString),
- MaybeListCandidateCallSite =
+ MaybeListCandidateCallSite =
error(io.error_message(ErrReadFileAsString))
),
io.close_input(Stream, !IO)
@@ -880,7 +885,7 @@
% Process the header of the feedback file.
%
-:- pred process_header(list(string)::in, maybe_error(list(string))::out,
+:- pred process_header(list(string)::in, maybe_error(list(string))::out,
io::di, io::uo) is det.
process_header(FileAsListString, MaybeFileAsListStringWithoutHeader, !IO) :-
@@ -888,45 +893,45 @@
( Type = "Profiling feedback file" ->
(list.index0(FileAsListString, 1, Version) ->
( Version = "Version = 1.0" ->
- list.det_split_list(4, FileAsListString, _,
+ list.det_split_list(4, FileAsListString, _,
FileAsListStringWithoutHeader),
- MaybeFileAsListStringWithoutHeader =
+ MaybeFileAsListStringWithoutHeader =
ok(FileAsListStringWithoutHeader)
;
- MaybeFileAsListStringWithoutHeader = error("Profiling" ++
- " feedback file version incorrect")
+ MaybeFileAsListStringWithoutHeader =
+ error("Profiling feedback file version incorrect")
)
;
- MaybeFileAsListStringWithoutHeader = error("Not a profiling"
- ++ " feedback file")
+ MaybeFileAsListStringWithoutHeader =
+ error("Not a profiling feedback file")
)
;
- MaybeFileAsListStringWithoutHeader = error("Not a profiling" ++
- " feedback file")
+ MaybeFileAsListStringWithoutHeader =
+ error("Not a profiling feedback file")
)
;
- MaybeFileAsListStringWithoutHeader = error("Not a profiling feedback"
- ++ " file")
+ MaybeFileAsListStringWithoutHeader =
+ error("Not a profiling feedback file")
).
% Process the body of the feedback file.
%
-:- pred process_body(list(string)::in,
+:- pred process_body(list(string)::in,
maybe_error(list(candidate_call_site))::out) is det.
process_body(CoreFileAsListString, MaybeListCandidateCallSite) :-
( process_body2(CoreFileAsListString, [], ListCandidateCallSite) ->
MaybeListCandidateCallSite = ok(ListCandidateCallSite)
;
- MaybeListCandidateCallSite = error("Profiling feedback file is not"
- ++ " well-formed")
+ MaybeListCandidateCallSite =
+ error("Profiling feedback file is not well-formed")
).
-:- pred process_body2(list(string)::in, list(candidate_call_site)::in,
+:- pred process_body2(list(string)::in, list(candidate_call_site)::in,
list(candidate_call_site)::out) is semidet.
process_body2([], !ListCandidateCallSiteAcc).
-process_body2([ Line | Lines ], !ListCandidateCallSiteAcc) :-
+process_body2([Line | Lines], !ListCandidateCallSiteAcc) :-
Words = string.words_separator(is_whitespace, Line),
list.index0_det(Words, 0, Caller),
( Caller = "Mercury" ->
@@ -936,20 +941,25 @@
string.to_int(SlotNumber, IntSlotNumber),
list.index0_det(Words, 2, KindAsString),
( construct_call_site_kind(KindAsString, Kind) ->
- ( Kind = csk_normal ->
- list.index0_det(Words, 3, Callee),
- CandidateCallSite = candidate_call_site(Caller, IntSlotNumber,
- Kind, Callee)
+ (
+ Kind = csk_normal,
+ list.index0_det(Words, 3, Callee)
;
- CandidateCallSite = candidate_call_site(Caller, IntSlotNumber,
- Kind, "")
- )
+ ( Kind = csk_higher_order
+ ; Kind = csk_method
+ ; Kind = csk_special
+ ; Kind = csk_callback
+ ),
+ Callee = ""
+ ),
+ CandidateCallSite = candidate_call_site(Caller, IntSlotNumber,
+ Kind, Callee)
;
% Unexpected call site kind.
unexpected(this_file, "process_body2")
),
- !:ListCandidateCallSiteAcc = [ CandidateCallSite |
- !.ListCandidateCallSiteAcc ],
+ !:ListCandidateCallSiteAcc =
+ [CandidateCallSite | !.ListCandidateCallSiteAcc],
process_body2(Lines, !ListCandidateCallSiteAcc)
).
Index: compiler/inst_graph.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_graph.m,v
retrieving revision 1.16
diff -u -r1.16 inst_graph.m
--- compiler/inst_graph.m 23 May 2007 10:09:16 -0000 1.16
+++ compiler/inst_graph.m 21 Nov 2007 09:16:32 -0000
@@ -206,10 +206,12 @@
set_parent(Parent, Child, InstGraph0, InstGraph) :-
map.lookup(InstGraph0, Child, node(Functors, MaybeParent0)),
- ( MaybeParent0 = top_level ->
+ (
+ MaybeParent0 = top_level,
map.det_update(InstGraph0, Child, node(Functors, parent(Parent)),
InstGraph)
;
+ MaybeParent0 = parent(_),
unexpected(this_file, "set_parent: node already has parent")
).
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.224
diff -u -r1.224 intermod.m
--- compiler/intermod.m 25 Sep 2007 04:56:39 -0000 1.224
+++ compiler/intermod.m 22 Nov 2007 03:07:53 -0000
@@ -503,7 +503,7 @@
% or function calls.
intermod_traverse_goal_expr(unify(LVar, RHS0, C, D, E),
unify(LVar, RHS, C, D, E), DoWrite, !Info) :-
- module_qualify_unify_rhs(LVar, RHS0, RHS, DoWrite, !Info).
+ module_qualify_unify_rhs(RHS0, RHS, DoWrite, !Info).
intermod_traverse_goal_expr(negation(Goal0), negation(Goal), DoWrite, !Info) :-
intermod_traverse_goal(Goal0, Goal, DoWrite, !Info).
intermod_traverse_goal_expr(scope(Reason, Goal0), scope(Reason, Goal),
@@ -701,38 +701,40 @@
% For function calls and higher-order terms, call add_proc
% so that the predicate or function will be exported if necessary.
%
-:- pred module_qualify_unify_rhs(prog_var::in, unify_rhs::in,
- unify_rhs::out, bool::out, intermod_info::in,
- intermod_info::out) is det.
+:- pred module_qualify_unify_rhs(unify_rhs::in, unify_rhs::out, bool::out,
+ intermod_info::in, intermod_info::out) is det.
-module_qualify_unify_rhs(_LHS, RHS @ rhs_var(_Var), RHS, yes, !Info).
-module_qualify_unify_rhs(_LHS,
- rhs_lambda_goal(A, B, C, D, E, F, G,Goal0),
- rhs_lambda_goal(A, B, C, D, E, F, G,Goal), DoWrite, !Info) :-
- intermod_traverse_goal(Goal0, Goal, DoWrite, !Info).
-module_qualify_unify_rhs(_LHS, RHS @ rhs_functor(Functor, _Exist, _Vars),
- RHS, DoWrite, !Info) :-
- % Is this a higher-order predicate or higher-order function
- % term?
- ( Functor = pred_const(ShroudedPredProcId, _) ->
- %
- % Yes, the unification creates a higher-order term.
- % Make sure that the predicate/function is exported.
- %
- proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
- add_proc(PredId, DoWrite, !Info)
- ;
- %
- % It's an ordinary constructor, or a constant of a builtin
- % type, so just leave it alone.
- %
- % Constructors are module qualified by post_typecheck.m.
- %
- % Function calls and higher-order function applications
- % are transformed into ordinary calls and higher-order calls
- % by post_typecheck.m, so they can't occur here.
- %
+module_qualify_unify_rhs(RHS0, RHS, DoWrite, !Info) :-
+ (
+ RHS0 = rhs_var(_),
+ RHS = RHS0,
DoWrite = yes
+ ;
+ RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, Goal0),
+ intermod_traverse_goal(Goal0, Goal, DoWrite, !Info),
+ RHS = rhs_lambda_goal(A, B, C, D, E, F, G, Goal)
+ ;
+ RHS0 = rhs_functor(Functor, _Exist, _Vars),
+ RHS = RHS0,
+ % Is this a higher-order predicate or higher-order function term?
+ ( Functor = pred_const(ShroudedPredProcId, _) ->
+ % Yes, the unification creates a higher-order term.
+ % Make sure that the predicate/function is exported.
+
+ proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
+ add_proc(PredId, DoWrite, !Info)
+ ;
+ % It's an ordinary constructor, or a constant of a builtin type,
+ % so just leave it alone.
+ %
+ % Constructors are module qualified by post_typecheck.m.
+ %
+ % Function calls and higher-order function applications
+ % are transformed into ordinary calls and higher-order calls
+ % by post_typecheck.m, so they can't occur here.
+
+ DoWrite = yes
+ )
).
%-----------------------------------------------------------------------------%
@@ -2343,7 +2345,8 @@
maybe_write_string(VeryVerbose, "% done.\n", !IO),
globals.io_get_globals(Globals, !IO),
- ( Transitive = yes ->
+ (
+ Transitive = yes,
get_dependencies(OptItems, NewImportDeps0, NewUseDeps0),
get_implicit_dependencies(OptItems, Globals,
NewImplicitImportDeps0, NewImplicitUseDeps0),
@@ -2354,6 +2357,7 @@
set.union(ModulesProcessed0, NewDepsSet, ModulesProcessed),
set.to_sorted_list(NewDepsSet, NewDeps)
;
+ Transitive = no,
ModulesProcessed = ModulesProcessed0,
NewDeps = []
),
Index: compiler/interval.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/interval.m,v
retrieving revision 1.34
diff -u -r1.34 interval.m
--- compiler/interval.m 10 Oct 2007 14:35:26 -0000 1.34
+++ compiler/interval.m 21 Nov 2007 05:56:09 -0000
@@ -288,10 +288,15 @@
ArgModes, ArgTypes, InputArgs, _OutputArgs),
% Casts are generated inline.
- ( GenericCall = cast(_) ->
+ (
+ GenericCall = cast(_),
require_in_regs(InputArgs, !IntervalInfo),
require_access(InputArgs, !IntervalInfo)
;
+ ( GenericCall = higher_order(_, _, _, _)
+ ; GenericCall = class_method(_, _, _, _)
+ ; GenericCall = event_call(_)
+ ),
module_info_get_globals(ModuleInfo, Globals),
call_gen.generic_call_info(Globals, GenericCall,
length(InputArgs), _, GenericVarsArgInfos, _, _),
@@ -557,10 +562,13 @@
StartAnchor = anchor_branch_start(Construct, GoalPath),
assign_open_intervals_to_anchor(EndAnchor, !IntervalInfo),
CodeModel = goal_info_get_code_model(GoalInfo),
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
record_model_non_anchor(EndAnchor, !IntervalInfo)
;
- true
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ )
),
no_open_intervals(!IntervalInfo),
get_cur_interval(AfterIntervalId, !.IntervalInfo),
@@ -870,7 +878,8 @@
;
GoalExpr0 = disj(Goals0),
construct_anchors(branch_disj, Goal0, StartAnchor, EndAnchor),
- ( Goals0 = [FirstGoal0 | LaterGoals0] ->
+ (
+ Goals0 = [FirstGoal0 | LaterGoals0],
record_decisions_in_goal(FirstGoal0, FirstGoal, !VarInfo,
!.VarRename, _, InsertMap, MaybeFeature),
lookup_inserts(InsertMap, StartAnchor, StartInserts),
@@ -882,6 +891,7 @@
insert_goals_after(Goal1, Goal, !VarInfo, !:VarRename, Inserts,
MaybeFeature)
;
+ Goals0 = [],
GoalExpr = disj(Goals0),
Goal = hlds_goal(GoalExpr, GoalInfo0)
)
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.131
diff -u -r1.131 lambda.m
--- compiler/lambda.m 4 Sep 2007 03:12:20 -0000 1.131
+++ compiler/lambda.m 22 Nov 2007 03:05:12 -0000
@@ -280,12 +280,11 @@
unification::in, unify_context::in, hlds_goal_expr::out,
lambda_info::in, lambda_info::out) is det.
-lambda_process_unify_goal(XVar, Y0, Mode, Unification0, Context, GoalExpr,
+lambda_process_unify_goal(LHS, RHS0, Mode, Unification0, Context, GoalExpr,
!Info) :-
(
- Y0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
- NonLocalVars, Vars, Modes, Det, LambdaGoal0)
- ->
+ RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ NonLocalVars, Vars, Modes, Det, LambdaGoal0),
% First, process the lambda goal recursively, in case it contains
% some nested lambda expressions.
lambda_process_goal(LambdaGoal0, LambdaGoal, !Info),
@@ -293,10 +292,13 @@
% Then, convert the lambda expression into a new predicate.
lambda_process_lambda(Purity, PredOrFunc, EvalMethod, Vars, Modes, Det,
NonLocalVars, LambdaGoal, Unification0, Y, Unification, !Info),
- GoalExpr = unify(XVar, Y, Mode, Unification, Context)
+ GoalExpr = unify(LHS, Y, Mode, Unification, Context)
;
+ ( RHS0 = rhs_var(_)
+ ; RHS0 = rhs_functor(_, _, _)
+ ),
% Ordinary unifications are left unchanged.
- GoalExpr = unify(XVar, Y0, Mode, Unification0, Context)
+ GoalExpr = unify(LHS, RHS0, Mode, Unification0, Context)
).
:- pred lambda_process_lambda(purity::in, pred_or_func::in,
Index: compiler/lco.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lco.m,v
retrieving revision 1.47
diff -u -r1.47 lco.m
--- compiler/lco.m 28 Sep 2007 03:17:12 -0000 1.47
+++ compiler/lco.m 22 Nov 2007 02:56:02 -0000
@@ -875,12 +875,14 @@
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
(
GoalExpr0 = conj(ConjType, Goals0),
- ( ConjType = parallel_conj ->
- unexpected(this_file, "transform_variant_goal: parallel_conj")
- ;
+ (
+ ConjType = plain_conj,
transform_variant_conj(ModuleInfo, VarToAddr, InstMap0,
Goals0, Goals, Changed),
GoalExpr = conj(ConjType, Goals)
+ ;
+ ConjType = parallel_conj,
+ unexpected(this_file, "transform_variant_goal: parallel_conj")
)
;
GoalExpr0 = disj(Goals0),
Index: compiler/live_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/live_vars.m,v
retrieving revision 1.132
diff -u -r1.132 live_vars.m
--- compiler/live_vars.m 10 Oct 2007 14:35:26 -0000 1.132
+++ compiler/live_vars.m 21 Nov 2007 10:41:33 -0000
@@ -382,10 +382,15 @@
_ResumeVars0, _AllocData, !StackAlloc, !Liveness, !NondetLiveness,
!ParStackVars) :-
Goal = unify(_, _, _, Unification, _),
- ( Unification = complicated_unify(_, _, _) ->
- unexpected(this_file, "build_live_sets_in_goal_2: complicated_unify")
+ (
+ ( Unification = construct(_, _, _, _, _, _, _)
+ ; Unification = deconstruct(_, _, _, _, _, _)
+ ; Unification = assign(_, _)
+ ; Unification = simple_test(_, _)
+ )
;
- true
+ Unification = complicated_unify(_, _, _),
+ unexpected(this_file, "build_live_sets_in_goal_2: complicated_unify")
).
build_live_sets_in_goal_2(Goal, Goal, GoalInfo0, GoalInfo, ResumeVars0,
@@ -466,10 +471,13 @@
% must be protected against reuse in following code.
CodeModel = goal_info_get_code_model(GoalInfo),
- ( CodeModel = model_non ->
- set.union(!.NondetLiveness, ForwardVars, !:NondetLiveness)
+ (
+ CodeModel = model_det
+ ;
+ CodeModel = model_semi
;
- true
+ CodeModel = model_non,
+ set.union(!.NondetLiveness, ForwardVars, !:NondetLiveness)
),
% In a parallel conjunction all the stack slots we need must not be reused
@@ -555,7 +563,8 @@
AllocData, !StackAlloc, Liveness0, _Liveness2,
NondetLiveness0, NondetLiveness2, !ParStackVars),
DisjCodeModel = goal_info_get_code_model(DisjGoalInfo),
- ( DisjCodeModel = model_non ->
+ (
+ DisjCodeModel = model_non,
% NondetLiveness should be a set of prog_var sets. Instead of taking
% the union of the NondetLive sets at the ends of disjuncts, we should
% just keep them in this set of sets.
@@ -570,6 +579,9 @@
NondetLiveness = NondetLiveness3
)
;
+ ( DisjCodeModel = model_det
+ ; DisjCodeModel = model_semi
+ ),
NondetLiveness = NondetLiveness0
).
Index: compiler/livemap.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.89
diff -u -r1.89 livemap.m
--- compiler/livemap.m 11 Oct 2007 11:45:18 -0000 1.89
+++ compiler/livemap.m 21 Nov 2007 10:45:55 -0000
@@ -76,12 +76,16 @@
set.init(Livevals0),
livemap_do_build(Backinstrs, Livevals0, no, ContainsBadUserCode,
Livemap0, Livemap1),
- ( ContainsBadUserCode = yes ->
+ (
+ ContainsBadUserCode = yes,
MaybeLivemap = no
- ; livemap.equal_livemaps(Livemap0, Livemap1) ->
- MaybeLivemap = yes(Livemap1)
;
- build_livemap_fixpoint(Backinstrs, Livemap1, MaybeLivemap)
+ ContainsBadUserCode = no,
+ ( livemap.equal_livemaps(Livemap0, Livemap1) ->
+ MaybeLivemap = yes(Livemap1)
+ ;
+ build_livemap_fixpoint(Backinstrs, Livemap1, MaybeLivemap)
+ )
).
% Check whether the two livemaps agree on the set of live lvals
@@ -168,20 +172,31 @@
LivevalsNeeded = opt_util.livevals_addr(CodeAddr),
livemap.look_for_livevals(!Instrs, !Livevals, "goto",
LivevalsNeeded, Found),
- ( Found = yes ->
- true
- ; CodeAddr = code_label(Label) ->
- livemap_insert_label_livevals(!.Livemap, Label,
- set.init, !:Livevals)
- ;
- ( CodeAddr = do_redo
- ; CodeAddr = do_fail
- ; CodeAddr = do_not_reached
- )
- ->
- true
+ (
+ Found = yes
;
- unexpected(this_file, "unknown label type in build_livemap")
+ Found = no,
+ (
+ CodeAddr = code_label(Label),
+ livemap_insert_label_livevals(!.Livemap, Label,
+ set.init, !:Livevals)
+ ;
+ ( CodeAddr = do_redo
+ ; CodeAddr = do_fail
+ ; CodeAddr = do_not_reached
+ )
+ ;
+ ( CodeAddr = code_imported_proc(_)
+ ; CodeAddr = code_succip
+ ; CodeAddr = do_succeed(_)
+ ; CodeAddr = do_trace_redo_fail_shallow
+ ; CodeAddr = do_trace_redo_fail_deep
+ ; CodeAddr = do_call_closure(_)
+ ; CodeAddr = do_call_class_method(_)
+ ),
+ unexpected(this_file,
+ "unknown code_addr type in build_livemap")
+ )
),
livemap_special_code_addr(CodeAddr, MaybeSpecial),
(
@@ -424,11 +439,15 @@
livemap_filter_livevals(Livevals1, !:Livevals),
Instrs = Instrs2,
Found = yes
- ; Compulsory = yes ->
- unexpected(this_file, Site ++ " not preceded by livevals")
;
- Instrs = Instrs1,
- Found = no
+ (
+ Compulsory = yes,
+ unexpected(this_file, Site ++ " not preceded by livevals")
+ ;
+ Compulsory = no,
+ Instrs = Instrs1,
+ Found = no
+ )
).
% What lval (if any) is consulted when we branch to a code address?
Index: compiler/liveness.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/liveness.m,v
retrieving revision 1.157
diff -u -r1.157 liveness.m
--- compiler/liveness.m 11 Oct 2007 11:45:18 -0000 1.157
+++ compiler/liveness.m 21 Nov 2007 10:46:17 -0000
@@ -1441,8 +1441,7 @@
(
% If there are any more disjuncts, then this disjunct
% establishes a resumption point.
- Goals0 = [_ | _]
- ->
+ Goals0 = [_ | _],
detect_resume_points_in_non_disj(Goals0, Goals,
Liveness0, LivenessRest, LiveInfo,
ResumeVars0, NeededRest),
@@ -1450,6 +1449,7 @@
Liveness0, LivenessRest, LiveInfo, ResumeVars0,
Liveness, NeededRest, Needed)
;
+ Goals0 = [],
detect_resume_points_in_last_disjunct(Goal0, Goal,
Liveness0, Liveness, LiveInfo, ResumeVars0, Needed),
Goals = Goals0
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.318
diff -u -r1.318 llds_out.m
--- compiler/llds_out.m 11 Oct 2007 11:45:18 -0000 1.318
+++ compiler/llds_out.m 21 Nov 2007 10:49:25 -0000
@@ -3242,11 +3242,10 @@
output_data_addr_decls_format(DataAddr, FirstIndent, LaterIndent,
!N, !DeclSet, !IO)
; Const = llconst_float(FloatVal) ->
- %
% If floats are boxed, and the static ground terms option is enabled,
% then for each float constant which we might want to box we declare
% a static const variable holding that constant.
- %
+
globals.io_lookup_bool_option(unboxed_float, UnboxedFloat, !IO),
globals.io_lookup_bool_option(static_ground_terms, StaticGroundTerms,
!IO),
@@ -3984,7 +3983,8 @@
!DeclSet, !IO).
c_data_linkage_string(DefaultLinkage, BeingDefined) = LinkageStr :-
- ( DefaultLinkage = extern ->
+ (
+ DefaultLinkage = extern,
(
BeingDefined = yes,
LinkageStr = ""
@@ -3993,6 +3993,7 @@
LinkageStr = "extern "
)
;
+ DefaultLinkage = static,
% Previously we used to always write `extern' here, but declaring
% something `extern' and then later defining it as `static' causes
% undefined behavior -- on many systems, it works, but on some systems
Index: compiler/loop_inv.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/loop_inv.m,v
retrieving revision 1.42
diff -u -r1.42 loop_inv.m
--- compiler/loop_inv.m 7 Aug 2007 07:09:58 -0000 1.42
+++ compiler/loop_inv.m 22 Nov 2007 03:08:03 -0000
@@ -1201,33 +1201,38 @@
goal_expr_inputs(MI, unify(LHS, UnifyRHS, _, Kind, _)) = Inputs :-
(
- % The LHS is always an output var in constructions.
- %
+ % The LHS is always an output var in constructions.
Kind = construct(_, _, RHSArgs, ArgUniModes, _, _, _),
Inputs = list.filter_map_corresponding(
input_arg(MI), RHSArgs, rhs_modes(ArgUniModes))
;
- % The LHS is always in input var in deconstructions.
- %
+ % The LHS is always in input var in deconstructions.
Kind = deconstruct(_, _, RHSArgs, ArgUniModes, _, _),
Inputs = [ LHS
| list.filter_map_corresponding(
input_arg(MI), RHSArgs, rhs_modes(ArgUniModes)) ]
;
- % The RHS is the only input in an assignment.
- %
+ % The RHS is the only input in an assignment.
Kind = assign(_, RHS),
Inputs = [RHS]
;
- % Both sides of a simple test are inputs.
- %
+ % Both sides of a simple test are inputs.
Kind = simple_test(_, RHS),
Inputs = [LHS, RHS]
;
- % Both sides of a complicated unification are inputs.
- %
+ % Both sides of a complicated unification are inputs.
Kind = complicated_unify(_, _, _),
- Inputs = ( if UnifyRHS = rhs_var(RHS) then [LHS, RHS] else [LHS] )
+ (
+ UnifyRHS = rhs_var(RHS),
+ Inputs = [LHS, RHS]
+ ;
+ UnifyRHS = rhs_functor(_, _, _),
+ Inputs = [LHS]
+ ;
+ UnifyRHS = rhs_lambda_goal(_, _, _, _, _, _, _, _),
+ % These should have been expanded out by now.
+ unexpected(this_file, "goal_expr_inputs: lambda goal")
+ )
).
goal_expr_inputs(_MI, conj(_, _)) = _ :-
Index: compiler/lp.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lp.m,v
retrieving revision 1.18
diff -u -r1.18 lp.m
--- compiler/lp.m 1 Dec 2006 15:04:04 -0000 1.18
+++ compiler/lp.m 21 Nov 2007 09:39:23 -0000
@@ -45,15 +45,21 @@
:- type coeff == pair(var, float).
-:- type equation ---> eqn(list(coeff), operator, float).
+:- type equation
+ ---> eqn(list(coeff), operator, float).
-:- type operator ---> (=<) ; (=) ; (>=).
+:- type operator
+ ---> (=<)
+ ; (=)
+ ; (>=).
:- type equations == list(equation).
:- type objective == list(coeff).
-:- type direction ---> max ; min.
+:- type direction
+ ---> max
+ ; min.
:- type lp.result
---> unsatisfiable
Index: compiler/lp_rational.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lp_rational.m,v
retrieving revision 1.10
diff -u -r1.10 lp_rational.m
--- compiler/lp_rational.m 10 Oct 2007 14:35:26 -0000 1.10
+++ compiler/lp_rational.m 21 Nov 2007 14:32:32 -0000
@@ -65,7 +65,7 @@
:- type constraints == list(constraint).
% Create a constraint from the given components.
- %
+ %
:- func lp_rational.constraint(lp_terms, operator, constant) = constraint.
% Create a constraint from the given components.
@@ -75,33 +75,33 @@
= constraint.
% Deconstruct the given constraint.
- %
-:- pred lp_rational.constraint(constraint::in, lp_terms::out, operator::out,
+ %
+:- pred lp_rational.constraint(constraint::in, lp_terms::out, operator::out,
constant::out) is det.
% As above but throws an exception if the constraint is false.
- %
+ %
:- pred lp_rational.non_false_constraint(constraint::in, lp_terms::out,
operator::out, constant::out) is det.
% Succeeds iff the given constraint contains a single variable and
% that variable is constrained to be a nonnegative value.
- %
+ %
:- pred lp_rational.nonneg_constr(constraint::in) is semidet.
- % Create a constraint that constrains the argument
+ % Create a constraint that constrains the argument
% have a non-negative value.
%
:- func lp_rational.make_nonneg_constr(lp_var) = constraint.
% Create a constraint that equates two variables.
- %
+ %
:- func lp_rational.make_vars_eq_constraint(lp_var, lp_var) = constraint.
% Create constraints of the form:
%
% Var = Constant or Var >= Constant
- %
+ %
% These functions are useful with higher-order code.
%
:- func lp_rational.make_var_const_eq_constraint(lp_var, rat) = constraint.
@@ -110,21 +110,21 @@
% Create a constraint that is trivially false.
%
:- func lp_rational.false_constraint = constraint.
-
+
% Create a constraint that is trivially true.
- %
+ %
:- func lp_rational.true_constraint = constraint.
% Succeeds if the constraint is trivially false.
%
:- pred lp_rational.is_false(constraint::in) is semidet.
-
+
% Succeeds if the constraint is trivially true.
- %
+ %
:- pred lp_rational.is_true(constraint::in) is semidet.
-
+
% Takes a list of constraints and looks for equality constraints
- % that may be implicit in any inequalities.
+ % that may be implicit in any inequalities.
%
% NOTE: this is only a syntactic check so it may miss
% some equalities that are implicit in the system.
@@ -142,10 +142,10 @@
% Fails if the system of constraints is inconsistent.
%
:- pred remove_some_entailed_constraints(lp_varset::in, constraints::in,
- constraints::out) is semidet.
+ constraints::out) is semidet.
% Succeeds iff the given system of constraints is inconsistent.
- %
+ %
:- pred lp_rational.inconsistent(lp_varset::in, constraints::in) is semidet.
% Remove those constraints from the system whose redundancy can be
@@ -162,11 +162,11 @@
%
% If length(VarsA) \= length(VarsB) then an exception is thrown.
%
-:- func lp_rational.substitute_vars(lp_vars, lp_vars, constraints)
+:- func lp_rational.substitute_vars(lp_vars, lp_vars, constraints)
= constraints.
:- func lp_rational.substitute_vars(map(lp_var, lp_var), constraints)
= constraints.
-
+
% Make the values of all the variables in the set zero.
%
:- func lp_rational.set_vars_to_zero(set(lp_var), constraints) = constraints.
@@ -194,25 +194,27 @@
:- type objective == lp_terms.
-:- type direction ---> max ; min.
+:- type direction
+ ---> max
+ ; min.
:- type lp_result
- ---> unbounded
- ; inconsistent
- ; satisfiable(rat, map(lp_var, rat)).
- % satisfiable(ObjVal, MapFromObjVarsToVals)
+ ---> lp_res_unbounded
+ ; lp_res_inconsistent
+ ; lp_res_satisfiable(rat, map(lp_var, rat)).
+ % lp_res_satisfiable(ObjVal, MapFromObjVarsToVals)
% Maximize (or minimize - depending on `direction') `objective'
% subject to the given constraints. The variables in the objective
% and the constraints *must* be from the given `lp_varset'. This
% is passed to the solver so that it can allocate fresh variables
% as required.
- %
+ %
% The result is `unbounded' if the objective is not bounded by
% the constraints, `inconsistent' if the given constraints are
% inconsistent, or `satisfiable/2' otherwise.
%
-:- func lp_rational.solve(constraints, direction, objective, lp_varset)
+:- func lp_rational.solve(constraints, direction, objective, lp_varset)
= lp_result.
%-----------------------------------------------------------------------------%
@@ -220,14 +222,14 @@
% Projection
%
-:- type projection_result
- ---> ok(constraints) % projection succeeded.
- ; inconsistent % matrix was inconsistent.
- ; aborted. % ran out of time/space and backed out.
+:- type projection_result
+ ---> pr_res_ok(constraints) % projection succeeded.
+ ; pr_res_inconsistent % matrix was inconsistent.
+ ; pr_res_aborted. % ran out of time/space and backed out.
% project(Constraints0, Vars, Varset) = Result:
% Takes a list of constraints, `Constraints0', and eliminates the
- % variables in the list `Vars' using Fourier elimination.
+ % variables in the list `Vars' using Fourier elimination.
%
% Returns `ok(Constraints)' if `Constraints' is the projection
% of `Constraints0' over `Vars'. Returns `inconsistent' if
@@ -240,13 +242,13 @@
% to do a consistency check on the result if they require
% the resulting system of constraints to be consistent.
%
-:- func lp_rational.project(lp_vars, lp_varset, constraints)
+:- func lp_rational.project(lp_vars, lp_varset, constraints)
= projection_result.
:- pred lp_rational.project(lp_vars::in, lp_varset::in, constraints::in,
projection_result::out) is det.
% project(Vars, Varset, maybe(MaxMatrixSize), Matrix, Result).
- % Same as above but if the size of the matrix ever exceeds
+ % Same as above but if the size of the matrix ever exceeds
% `MaxMatrixSize' we back out of the computation.
%
:- pred lp_rational.project(lp_vars::in, lp_varset::in, maybe(int)::in,
@@ -292,7 +294,7 @@
%
:- type output_var == (func(lp_var) = string).
- % Write out the constraints in a form we can read in using the
+ % Write out the constraints in a form we can read in using the
% term parser from the standard library.
%
:- pred lp_rational.output_constraints(output_var::in, constraints::in,
@@ -303,11 +305,11 @@
% Debugging predicates
%
- % Print out the constraints using the names in the varset. If the
+ % Print out the constraints using the names in the varset. If the
% variable has no name it will be given the name Temp<n>, where <n>
% is the variable number.
%
-:- pred lp_rational.write_constraints(constraints::in, lp_varset::in, io::di,
+:- pred lp_rational.write_constraints(constraints::in, lp_varset::in, io::di,
io::uo) is det.
% Return the set of variables that are present in a list of constraints.
@@ -350,7 +352,6 @@
; eq(lp_terms, constant) % sumof(Terms) = Constant
; gte(lp_terms, constant). % sumof(Terms) >= Constant
-
%-----------------------------------------------------------------------------%
%
% Procedures for constructing/deconstructing constraints.
@@ -383,7 +384,7 @@
unchecked_constraint(Terms, (=<), Constant) = lte(Terms, Constant).
unchecked_constraint(Terms, (=), Constant) = eq(Terms, Constant).
-unchecked_constraint(Terms, (>=), Constant) = gte(Terms, Constant).
+unchecked_constraint(Terms, (>=), Constant) = gte(Terms, Constant).
:- func sum_like_terms(lp_terms) = lp_terms.
@@ -395,13 +396,13 @@
% coefficients. Also if a coefficient is (or ends up being) zero
% make sure that the variable doesn't end up in the resulting map.
%
-:- func lp_terms_to_map(assoc_list(lp_var, coefficient)) =
+:- func lp_terms_to_map(assoc_list(lp_var, coefficient)) =
map(lp_var, coefficient).
lp_terms_to_map(Terms) = Map :-
list.foldl(lp_terms_to_map_2, Terms, map.init, Map).
-:- pred lp_terms_to_map_2(pair(lp_var, coefficient)::in,
+:- pred lp_terms_to_map_2(pair(lp_var, coefficient)::in,
map(lp_var, coefficient)::in, map(lp_var, coefficient)::out) is det.
lp_terms_to_map_2(Var - Coeff0, !Map) :-
@@ -422,7 +423,7 @@
Constraint = constraint(Terms, Op, Constant),
( if is_false(Constraint)
then unexpected(this_file,
- "non_false_constraints/3: false constraint.")
+ "non_false_constraints/3: false constraint.")
else true
).
@@ -433,9 +434,9 @@
non_false_constraint(Constraint, Terms, Operator, Constant) :-
( if is_false(Constraint)
then unexpected(this_file,
- "non_false_constraint/4: false_constraint.")
+ "non_false_constraint/4: false_constraint.")
else true
- ),
+ ),
(
Constraint = lte(Terms, Constant),
Operator = (=<)
@@ -451,13 +452,13 @@
lp_terms(lte(Terms, _)) = Terms.
lp_terms(eq(Terms, _)) = Terms.
-lp_terms(gte(Terms, _)) = Terms.
+lp_terms(gte(Terms, _)) = Terms.
:- func constant(constraint) = constant.
constant(lte(_, Constant)) = Constant.
constant(eq(_, Constant)) = Constant.
-constant(gte(_, Constant)) = Constant.
+constant(gte(_, Constant)) = Constant.
:- func operator(constraint) = operator.
@@ -477,8 +478,8 @@
make_nonneg_constr(Var) = constraint([Var - (-rat.one)], (=<), rat.zero).
-make_vars_eq_constraint(Var1, Var2) =
- constraint([Var1 - rat.one, Var2 - (-rat.one)], (=), rat.zero).
+make_vars_eq_constraint(Var1, Var2) =
+ constraint([Var1 - rat.one, Var2 - (-rat.one)], (=), rat.zero).
make_var_const_eq_constraint(Var, Constant) =
constraint([Var - rat.one], (=), Constant).
@@ -500,7 +501,7 @@
% Put each constraint in the list in standard form (see below).
%
:- func lp_rational.standardize_constraints(constraints) = constraints.
-
+
standardize_constraints(Constraints) =
list.map(standardize_constraint, Constraints).
@@ -508,8 +509,8 @@
% has its terms list in increasing order of variable name
% and then multiplied so that the absolute value of the leading
% coefficient is one. (>=) is converted to (=<) by multiplying
- % through by negative one. (=) constraints should have an
- % initial coefficient of (positive) 1.
+ % through by negative one. (=) constraints should have an
+ % initial coefficient of (positive) 1.
%
:- func lp_rational.standardize_constraint(constraint) = constraint.
@@ -521,7 +522,7 @@
standardize_constraint(lte(Terms0, Const0)) = lte(Terms, Const) :-
normalize_terms_and_const(yes, Terms0, Const0, Terms, Const).
- % Sort the list of terms in ascending order by variable
+ % Sort the list of terms in ascending order by variable
% and then multiply through so that the first term has a
% coefficient of one or negative one. If the first argument
% is `yes' then we multiply through by the reciprocal of the
@@ -537,17 +538,17 @@
),
!:Terms = list.sort(CompareTerms, !.Terms),
( if !.Terms = [_ - Coefficient0 | _]
- then
- (
+ then
+ (
AbsVal = yes,
Coefficient = rat.abs(Coefficient0)
;
AbsVal = no,
Coefficient = Coefficient0
),
- ( if Coefficient = rat.zero
+ ( if Coefficient = rat.zero
then unexpected(this_file,
- "normalize_term_and_const/5: zero coefficient.")
+ "normalize_term_and_const/5: zero coefficient.")
else true
),
DivideBy = (func(Var - Coeff) = Var - (Coeff / Coefficient)),
@@ -584,8 +585,8 @@
Constraint = gte([Term | _], _)
),
DummyObjective = [Term],
- Result = lp_rational.solve(Constraints, max, DummyObjective, Vars),
- Result = inconsistent
+ lp_rational.solve(Constraints, max, DummyObjective, Vars) =
+ lp_res_inconsistent
).
simplify_constraints(Constraints) = remove_weaker(remove_trivial(Constraints)).
@@ -609,7 +610,7 @@
Result = [ Constraint | Result0 ]
)
)
- ).
+ ).
:- func remove_weaker(constraints) = constraints.
@@ -623,11 +624,11 @@
;
Keep = no,
Result = Result0
- ).
+ ).
:- pred remove_weaker_2(constraint::in, constraint::in, constraints::in,
constraints::out, bool::in, bool::out) is det.
-
+
remove_weaker_2(A, B, !Acc, !Keep) :-
( is_stronger(A, B) -> true
; is_stronger(B, A) -> list.cons(B, !Acc), !:Keep = no
@@ -643,7 +644,7 @@
is_stronger(lte([Var - (-one)], ConstA), lte([Var - (-one)], ConstB)) :-
ConstA =< zero, ConstA =< ConstB.
is_stronger(eq(Terms, ConstA), lte(negate_lp_terms(Terms), ConstB)) :-
- ConstA >= (-one) * ConstB.
+ ConstA >= (-one) * ConstB.
is_stronger(lte(Terms, ConstA), lte(Terms, ConstB)) :-
ConstB =< zero, ConstA =< ConstB.
@@ -661,8 +662,8 @@
substitute_vars_2(SubstMap, eq(Terms0, Const)) = Result :-
Terms = list.map(substitute_term(SubstMap), Terms0),
Result = eq(sum_like_terms(Terms), Const).
-substitute_vars_2(_, gte(_, _)) =
- unexpected(this_file, "substitute_vars_2/2: gte.").
+substitute_vars_2(_, gte(_, _)) =
+ unexpected(this_file, "substitute_vars_2/2: gte.").
:- func substitute_term(map(lp_var, lp_var), lp_term) = lp_term.
@@ -696,21 +697,23 @@
bounding_box(Varset, Constraints) = BoundingBox :-
Vars = set.to_sorted_list(get_vars_from_constraints(Constraints)),
- BoundingBox = list.foldl((func(Var, Constrs0) = Constrs :-
+ CallProject =
+ (func(Var, Constrs0) = Constrs :-
Result = lp_rational.project([Var], Varset, Constrs0),
(
- Result = inconsistent,
+ Result = pr_res_inconsistent,
Constrs = [false_constraint]
;
% If we needed to abort this computation
% we will just approximate the whole lot
% by `true'.
- Result = aborted,
+ Result = pr_res_aborted,
Constrs = []
;
- Result = ok(Constrs)
+ Result = pr_res_ok(Constrs)
)
- ), Vars, Constraints).
+ ),
+ BoundingBox = list.foldl(CallProject, Vars, Constraints).
nonneg_box(VarsToIgnore, Constraints) = NonNegConstraints :-
Vars0 = get_vars_from_constraints(Constraints),
@@ -729,39 +732,37 @@
% Linear solver.
%
-% XXX Most of this came from lp.m. We should try to remove a lot of
+% XXX Most of this came from lp.m. We should try to remove a lot of
% nondeterminism here.
:- type lp_info
- ---> lp(
- varset :: lp_varset,
- slack_vars :: lp_vars, % - slack variables.
- art_vars :: lp_vars % - artificial variables.
- ).
+ ---> lp(
+ varset :: lp_varset,
+ slack_vars :: lp_vars, % - slack variables.
+ art_vars :: lp_vars % - artificial variables.
+ ).
lp_rational.solve(Constraints, Direction, Objective, Varset) = Result :-
Info0 = lp_info_init(Varset),
solve_2(Constraints, Direction, Objective, Result, Info0, _).
% solve_2(Eqns, Dir, Obj, Res, LPInfo0, LPInfo) takes a list
- % of inequalities `Eqns', a direction for optimization `Dir', an
+ % of inequalities `Eqns', a direction for optimization `Dir', an
% objective function `Obj' and an lp_info structure `LPInfo0'.
% See inline comments for details on the algorithm.
%
-:- pred solve_2(constraints::in, direction::in, objective::in,
+:- pred solve_2(constraints::in, direction::in, objective::in,
lp_result::out, lp_info::in, lp_info::out) is det.
solve_2(!.Constraints, Direction, !.Objective, Result, !LPInfo) :-
- %
% Simplify the inequalities and convert them to standard form by
% introducing slack/artificial variables.
- %
+
Obj = !.Objective,
lp_standardize_constraints(!Constraints, !LPInfo),
- %
+
% If we are maximizing the objective function then we need
% to negate all the coefficients in the objective.
- %
(
Direction = max,
ObjTerms = negate_constraint(eq(!.Objective, zero)),
@@ -776,8 +777,7 @@
VarNums = number_vars(VarList, 0),
ArtVars = !.LPInfo ^ art_vars,
Tableau0 = init_tableau(Rows, Columns, VarNums),
- insert_constraints(!.Constraints, 1, Columns, VarNums,
- Tableau0, Tableau),
+ insert_constraints(!.Constraints, 1, Columns, VarNums, Tableau0, Tableau),
(
ArtVars = [_|_],
% There are one or more artificial variables, so we use
@@ -793,15 +793,13 @@
;
Direction = min,
(
- Result0 = unbounded,
- Result = Result0
- ;
- Result0 = inconsistent,
+ ( Result0 = lp_res_unbounded
+ ; Result0 = lp_res_inconsistent
+ ),
Result = Result0
;
- Result0 = satisfiable(NOptVal, OptCoffs),
- OptVal = -NOptVal,
- Result = satisfiable(OptVal, OptCoffs)
+ Result0 = lp_res_satisfiable(OptVal, OptCoffs),
+ Result = lp_res_satisfiable(-OptVal, OptCoffs)
)
).
@@ -817,35 +815,33 @@
%-----------------------------------------------------------------------------%
-:- func two_phase(lp_terms, lp_terms, lp_vars, map(lp_var, int), tableau)
+:- func two_phase(lp_terms, lp_terms, lp_vars, map(lp_var, int), tableau)
= lp_result.
two_phase(Obj0, Obj, ArtVars, VarNums, !.Tableau) = Result :-
- %
% Phase 1: minimize the sum of the artificial variables.
- %
+
ArtObj = list.map(lp_term, ArtVars),
insert_terms(ArtObj, 0, VarNums, !Tableau),
ensure_zero_obj_coeffs(ArtVars, !Tableau),
optimize(ArtVars, Result0, !Tableau),
(
- Result0 = unbounded,
- Result = unbounded
+ Result0 = lp_res_unbounded,
+ Result = lp_res_unbounded
;
- Result0 = inconsistent,
- Result = inconsistent
+ Result0 = lp_res_inconsistent,
+ Result = lp_res_inconsistent
;
- Result0 = satisfiable(Val, _ArtRes),
+ Result0 = lp_res_satisfiable(Val, _ArtRes),
( if Val \= zero
- then Result = inconsistent
- else
+ then Result = lp_res_inconsistent
+ else
fix_basis_and_rem_cols(ArtVars, !.Tableau, Tableau1),
- %
+
% Phase 2:
- % Insert the real objective, zero the objective
- % coefficients of the basis variables and optimize
- % the objective.
- %
+ % Insert the real objective, zero the objective coefficients
+ % of the basis variables and optimize the objective.
+
insert_terms(Obj, 0, VarNums, Tableau1, Tableau2),
BasisVars = get_basis_vars(Tableau2),
ensure_zero_obj_coeffs(BasisVars, Tableau2, Tableau3),
@@ -857,15 +853,15 @@
%-----------------------------------------------------------------------------%
-:- pred lp_standardize_constraints(constraints::in, constraints::out,
+:- pred lp_standardize_constraints(constraints::in, constraints::out,
lp_info::in, lp_info::out) is det.
lp_standardize_constraints(!Constraints, !LPInfo) :-
list.map_foldl(lp_standardize_constraint, !Constraints, !LPInfo).
-
+
% standardize_constraint performs the following operations on a
% constraint:
- % - ensures the constant is >= 0
+ % - ensures the constant is >= 0
% (multiplying by -1 if necessary)
% - introduces slack and artificial variables
%
@@ -875,16 +871,16 @@
lp_standardize_constraint(Constr0 @ lte(Coeffs, Const), Constr, !LPInfo) :-
( Const < zero ->
Constr1 = negate_constraint(Constr0),
- lp_standardize_constraint(Constr1, Constr, !LPInfo)
+ lp_standardize_constraint(Constr1, Constr, !LPInfo)
;
new_slack_var(Var, !LPInfo),
Constr = lte([Var - one | Coeffs], Const)
).
-lp_standardize_constraint(Eqn0 @ eq(Coeffs, Const), Eqn, !LPInfo) :-
+lp_standardize_constraint(Eqn0 @ eq(Coeffs, Const), Eqn, !LPInfo) :-
( Const < zero ->
Eqn1 = negate_constraint(Eqn0),
lp_standardize_constraint(Eqn1, Eqn, !LPInfo)
- ;
+ ;
new_art_var(Var, !LPInfo),
Eqn = lte([Var - one | Coeffs], Const)
).
@@ -957,7 +953,7 @@
set_cell(Row, ConstCol, constant(C), !Tableau),
insert_constraints(Cs, Row + 1, ConstCol, VarNums, !Tableau).
-:- pred insert_terms(lp_terms::in, int::in, var_num_map::in,
+:- pred insert_terms(lp_terms::in, int::in, var_num_map::in,
tableau::in, tableau::out) is det.
insert_terms([], _, _, !Tableau).
@@ -971,24 +967,24 @@
:- pred optimize(lp_vars::in, lp_result::out, tableau::in, tableau::out)
is det.
-optimize(ObjVars, Result, !Tableau) :-
+optimize(ObjVars, Result, !Tableau) :-
simplex(Result0, !Tableau),
(
Result0 = no,
- Result = unbounded
+ Result = lp_res_unbounded
;
Result0 = yes,
ObjVal = !.Tableau ^ elem(0, !.Tableau ^ cols),
ObjMap = extract_objective(ObjVars, !.Tableau),
- Result = satisfiable(ObjVal, ObjMap)
+ Result = lp_res_satisfiable(ObjVal, ObjMap)
).
-:- func extract_objective(lp_vars, tableau) = map(lp_var, rat).
+:- func extract_objective(lp_vars, tableau) = map(lp_var, rat).
extract_objective(ObjVars, Tableau) = Objective :-
Objective = list.foldl(extract_obj_var(Tableau), ObjVars, map.init).
-:- func extract_obj_var(tableau, lp_var, map(lp_var, rat))
+:- func extract_obj_var(tableau, lp_var, map(lp_var, rat))
= map(lp_var, rat).
extract_obj_var(Tableau, Var, Map0) = Map :-
@@ -1044,7 +1040,7 @@
),
CVal = MVal / MaxVal,
!:Max = yes(Row - CVal)
- else
+ else
!:Max = no
)
;
@@ -1058,12 +1054,12 @@
( if CellVal = zero
then unexpected(this_file,
"simplex/3: zero divisor.")
- else true
+ else true
),
MaxVal1 = MVal / CellVal,
( if MaxVal1 =< MaxVal0
then !:Max = yes(Row - MaxVal1)
- else true
+ else true
)
)
)
@@ -1092,7 +1088,7 @@
;
FindOne = (pred(P::out) is nondet :-
all_rows(!.Tableau, R),
- ValF0 = !.Tableau ^ elem(R, Col),
+ ValF0 = !.Tableau ^ elem(R, Col),
ValF0 \= zero,
P = R - ValF0
),
@@ -1121,7 +1117,7 @@
Col = var_col(!.Tableau, Var),
BasisAgg = (pred(R::in, Ones0::in, Ones::out) is det :-
Val = !.Tableau ^ elem(R, Col),
- Ones = ( Val = zero -> Ones0 ; [Val - R | Ones0] )
+ Ones = ( Val = zero -> Ones0 ; [Val - R | Ones0] )
),
solutions.aggregate(all_rows(!.Tableau), BasisAgg, [], Res),
(
@@ -1173,7 +1169,7 @@
then unexpected(this_file, "pivot/4 - ScaleCell: zero divisor.")
else true
),
- T = T0 ^ elem(J, K) := Ajk - Apk * Ajq / Apq
+ T = T0 ^ elem(J, K) := Ajk - Apk * Ajq / Apq
),
solutions.aggregate(MostCells, ScaleCell, !Tableau),
QColumn = (pred(Cell::out) is nondet :-
@@ -1189,15 +1185,15 @@
ScaleRow = (pred(K::in, T0::in, T::out) is det :-
Apk = T0 ^ elem(P, K),
( if Apq = zero
- then unexpected(this_file, "pivot/4 - ScaleRow: zero divisor.")
- else true
+ then unexpected(this_file, "pivot/4 - ScaleRow: zero divisor.")
+ else true
),
- T = T0 ^ elem(P, K) := Apk / Apq
+ T = T0 ^ elem(P, K) := Apk / Apq
),
solutions.aggregate(PRow, ScaleRow, !Tableau),
set_cell(P, Q, one, !Tableau).
-:- pred row_op(rat::in, int::in, int::in, tableau::in,
+:- pred row_op(rat::in, int::in, int::in, tableau::in,
tableau::out) is det.
row_op(Scale, From, To, !Tableau) :-
@@ -1220,8 +1216,8 @@
rows :: int,
cols :: int,
var_nums :: map(lp_var, int),
- shunned_rows :: list(int),
- shunned_cols :: list(int),
+ shunned_rows :: list(int),
+ shunned_cols :: list(int),
cells :: map(pair(int), rat)
).
@@ -1250,11 +1246,11 @@
else true
),
( if Cell0 = Tableau ^ cells ^ elem(Row - Col)
- then Cell = Cell0
+ then Cell = Cell0
else Cell = zero
).
-:- pred set_cell(int::in, int::in, rat::in, tableau::in,
+:- pred set_cell(int::in, int::in, rat::in, tableau::in,
tableau::out) is det.
set_cell(J, K, R, Tableau0, Tableau) :-
@@ -1264,7 +1260,7 @@
"set_cell/5: Attempt to write shunned row/col.")
else true
),
- ( if R = zero
+ ( if R = zero
then Cells = map.delete(Cells0, J - K)
else Cells = map.set(Cells0, J - K, R)
),
@@ -1346,7 +1342,7 @@
:- pred new_slack_var(lp_var::out, lp_info::in, lp_info::out) is det.
-new_slack_var(Var, !LPInfo) :-
+new_slack_var(Var, !LPInfo) :-
varset.new_var(!.LPInfo ^ varset, Var, Varset),
!:LPInfo = !.LPInfo ^ varset := Varset,
Vars = !.LPInfo ^ slack_vars,
@@ -1354,7 +1350,7 @@
:- pred new_art_var(lp_var::out, lp_info::in, lp_info::out) is det.
-new_art_var(Var, !LPInfo) :-
+new_art_var(Var, !LPInfo) :-
varset.new_var(!.LPInfo ^ varset, Var, Varset),
!:LPInfo = !.LPInfo ^ varset := Varset,
Vars = !.LPInfo ^ art_vars,
@@ -1375,8 +1371,8 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
-% Projection.
-%
+% Projection.
+%
% The following code more or less follows the algorithm described in:
% Joxan Jaffar, Michael Maher, Peter Stuckey and Roland Yap.
@@ -1388,8 +1384,8 @@
% We next convert any remaining equations into opposing inequalities and
% then use Fourier elimination to try and eliminate any remaining target
-% variables. The main problem here is ensuring that we don't get
-% swamped by redundant constraints.
+% variables. The main problem here is ensuring that we don't get
+% swamped by redundant constraints.
% The implementation here uses the extensions to FM elimination described by
% Cernikov as well as some other redundancy checks. Note that in general
@@ -1397,21 +1393,21 @@
% methods is unsound (See the above article for an example).
% In addition to Cernikov's methods and quasi-syntactic redundancy checks
-% we also use a heuristic developed by Duffin to choose the order in
+% we also use a heuristic developed by Duffin to choose the order in
% which we eliminate variables (See below).
-%
+%
%-----------------------------------------------------------------------------%
-:- type vector
+:- type vector
---> vector(
label :: set(int),
% The vector's label is for redundancy checking
% during Fourier elimination - see below.
-
+
terms :: map(lp_var, coefficient),
% A map from each variable in the vector to its
% coefficient
-
+
const :: constant
).
@@ -1426,37 +1422,37 @@
% For the first branch of this switch the `Constraints' may actually
% be an inconsistent system - we don't bother checking that here though.
% We instead delay that until we need to perform an entailment check.
- %
-project([], _, _, Constraints, ok(Constraints)).
-project(!.Vars @ [_|_], Varset, MaybeThreshold, Constraints0, Result) :-
+ %
+project([], _, _, Constraints, pr_res_ok(Constraints)).
+project(!.Vars @ [_|_], Varset, MaybeThreshold, Constraints0, Result) :-
eliminate_equations(!Vars, Constraints0, EqlResult),
(
- EqlResult = inconsistent,
- Result = inconsistent
+ EqlResult = pr_res_inconsistent,
+ Result = pr_res_inconsistent
;
% Elimination of equations should not cause an abort since we always
% make the matrix smaller.
%
- EqlResult = aborted,
+ EqlResult = pr_res_aborted,
unexpected(this_file, "project/5: abort from eliminate_equations.")
;
- EqlResult = ok(Constraints1),
- %
+ EqlResult = pr_res_ok(Constraints1),
+ %
% Skip the call to fourier_elimination/6 if there are no variables to
% project - this avoids the transformation to vector form.
%
(
!.Vars = [_ | _],
- Matrix0 = constraints_to_matrix(Constraints1),
- fourier_elimination(!.Vars, Varset, MaybeThreshold, 0,
+ Matrix0 = constraints_to_matrix(Constraints1),
+ fourier_elimination(!.Vars, Varset, MaybeThreshold, 0,
Matrix0, FourierResult),
(
- FourierResult = yes(Matrix),
+ FourierResult = yes(Matrix),
Constraints = matrix_to_constraints(Matrix),
- Result = ok(Constraints)
+ Result = pr_res_ok(Constraints)
;
FourierResult = no,
- Result = aborted
+ Result = pr_res_aborted
)
;
% NOTE: the matrix `Constraints1' may actually be inconsistent
@@ -1465,12 +1461,12 @@
% operation that needs to traverse it anyway or until the
% next entailment check.
!.Vars = [],
- Result = ok(Constraints1)
- )
+ Result = pr_res_ok(Constraints1)
+ )
).
%-----------------------------------------------------------------------------%
-%
+%
% Convert each constraint into `=<' form and give each an initial label
%
@@ -1479,7 +1475,7 @@
constraints_to_matrix(Constraints) = Matrix :-
list.foldl2(fm_standardize, Constraints, 0, _, [], Matrix).
-:- pred fm_standardize(constraint::in, int::in, int::out, matrix::in,
+:- pred fm_standardize(constraint::in, int::in, int::out, matrix::in,
matrix::out) is det.
fm_standardize(lte(Terms0, Constant), !Labels, !Matrix) :-
@@ -1526,25 +1522,25 @@
% equality that contains that variable. If so, then substitute the
% value of that variable into the other constraints. Return the set
% of target variables that do not occur in any equality.
- %
+ %
:- pred eliminate_equations(lp_vars::in, lp_vars::out, constraints::in,
projection_result::out) is det.
eliminate_equations(!Vars, Constraints0, Result) :-
Constraints = simplify_constraints(Constraints0),
list.filter((pred(eq(_, _)::in) is semidet), Constraints,
- Equalities0, Inequalities0),
+ Equalities0, Inequalities0),
(
- eliminate_equations_2(!Vars, Equalities0, Equalities,
+ eliminate_equations_2(!Vars, Equalities0, Equalities,
Inequalities0, Inequalities)
->
- Result = ok(Equalities ++ Inequalities)
+ Result = pr_res_ok(Equalities ++ Inequalities)
;
- Result = inconsistent
+ Result = pr_res_inconsistent
).
-:- pred eliminate_equations_2(lp_vars::in, lp_vars::out,
- constraints::in, constraints::out, constraints::in,
+:- pred eliminate_equations_2(lp_vars::in, lp_vars::out,
+ constraints::in, constraints::out, constraints::in,
constraints::out) is semidet.
eliminate_equations_2([], [], !Equations, !Inequations).
@@ -1553,12 +1549,12 @@
( find_target_equality(Var, Target, !Equations) ->
substitute_variable(Target, Var, !Equations, !Inequations,
SuccessFlag),
- (
- SuccessFlag = no,
+ (
+ SuccessFlag = no,
list.cons(Var, !Vars),
list.cons(Target, !Equations)
;
- SuccessFlag = yes
+ SuccessFlag = yes
)
;
list.cons(Var, !Vars)
@@ -1567,14 +1563,14 @@
% Find an equation that constrains a variable we are trying
% to eliminate.
%
-:- pred find_target_equality(lp_var::in, constraint::out, constraints::in,
+:- pred find_target_equality(lp_var::in, constraint::out, constraints::in,
constraints::out) is semidet.
find_target_equality(Var, Target, Constraints0, Constraints) :-
Result = find_target_equality(Var, Constraints0),
Result = yes(Target - Constraints).
-
-:- func find_target_equality(lp_var, constraints) =
+
+:- func find_target_equality(lp_var, constraints) =
maybe(pair(constraint, constraints)).
find_target_equality(Var, Eqns) = find_target_equality_2(Var, Eqns, []).
@@ -1599,65 +1595,68 @@
% a target variable, say `x1', notionally rewrite the equation as:
%
% x1 = C - ... aN/a1 xN
- %
+ %
% and then substitute that value for x1 in the supplied sets
- % of equations and inequations.
- %
-:- pred substitute_variable(constraint::in, lp_var::in,
- constraints::in, constraints::out, constraints::in, constraints::out,
- bool::out) is semidet.
+ % of equations and inequations.
+ %
+:- pred substitute_variable(constraint::in, lp_var::in,
+ constraints::in, constraints::out, constraints::in, constraints::out,
+ bool::out) is semidet.
substitute_variable(Target0, Var, !Equations, !Inequations, Flag) :-
normalize_constraint(Var, Target0, Target),
constraint(Target, TargetCoeffs, Op, TargetConst),
- ( if Op \= (=)
- then unexpected(this_file,
- "substitute_variable/7: inequality encountered.")
- else true
+ (
+ Op = (=)
+ ;
+ ( Op = (=<)
+ ; Op = (>=)
+ ),
+ unexpected(this_file, "substitute_variable/7: inequality encountered.")
),
fix_coeff_and_const(Var, TargetCoeffs, TargetConst, Coeffs, Const),
substitute_into_constraints(Var, Coeffs, Const, !Equations, EqlFlag),
substitute_into_constraints(Var, Coeffs, Const, !Inequations, IneqlFlag),
Flag = bool.or(EqlFlag, IneqlFlag).
-
+
% Multiply the terms and constant except for the term containing
% the specified variable in preparation for making a substitution
% for that variable. Notionally this converts a constraint of the
% form:
% t + z + w = C ... C is a constant
- %
+ %
% into:
%
% t = C - z - w
%
-:- pred fix_coeff_and_const(lp_var::in, lp_terms::in, constant::in,
+:- pred fix_coeff_and_const(lp_var::in, lp_terms::in, constant::in,
lp_terms::out, constant::out) is det.
fix_coeff_and_const(_, [], Const, [], -Const).
-fix_coeff_and_const(Var, [Var1 - Coeff1 | Coeffs], Const0, FixedCoeffs,
+fix_coeff_and_const(Var, [Var1 - Coeff1 | Coeffs], Const0, FixedCoeffs,
Const) :-
fix_coeff_and_const(Var, Coeffs, Const0, FCoeffs0, Const),
FixedCoeffs = ( Var = Var1 -> FCoeffs0 ; [Var1 - (-Coeff1) | FCoeffs0]).
- % The `Flag' argument is `yes' if one or more substitutions were made,
+ % The `Flag' argument is `yes' if one or more substitutions were made,
% `no' otherwise. substitute_into_constraints/7 fails if a false
% constraint is generated as a result of a substitution. This means
- % that the original matrix was inconsistent.
+ % that the original matrix was inconsistent.
%
:- pred substitute_into_constraints(lp_var::in, lp_terms::in,
constant::in, constraints::in, constraints::out, bool::out) is semidet.
substitute_into_constraints(_, _, _, [], [], no).
substitute_into_constraints(Var, Coeffs, Const, [Constr0 | Constrs0], Result,
- Flag) :-
+ Flag) :-
substitute_into_constraint(Var, Coeffs, Const, Constr0, Constr, Flag0),
- not is_false(Constr),
- substitute_into_constraints(Var, Coeffs, Const, Constrs0, Constrs,
+ not is_false(Constr),
+ substitute_into_constraints(Var, Coeffs, Const, Constrs0, Constrs,
Flag1),
Result = ( if is_true(Constr) then Constrs else [ Constr | Constrs ] ),
Flag = bool.or(Flag0, Flag1).
-:- pred substitute_into_constraint(lp_var::in, lp_terms::in,
+:- pred substitute_into_constraint(lp_var::in, lp_terms::in,
constant::in, constraint::in, constraint::out, bool::out) is det.
substitute_into_constraint(Var, SubCoeffs, SubConst, !Constraint, Flag) :-
@@ -1685,7 +1684,7 @@
% Will return `no' if it aborts otherwise `yes(Matrix)', where
% `Matrix' is the result of the projection.
%
-:- pred fourier_elimination(lp_vars::in, lp_varset::in, maybe(int)::in,
+:- pred fourier_elimination(lp_vars::in, lp_varset::in, maybe(int)::in,
int::in, matrix::in, maybe(matrix)::out) is det.
fourier_elimination([], _, _, _, Matrix, yes(Matrix)).
@@ -1703,29 +1702,36 @@
then Var = TargetVar0, OtherVars = OtherVars0
else Var = Var0, OtherVars = Vars0
),
- separate_vectors(Matrix0, Var, PosMatrix, NegMatrix, ZeroMatrix,
- SizeZeroMatrix),
- %
- % `Step' counts active Fourier eliminations only. An elimination is
- % active if at least one constraint contains a term that has a
- % non-zero coefficient for the variable being eliminated.
- %
- ( PosMatrix \= [], NegMatrix \= [] ->
+ separate_vectors(Matrix0, Var, PosMatrix, NegMatrix, ZeroMatrix,
+ SizeZeroMatrix),
+
+ % `Step' counts active Fourier eliminations only. An elimination is active
+ % if at least one constraint contains a term that has a non-zero
+ % coefficient for the variable being eliminated.
+
+ (
+ PosMatrix = [_ | _],
+ NegMatrix = [_ | _]
+ ->
!:Step = !.Step + 1,
- ( list.foldl2(eliminate_var(!.Step, MaybeThreshold, NegMatrix),
- PosMatrix, ZeroMatrix, ResultMatrix, SizeZeroMatrix, _)
+ (
+ list.foldl2(eliminate_var(!.Step, MaybeThreshold, NegMatrix),
+ PosMatrix, ZeroMatrix, ResultMatrix, SizeZeroMatrix, _)
->
NewMatrix = yes(ResultMatrix)
- ;
+ ;
NewMatrix = no
)
- ;
+ ;
NewMatrix = yes(ZeroMatrix)
),
- ( if NewMatrix = yes(Matrix)
- then fourier_elimination(OtherVars, Varset, MaybeThreshold, !.Step,
+ (
+ NewMatrix = yes(Matrix),
+ fourier_elimination(OtherVars, Varset, MaybeThreshold, !.Step,
Matrix, Result)
- else Result = no
+ ;
+ NewMatrix = no,
+ Result = no
).
% separate_vectors(Matrix, Var, Positive, Negative, Zero, Num).
@@ -1746,7 +1752,7 @@
matrix::out, matrix::in, matrix::out, matrix::in, matrix::out,
int::in, int::out) is det.
-classify_vector(Var, Vector0, !Pos, !Neg, !Zero, !Num) :-
+classify_vector(Var, Vector0, !Pos, !Neg, !Zero, !Num) :-
( Coefficient = Vector0 ^ terms ^ elem(Var) ->
Vector0 = vector(Label, Terms0, Const0),
normalize_vector(Var, Terms0, Const0, Terms, Const),
@@ -1771,7 +1777,7 @@
:- pred combine_vectors(int::in, maybe(int)::in, vector::in,
vector::in, matrix::in, matrix::out, int::in, int::out) is semidet.
-combine_vectors(Step, MaybeThreshold, vector(LabelPos, TermsPos, ConstPos),
+combine_vectors(Step, MaybeThreshold, vector(LabelPos, TermsPos, ConstPos),
vector(LabelNeg, TermsNeg, ConstNeg), !Zeros, !Num) :-
LabelNew = set.union(LabelPos, LabelNeg),
(
@@ -1782,18 +1788,18 @@
add_vectors(TermsPos, ConstPos, TermsNeg, ConstNeg, Coeffs,
Const),
New = vector(LabelNew, Coeffs, Const),
- (
+ (
(
% Do not bother adding the new constraint
% if it is just `true'.
map.is_empty(Coeffs),
Const >= zero
;
- list.member(Vec, !.Zeros),
+ list.member(Vec, !.Zeros),
quasi_syntactic_redundant(New, Vec)
)
->
- % If the new constraint is `true' or is
+ % If the new constraint is `true' or is
% quasi-syntactic redundant with something
% already there.
true
@@ -1809,16 +1815,16 @@
(
list.member(Vec, !.Zeros),
label_subsumed(New, Vec)
- ->
+ ->
% Do not add the new constraint because it is label
% subsumed by something already in the matrix.
%
true
- ;
+ ;
filter_and_count(
(pred(Vec2::in) is semidet :-
not label_subsumed(Vec2, New)
- ),
+ ),
!.Zeros, [], !:Zeros, 0, !:Num),
list.cons(New, !Zeros),
!:Num = !.Num + 1
@@ -1854,25 +1860,25 @@
% Succeeds if the first vector is quasi-syntactic redundant wrt to the
% second. That is c = c' + (0 < e), for e > 0.
%
-:- pred quasi_syntactic_redundant(vector::in, vector::in) is semidet.
+:- pred quasi_syntactic_redundant(vector::in, vector::in) is semidet.
quasi_syntactic_redundant(VecA, VecB) :-
VecB ^ const < VecA ^ const,
all [Var] (
- map.member(VecA ^ terms, Var, Coeff) <=>
+ map.member(VecA ^ terms, Var, Coeff) <=>
map.member(VecB ^ terms, Var, Coeff)
).
%-----------------------------------------------------------------------------%
-%
-% Label subsumption.
+%
+% Label subsumption.
%
% label_subsumed(A, B) : succeeds iff
% constraint A is label subsumed by constraint B.
%
:- pred label_subsumed(vector::in, vector::in) is semidet.
-label_subsumed(VectorA, VectorB) :-
+label_subsumed(VectorA, VectorB) :-
set.subset(VectorB ^ label, VectorA ^ label).
%-----------------------------------------------------------------------------%
@@ -1880,9 +1886,9 @@
% Duffin's heuristic.
%
-% This attempts to find an order in which to eliminate variables such that
+% This attempts to find an order in which to eliminate variables such that
% the minimal number of redundant constraints are generated at each
-% Fourier step. For each variable, x_h, to be eliminated, we
+% Fourier step. For each variable, x_h, to be eliminated, we
% calculate E(x_h) which is defined as follows:
%
% E(x_h) = p(x_h)q(x_h) + r(x_h) ... if p(x_h) + q(x_h) > 0
@@ -1904,7 +1910,7 @@
% We can work out the zero occurrences by subtracting the two
% previous totals from the total number of constraints.
%
-:- type coeff_info
+:- type coeff_info
---> coeff_info(
pos :: int,
neg :: int
@@ -1918,7 +1924,7 @@
% anyway). Fails if it can't find such a variable, ie. none of the
% variables being eliminated actually occurs in the constraints.
%
-:- pred duffin_heuristic(lp_vars::in, matrix::in, lp_var::out,
+:- pred duffin_heuristic(lp_vars::in, matrix::in, lp_var::out,
lp_vars::out) is semidet.
duffin_heuristic([Var], _, Var, []).
@@ -1943,8 +1949,8 @@
find_max([]) = unexpected(this_file, "find_max/2: empty list passed as arg.").
find_max([Var0 - ExpnNum0 | Vars]) = fst(find_max_2(Vars, Var0 - ExpnNum0)).
-:- func find_max_2(assoc_list(lp_var, int), pair(lp_var, int)) =
- pair(lp_var, int).
+:- func find_max_2(assoc_list(lp_var, int), pair(lp_var, int)) =
+ pair(lp_var, int).
find_max_2([], Best) = Best.
find_max_2([Var1 - ExpnNum1 | Vars], Var0 - ExpnNum0) =
@@ -1967,17 +1973,17 @@
Vars = list.sort_and_remove_dups(Vars0),
CoeffMap0 = init_cc_map(Vars),
CoeffMap = list.foldl(count_coeffs_in_vector, Matrix, CoeffMap0),
- CoeffList = map.to_assoc_list(CoeffMap),
+ CoeffList = map.to_assoc_list(CoeffMap),
ConstrNum = list.length(Matrix),
ExpansionNums = list.map(make_expansion_num(ConstrNum), CoeffList).
:- func make_expansion_num(int, pair(lp_var, coeff_info)) = pair(lp_var, int).
-
+
make_expansion_num(ConstrNum, Var - coeff_info(Pos, Neg)) = Var - ExpnNum :-
PosAndNeg = Pos + Neg,
- ( if PosAndNeg = 0
+ ( if PosAndNeg = 0
then ExpnNum = 0
- else ExpnNum = (Pos * Neg) + (ConstrNum - PosAndNeg)
+ else ExpnNum = (Pos * Neg) + (ConstrNum - PosAndNeg)
).
:- func count_coeffs_in_vector(vector, cc_map) = cc_map.
@@ -2000,8 +2006,8 @@
),
svmap.det_update(Var, coeff_info(Pos, Neg), !Map)
;
- true
- % If the variable in the term was not in the map then it is not
+ true
+ % If the variable in the term was not in the map then it is not
% one of the ones that is being eliminated.
).
@@ -2016,11 +2022,11 @@
%
% Predicates for normalizing vectors and constraints.
%
-
+
% normalize_vector(Var, Terms0, Const0, Terms, Const).
% Multiply the given vector by a scalar appropraite to make the
% coefficient of the given variable in the vector one. Throws
- % an exception if `Var' has a zero coefficient.
+ % an exception if `Var' has a zero coefficient.
%
:- pred normalize_vector(lp_var::in, map(lp_var, coefficient)::in,
constant::in, map(lp_var, coefficient)::out, constant::out) is det.
@@ -2034,7 +2040,7 @@
),
DivVal = rat.abs(Coefficient),
!:Terms = map.map_values((func(_, C) = C / DivVal), !.Terms),
- !:Constant = !.Constant / DivVal
+ !:Constant = !.Constant / DivVal
;
% In this case the the coefficient of the variable was zero
% (implicit in the fact that it is not in the map).
@@ -2060,8 +2066,8 @@
else true
),
Terms = list.map((func(V - C) = V - (C / Coefficient)), Terms0),
- Constant = Constant0 / Coefficient,
- ( if Coefficient < zero
+ Constant = Constant0 / Coefficient,
+ ( if Coefficient < zero
then Op = negate_operator(Op0)
else Op = Op0
)
@@ -2071,9 +2077,9 @@
Terms = Terms0,
Op = Op0,
Constant = Constant0
- ),
+ ),
Constraint = lp_rational.unchecked_constraint(Terms, Op, Constant).
-
+
:- pred add_vectors(map(lp_var, coefficient)::in, constant::in,
map(lp_var, coefficient)::in, constant::in,
map(lp_var, coefficient)::out, constant::out) is det.
@@ -2096,7 +2102,7 @@
solutions.aggregate(IsMapKey, AddVal, TermsB, Terms).
%-----------------------------------------------------------------------------%
-%
+%
% Redundancy checking using the linear solver
%
@@ -2104,10 +2110,10 @@
% XXX It would be preferable not to use this as it can be very slow.
%
remove_some_entailed_constraints(Varset, Constraints0, Constraints) :-
- remove_some_entailed_constraints_2(Varset, Constraints0, [],
+ remove_some_entailed_constraints_2(Varset, Constraints0, [],
Constraints).
-:- pred remove_some_entailed_constraints_2(lp_varset::in, constraints::in,
+:- pred remove_some_entailed_constraints_2(lp_varset::in, constraints::in,
constraints::in, constraints::out) is semidet.
remove_some_entailed_constraints_2(_, [], !Constraints).
@@ -2119,7 +2125,7 @@
;
RestOfMatrix = [ X | Es ] ++ !.Constraints,
Result = entailed(Varset, RestOfMatrix, E),
- (
+ (
Result = entailed
;
Result = not_entailed,
@@ -2135,17 +2141,17 @@
restore_equalities([], []).
restore_equalities([E0 | Es0], [E | Es]) :-
- ( if check_for_equalities(E0, Es0, [], E1, Es1)
- then E = E1, Es2 = Es1
+ ( if check_for_equalities(E0, Es0, [], E1, Es1)
+ then E = E1, Es2 = Es1
else Es2 = Es0, E = E0
),
restore_equalities(Es2, Es).
-:- pred check_for_equalities(constraint::in, constraints::in, constraints::in,
+:- pred check_for_equalities(constraint::in, constraints::in, constraints::in,
constraint::out, constraints::out) is semidet.
check_for_equalities(Eqn0, [Eqn | Eqns], SoFar, NewEqn, NewEqnSet) :-
- (
+ (
opposing_inequalities(Eqn0 @ lte(Coeffs, Constant), Eqn)
->
NewEqn = standardize_constraint(eq(Coeffs, Constant)),
@@ -2155,20 +2161,20 @@
).
% Checks if a pair of constraints are inequalities of the form:
- %
+ %
% -ax1 - ax2 - ... - axN =< -C
% ax1 + ax2 + ... + axN =< C
- %
+ %
% These can be converted into the equality:
%
- % ax1 + ... + axN = C
+ % ax1 + ... + axN = C
%
% NOTE: we don't check for gte constraints because these should
- % have been transformed away when we converted to standard form.
+ % have been transformed away when we converted to standard form.
%
:- pred opposing_inequalities(constraint::in, constraint::in) is semidet.
-opposing_inequalities(lte(TermsA, Const), lte(TermsB, -Const)) :-
+opposing_inequalities(lte(TermsA, Const), lte(TermsB, -Const)) :-
TermsB = list.map((func(V - X) = V - (-X)), TermsA).
%-----------------------------------------------------------------------------%
@@ -2176,49 +2182,53 @@
%
% Entailment test
%
-
+
entailed(Varset, Constraints, lte(Objective, Constant)) = Result :-
- SolverResult = lp_rational.solve(Constraints, max, Objective, Varset),
- (
- SolverResult = satisfiable(MaxVal, _),
+ SolverResult = lp_rational.solve(Constraints, max, Objective, Varset),
+ (
+ SolverResult = lp_res_satisfiable(MaxVal, _),
Result = ( if MaxVal =< Constant then entailed else not_entailed )
;
- SolverResult = unbounded,
+ SolverResult = lp_res_unbounded,
Result = not_entailed
;
- SolverResult = inconsistent,
+ SolverResult = lp_res_inconsistent,
Result = inconsistent
- ).
+ ).
entailed(Varset, Constraints, eq(Objective, Constant)) = Result :-
Result0 = entailed(Varset, Constraints, lte(Objective, Constant)),
- ( Result0 = entailed ->
+ (
+ Result0 = entailed,
Result = entailed(Varset, Constraints, gte(Objective, Constant))
;
+ ( Result0 = not_entailed
+ ; Result0 = inconsistent
+ ),
Result0 = Result
).
entailed(Varset, Constraints, gte(Objective, Constant)) = Result :-
SolverResult = lp_rational.solve(Constraints, min, Objective, Varset),
- (
- SolverResult = satisfiable(MinVal, _),
+ (
+ SolverResult = lp_res_satisfiable(MinVal, _),
Result = ( if MinVal >= Constant then entailed else not_entailed )
;
- SolverResult = unbounded,
+ SolverResult = lp_res_unbounded,
Result = not_entailed
;
- SolverResult = inconsistent,
+ SolverResult = lp_res_inconsistent,
Result = inconsistent
- ).
+ ).
entailed(Varset, Constraints, Constraint) :-
Result = entailed(Varset, Constraints, Constraint),
- (
+ (
Result = entailed
;
Result = inconsistent,
unexpected(this_file, "entailed/3: inconsistent constraint set.")
;
Result = not_entailed,
- fail
+ fail
).
%-----------------------------------------------------------------------------%
@@ -2258,16 +2268,16 @@
io.write_string(" (", !IO),
Num = abs(numer(Coefficient)),
io.write_string(int_to_string(Num), !IO),
- ( if denom(Coefficient) \= 1
+ ( if denom(Coefficient) \= 1
then io.format("/%s", [s(int_to_string(denom(Coefficient)))], !IO)
- else true
+ else true
),
io.write_char(')', !IO),
io.write_string(varset.lookup_name(Varset, Var), !IO).
%-----------------------------------------------------------------------------%
%
-% Debugging predicates for writing out constraints.
+% Debugging predicates for writing out constraints.
%
write_constraints(Constraints, Varset, !IO) :-
@@ -2275,18 +2285,18 @@
:- pred write_constraint(lp_varset::in, constraint::in, io::di, io::uo) is det.
-write_constraint(Varset, Constr, !IO) :-
+write_constraint(Varset, Constr, !IO) :-
constraint(Constr, Coeffs, Operator, Constant),
io.write_char('\t', !IO),
list.foldl(write_constr_term(Varset), Coeffs, !IO),
io.format("%s %s\n", [s(operator_to_string(Operator)),
- s(rat.to_string(Constant))], !IO).
+ s(rat.to_string(Constant))], !IO).
:- pred write_constr_term(lp_varset::in, lp_term::in, io::di, io::uo) is det.
write_constr_term(Varset, Var - Coeff, !IO) :-
VarName = varset.lookup_name(Varset, Var),
- io.format("%s%s ", [s(rat.to_string(Coeff)), s(VarName)], !IO).
+ io.format("%s%s ", [s(rat.to_string(Coeff)), s(VarName)], !IO).
:- func operator_to_string(operator) = string.
@@ -2306,7 +2316,12 @@
write_vars_2(_, [], !IO).
write_vars_2(Varset, [V | Vs], !IO) :-
io.write_string(var_to_string(Varset, V), !IO),
- ( if Vs = [] then true else io.write_string(", ", !IO)),
+ (
+ Vs = []
+ ;
+ Vs = [_ | _],
+ io.write_string(", ", !IO)
+ ),
write_vars_2(Varset, Vs, !IO).
:- func var_to_string(lp_varset, lp_var) = string.
@@ -2317,7 +2332,7 @@
% `Labels' is `yes' then write out the label for each vector
% as well.
%
-:- pred write_matrix(lp_varset::in, bool::in, matrix::in, io::di, io::uo)
+:- pred write_matrix(lp_varset::in, bool::in, matrix::in, io::di, io::uo)
is det.
write_matrix(Varset, Labels, Matrix, !IO) :-
@@ -2343,7 +2358,7 @@
output_constraints(OutputVar, Constraints, !IO) :-
io.write_char('[', !IO),
io.write_list(Constraints, ", ", output_constraint(OutputVar), !IO),
- io.write_char(']', !IO).
+ io.write_char(']', !IO).
:- pred output_constraint(output_var::in, constraint::in,
io::di, io::uo) is det.
@@ -2356,7 +2371,7 @@
output_constraint_2(OutputVar, Terms, Constant, !IO).
output_constraint(_, gte(_,_), _, _) :-
unexpected(this_file, "output_constraint/3: gte encountered.").
-
+
:- pred output_constraint_2(output_var::in, lp_terms::in,
constant::in, io::di, io::uo) is det.
Index: compiler/make.dependencies.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.dependencies.m,v
retrieving revision 1.43
diff -u -r1.43 make.dependencies.m
--- compiler/make.dependencies.m 26 Sep 2007 01:46:18 -0000 1.43
+++ compiler/make.dependencies.m 21 Nov 2007 14:42:38 -0000
@@ -170,12 +170,9 @@
(find_module_deps(T)::out(find_module_deps)) is det.
combine_deps_list([]) = no_deps.
-combine_deps_list([FindDeps | FindDepsList]) =
- ( FindDepsList = [] ->
- FindDeps
- ;
- combine_deps(FindDeps, combine_deps_list(FindDepsList))
- ).
+combine_deps_list([FindDeps]) = FindDeps.
+combine_deps_list([FindDeps1, FindDeps2 | FindDepsTail]) =
+ combine_deps(FindDeps1, combine_deps_list([FindDeps2 | FindDepsTail])).
target_dependencies(_, module_target_source) = no_deps.
target_dependencies(Globals, module_target_errors) =
@@ -216,8 +213,7 @@
compiled_code_dependencies(Globals).
target_dependencies(Globals, module_target_object_code(PIC)) = Deps :-
globals.get_target(Globals, CompilationTarget),
- TargetCode = ( CompilationTarget = target_asm ->
- module_target_asm_code(PIC) ; module_target_c_code ),
+ TargetCode = target_to_module_target_code(CompilationTarget, PIC),
globals.lookup_bool_option(Globals, highlevel_code, HighLevelCode),
% For --highlevel-code, the `.c' file will #include the header
@@ -269,7 +265,7 @@
get_foreign_deps(Globals, PIC).
target_dependencies(Globals, module_target_fact_table_object(PIC, _)) =
get_foreign_deps(Globals, PIC).
-target_dependencies(_, module_target_xml_doc) =
+target_dependencies(_, module_target_xml_doc) =
combine_deps_list([
module_target_source `of` self,
module_target_private_interface `of` parents,
@@ -282,12 +278,28 @@
get_foreign_deps(Globals, PIC) = Deps :-
globals.get_target(Globals, CompilationTarget),
- TargetCode = ( CompilationTarget = target_asm ->
- module_target_asm_code(PIC) ; module_target_c_code ),
+ TargetCode = target_to_module_target_code(CompilationTarget, PIC),
Deps = combine_deps_list([
TargetCode `of` self
]).
+:- func target_to_module_target_code(compilation_target, pic)
+ = module_target_type.
+
+target_to_module_target_code(CompilationTarget, PIC) = TargetCode :-
+ (
+ CompilationTarget = target_asm,
+ TargetCode = module_target_asm_code(PIC)
+ ;
+ ( CompilationTarget = target_c
+ ; CompilationTarget = target_il
+ ; CompilationTarget = target_java
+ ; CompilationTarget = target_x86_64
+ ; CompilationTarget = target_erlang
+ ),
+ TargetCode = module_target_c_code
+ ).
+
:- func interface_file_dependencies =
(find_module_deps(dependency_file)::out(find_module_deps)) is det.
@@ -1045,22 +1057,26 @@
debug_msg(WriteMissingDeps, !IO)
)
;
- Rebuild = yes
- ->
- % With `--rebuild', a target is always considered to be
- % out-of-date, regardless of the timestamps of its dependencies.
-
- DepsResult = deps_out_of_date
- ;
- list.member(MaybeDepTimestamp2, DepTimestamps),
- MaybeDepTimestamp2 = ok(DepTimestamp),
- compare((>), DepTimestamp, Timestamp)
- ->
- debug_newer_dependencies(TargetFileName, MaybeTimestamp,
- DepFiles, DepTimestamps, !IO),
- DepsResult = deps_out_of_date
- ;
- DepsResult = deps_up_to_date
+ (
+ Rebuild = yes,
+ % With `--rebuild', a target is always considered to be
+ % out-of-date, regardless of the timestamps of its
+ % dependencies.
+ DepsResult = deps_out_of_date
+ ;
+ Rebuild = no,
+ (
+ list.member(MaybeDepTimestamp2, DepTimestamps),
+ MaybeDepTimestamp2 = ok(DepTimestamp),
+ compare((>), DepTimestamp, Timestamp)
+ ->
+ debug_newer_dependencies(TargetFileName, MaybeTimestamp,
+ DepFiles, DepTimestamps, !IO),
+ DepsResult = deps_out_of_date
+ ;
+ DepsResult = deps_up_to_date
+ )
+ )
)
).
Index: compiler/make.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.m,v
retrieving revision 1.50
diff -u -r1.50 make.m
--- compiler/make.m 27 Aug 2007 06:36:33 -0000 1.50
+++ compiler/make.m 21 Nov 2007 14:49:26 -0000
@@ -216,14 +216,14 @@
:- type target_file
---> target_file(
- target_file_name :: module_name,
- target_file_type :: module_target_type
+ target_file_name :: module_name,
+ target_file_type :: module_target_type
).
-:- type linked_target_file
+:- type linked_target_file
---> linked_target_file(
- linked_tf_name :: module_name,
- linked_tf_type :: linked_target_type
+ linked_tf_name :: module_name,
+ linked_tf_type :: linked_target_type
).
%-----------------------------------------------------------------------------%
Index: compiler/make.module_dep_file.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.module_dep_file.m,v
retrieving revision 1.30
diff -u -r1.30 make.module_dep_file.m
--- compiler/make.module_dep_file.m 27 Aug 2007 06:36:33 -0000 1.30
+++ compiler/make.module_dep_file.m 21 Nov 2007 14:43:57 -0000
@@ -58,32 +58,38 @@
get_module_dependencies(ModuleName, MaybeImports, !Info, !IO) :-
RebuildModuleDeps = !.Info ^ rebuild_module_deps,
- ( ModuleName = unqualified(_) ->
+ (
+ ModuleName = unqualified(_),
maybe_get_module_dependencies(RebuildModuleDeps, ModuleName,
MaybeImports, !Info, !IO)
- ; map.search(!.Info ^ module_dependencies, ModuleName, MaybeImports0) ->
- MaybeImports = MaybeImports0
;
- %
- % For sub-modules, we need to generate the dependencies
- % for the parent modules first (make_module_dependencies
- % expects to be given the top-level module in a source file).
- % If the module is a nested module, its dependencies will be
- % generated as a side effect of generating the parent's
- % dependencies.
- %
- Ancestors = get_ancestors(ModuleName),
- list.foldl3(generate_ancestor_dependencies(RebuildModuleDeps),
- Ancestors, no, Error, !Info, !IO),
+ ModuleName = qualified(_, _),
(
- Error = yes,
- MaybeImports = no,
- !:Info = !.Info ^ module_dependencies
- ^ elem(ModuleName) := MaybeImports
+ map.search(!.Info ^ module_dependencies, ModuleName,
+ MaybeImportsPrime)
+ ->
+ MaybeImports = MaybeImportsPrime
;
- Error = no,
- maybe_get_module_dependencies(RebuildModuleDeps,
- ModuleName, MaybeImports, !Info, !IO)
+ % For sub-modules, we need to generate the dependencies
+ % for the parent modules first (make_module_dependencies
+ % expects to be given the top-level module in a source file).
+ % If the module is a nested module, its dependencies will be
+ % generated as a side effect of generating the parent's
+ % dependencies.
+
+ Ancestors = get_ancestors(ModuleName),
+ list.foldl3(generate_ancestor_dependencies(RebuildModuleDeps),
+ Ancestors, no, Error, !Info, !IO),
+ (
+ Error = yes,
+ MaybeImports = no,
+ !:Info = !.Info ^ module_dependencies
+ ^ elem(ModuleName) := MaybeImports
+ ;
+ Error = no,
+ maybe_get_module_dependencies(RebuildModuleDeps,
+ ModuleName, MaybeImports, !Info, !IO)
+ )
)
).
Index: compiler/make.module_target.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.module_target.m,v
retrieving revision 1.59
diff -u -r1.59 make.module_target.m
--- compiler/make.module_target.m 31 Aug 2007 07:16:41 -0000 1.59
+++ compiler/make.module_target.m 21 Nov 2007 14:50:50 -0000
@@ -95,7 +95,16 @@
make_module_target_extra_options(_ExtraOptions, dep_file(_, _) @ Dep,
Succeeded, !Info, !IO) :-
dependency_status(Dep, Status, !Info, !IO),
- Succeeded = ( Status = deps_status_error -> no ; yes ).
+ (
+ Status = deps_status_error,
+ Succeeded = no
+ ;
+ ( Status = deps_status_not_considered
+ ; Status = deps_status_being_built
+ ; Status = deps_status_up_to_date
+ ),
+ Succeeded = yes
+ ).
make_module_target_extra_options(ExtraOptions, dep_target(TargetFile) @ Dep,
Succeeded, !Info, !IO) :-
dependency_status(Dep, Status, !Info, !IO),
@@ -177,8 +186,13 @@
make_dependency_files(TargetFile, DepFilesToMake,
TouchedTargetFiles, TouchedFiles, DepsResult0,
!Info, !IO),
- DepsResult =
- ( DepsSuccess = yes -> DepsResult0 ; deps_error )
+ (
+ DepsSuccess = yes,
+ DepsResult = DepsResult0
+ ;
+ DepsSuccess = no,
+ DepsResult = deps_error
+ )
),
(
DepsResult = deps_error,
@@ -237,59 +251,58 @@
make_dependency_files(TargetFile, DepFilesToMake, TouchedTargetFiles,
TouchedFiles, DepsResult, !Info, !IO) :-
- %
% Build the dependencies.
- %
+
globals.io_lookup_bool_option(keep_going, KeepGoing, !IO),
foldl2_maybe_stop_at_error(KeepGoing, make_module_target,
DepFilesToMake, MakeDepsSuccess, !Info, !IO),
- %
% Check that the target files exist.
- %
+
list.map_foldl2(get_target_timestamp(no), TouchedTargetFiles,
TargetTimestamps, !Info, !IO),
(
- MakeDepsSuccess = no
- ->
+ MakeDepsSuccess = no,
debug_file_msg(TargetFile, "error making dependencies", !IO),
DepsResult = deps_error
;
- list.member(error(_), TargetTimestamps)
- ->
- debug_file_msg(TargetFile, "target file does not exist", !IO),
- DepsResult = deps_out_of_date
- ;
- (
- TargetFile = target_file(ModuleName, FileType),
- FileType = module_target_analysis_registry
- ->
- force_reanalysis_of_suboptimal_module(ModuleName, ForceReanalysis,
- !.Info, !IO)
- ;
- ForceReanalysis = no
- ),
- (
- ForceReanalysis = yes,
+ MakeDepsSuccess = yes,
+ ( list.member(error(_), TargetTimestamps) ->
+ debug_file_msg(TargetFile, "target file does not exist", !IO),
DepsResult = deps_out_of_date
;
- ForceReanalysis = no,
+ (
+ TargetFile = target_file(ModuleName, FileType),
+ FileType = module_target_analysis_registry
+ ->
+ force_reanalysis_of_suboptimal_module(ModuleName,
+ ForceReanalysis, !.Info, !IO)
+ ;
+ ForceReanalysis = no
+ ),
+ (
+ ForceReanalysis = yes,
+ DepsResult = deps_out_of_date
+ ;
+ ForceReanalysis = no,
- % Compare the oldest of the timestamps of the touched
- % files with the timestamps of the dependencies.
+ % Compare the oldest of the timestamps of the touched
+ % files with the timestamps of the dependencies.
- list.map_foldl2(get_timestamp_file_timestamp,
- TouchedTargetFiles, TouchedTargetFileTimestamps, !Info, !IO),
- list.map_foldl2(get_file_timestamp([dir.this_directory]),
- TouchedFiles, TouchedFileTimestamps, !Info, !IO),
- MaybeOldestTimestamp0 = list.foldl(find_oldest_timestamp,
- TouchedTargetFileTimestamps, ok(newest_timestamp)),
- MaybeOldestTimestamp = list.foldl(find_oldest_timestamp,
- TouchedFileTimestamps, MaybeOldestTimestamp0),
-
- get_file_name(no, TargetFile, TargetFileName, !Info, !IO),
- check_dependencies(TargetFileName, MaybeOldestTimestamp,
- MakeDepsSuccess, DepFilesToMake, DepsResult, !Info, !IO)
+ list.map_foldl2(get_timestamp_file_timestamp,
+ TouchedTargetFiles, TouchedTargetFileTimestamps,
+ !Info, !IO),
+ list.map_foldl2(get_file_timestamp([dir.this_directory]),
+ TouchedFiles, TouchedFileTimestamps, !Info, !IO),
+ MaybeOldestTimestamp0 = list.foldl(find_oldest_timestamp,
+ TouchedTargetFileTimestamps, ok(newest_timestamp)),
+ MaybeOldestTimestamp = list.foldl(find_oldest_timestamp,
+ TouchedFileTimestamps, MaybeOldestTimestamp0),
+
+ get_file_name(no, TargetFile, TargetFileName, !Info, !IO),
+ check_dependencies(TargetFileName, MaybeOldestTimestamp,
+ MakeDepsSuccess, DepFilesToMake, DepsResult, !Info, !IO)
+ )
)
).
@@ -1012,11 +1025,33 @@
:- func target_type_to_pic(module_target_type) = pic.
target_type_to_pic(TargetType) = Result :-
- ( TargetType = module_target_asm_code(PIC) ->
- Result = PIC
- ; TargetType = module_target_object_code(PIC) ->
+ (
+ ( TargetType = module_target_asm_code(PIC)
+ ; TargetType = module_target_object_code(PIC)
+ ),
Result = PIC
;
+ ( TargetType = module_target_source
+ ; TargetType = module_target_errors
+ ; TargetType = module_target_private_interface
+ ; TargetType = module_target_long_interface
+ ; TargetType = module_target_short_interface
+ ; TargetType = module_target_unqualified_short_interface
+ ; TargetType = module_target_intermodule_interface
+ ; TargetType = module_target_analysis_registry
+ ; TargetType = module_target_c_header(_)
+ ; TargetType = module_target_c_code
+ ; TargetType = module_target_il_code
+ ; TargetType = module_target_il_asm
+ ; TargetType = module_target_java_code
+ ; TargetType = module_target_erlang_header
+ ; TargetType = module_target_erlang_code
+ ; TargetType = module_target_erlang_beam_code
+ ; TargetType = module_target_foreign_il_asm(_)
+ ; TargetType = module_target_foreign_object(_, _)
+ ; TargetType = module_target_fact_table_object(_, _)
+ ; TargetType = module_target_xml_doc
+ ),
Result = non_pic
).
Index: compiler/make.program_target.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.program_target.m,v
retrieving revision 1.79
diff -u -r1.79 make.program_target.m
--- compiler/make.program_target.m 7 Sep 2007 15:08:17 -0000 1.79
+++ compiler/make.program_target.m 21 Nov 2007 15:12:08 -0000
@@ -363,8 +363,7 @@
% libraries linked using dlopen().
AllModulesList = set.to_sorted_list(AllModules),
(
- FileType = executable
- ->
+ FileType = executable,
(
( CompilationTarget = target_c
; CompilationTarget = target_asm
@@ -405,6 +404,11 @@
InitObjects = []
)
;
+ ( FileType = static_library
+ ; FileType = shared_library
+ ; FileType = java_archive
+ ; FileType = erlang_archive
+ ),
DepsResult2 = BuildDepsResult,
InitObjects = []
),
@@ -416,9 +420,11 @@
list.map((func(F) = dep_file(F, no)), ObjectsToCheck),
ExtraObjStatus, !Info, !IO),
- DepsResult3 =
- ( list.member(deps_status_error, ExtraObjStatus) ->
- deps_error ; DepsResult2 ),
+ ( list.member(deps_status_error, ExtraObjStatus) ->
+ DepsResult3 = deps_error
+ ;
+ DepsResult3 = DepsResult2
+ ),
BuildDepsSuccess = ( DepsResult3 \= deps_error -> yes ; no ),
list.map_foldl2(get_file_timestamp([dir.this_directory]),
ObjectsToCheck, ExtraObjectTimestamps, !Info, !IO),
@@ -426,7 +432,13 @@
BuildDepsSuccess, ObjectsToCheck, io.write,
ExtraObjectTimestamps, ExtraObjectDepsResult, !IO),
- DepsResult4 = ( DepsSuccess = yes -> DepsResult3 ; deps_error ),
+ (
+ DepsSuccess = yes,
+ DepsResult4 = DepsResult3
+ ;
+ DepsSuccess = no,
+ DepsResult4 = deps_error
+ ),
( DepsResult4 = deps_error, DepsResult = DepsResult4
; DepsResult4 = deps_out_of_date, DepsResult = DepsResult4
; DepsResult4 = deps_up_to_date, DepsResult = ExtraObjectDepsResult
@@ -1038,9 +1050,11 @@
% otherwise there is trouble using libraries installed by
% `mmc --make' with Mmake.
% XXX If we ever phase out mmake we could revert this behaviour.
- ( Target = target_c ; Target = target_asm )
- % Imports ^ contains_foreign_export = contains_foreign_export
- ->
+ ( Target = target_c
+ ; Target = target_asm
+ ),
+ % XXX Should we test
+ % Imports ^ contains_foreign_export = contains_foreign_export?
module_name_to_file_name(ModuleName, ".mh", no, FileName, !IO),
install_file(FileName, LibDir/"inc", HeaderSucceeded1, !IO),
@@ -1050,11 +1064,14 @@
HeaderSucceeded = HeaderSucceeded1 `and` HeaderSucceeded2
;
- Target = target_erlang
- ->
+ Target = target_erlang,
module_name_to_file_name(ModuleName, ".hrl", no, FileName, !IO),
install_file(FileName, LibDir/"inc", HeaderSucceeded, !IO)
;
+ ( Target = target_java
+ ; Target = target_il
+ ; Target = target_x86_64
+ ),
HeaderSucceeded = yes
),
Succeeded = bool.and_list([HeaderSucceeded | Results])
Index: compiler/make.util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.util.m,v
retrieving revision 1.52
diff -u -r1.52 make.util.m
--- compiler/make.util.m 24 Sep 2007 01:21:14 -0000 1.52
+++ compiler/make.util.m 21 Nov 2007 15:25:45 -0000
@@ -1089,7 +1089,8 @@
;
io.input_stream(OldInputStream, !IO),
search_for_file(SearchDirs, FileName, SearchResult, !IO),
- ( SearchResult = ok(_) ->
+ (
+ SearchResult = ok(_),
io.input_stream_name(FullFileName, !IO),
io.set_input_stream(OldInputStream, FileStream, !IO),
io.close_input(FileStream, !IO),
@@ -1105,6 +1106,7 @@
!:Info = !.Info ^ file_timestamps ^ elem(FileName)
:= MaybeTimestamp
;
+ SearchResult = error(_),
MaybeTimestamp = error("file `" ++ FileName ++ "' not found")
)
).
@@ -1263,7 +1265,8 @@
)
;
MaybeExt = no,
- ( TargetType = module_target_foreign_object(PIC, Lang) ->
+ (
+ TargetType = module_target_foreign_object(PIC, Lang),
(
ForeignModuleName =
foreign_language_module_name(ModuleName, Lang)
@@ -1274,7 +1277,8 @@
;
unexpected(this_file, "module_target_to_file_name_2")
)
- ; TargetType = module_target_foreign_il_asm(Lang) ->
+ ;
+ TargetType = module_target_foreign_il_asm(Lang),
(
ForeignModuleName =
foreign_language_module_name(ModuleName, Lang)
@@ -1284,11 +1288,32 @@
;
unexpected(this_file, "module_target_to_file_name_2")
)
- ; TargetType = module_target_fact_table_object(PIC, FactFile) ->
+ ;
+ TargetType = module_target_fact_table_object(PIC, FactFile),
maybe_pic_object_file_extension(PIC, Ext, !IO),
fact_table_file_name(ModuleName, FactFile, Ext, MkDir, FileName,
!IO)
;
+ ( TargetType = module_target_analysis_registry
+ ; TargetType = module_target_asm_code(_)
+ ; TargetType = make.module_target_c_code
+ ; TargetType = module_target_c_header(_)
+ ; TargetType = module_target_erlang_beam_code
+ ; TargetType = module_target_erlang_code
+ ; TargetType = module_target_erlang_header
+ ; TargetType = module_target_errors
+ ; TargetType = make.module_target_il_asm
+ ; TargetType = module_target_il_code
+ ; TargetType = module_target_intermodule_interface
+ ; TargetType = module_target_java_code
+ ; TargetType = module_target_long_interface
+ ; TargetType = module_target_object_code(_)
+ ; TargetType = module_target_private_interface
+ ; TargetType = module_target_short_interface
+ ; TargetType = module_target_source
+ ; TargetType = module_target_unqualified_short_interface
+ ; TargetType = module_target_xml_doc
+ ),
unexpected(this_file, "module_target_to_file_name_2")
)
).
@@ -1315,9 +1340,20 @@
timestamp_extension(_, module_target_c_code) = ".c_date".
timestamp_extension(Globals, module_target_c_header(_)) = Ext :-
globals.get_target(Globals, Target),
- Ext = timestamp_extension(Globals,
- (Target = target_asm ->
- module_target_asm_code(non_pic) ; module_target_c_code)).
+ (
+ Target = target_asm,
+ ModuleTargetType = module_target_asm_code(non_pic)
+ ;
+ % XXX Some of these alternatives don't look right.
+ ( Target = target_c
+ ; Target = target_x86_64
+ ; Target = target_il
+ ; Target = target_java
+ ; Target = target_erlang
+ ),
+ ModuleTargetType = module_target_c_code
+ ),
+ Ext = timestamp_extension(Globals, ModuleTargetType).
timestamp_extension(_, module_target_il_code) = ".il_date".
timestamp_extension(_, module_target_java_code) = ".java_date".
timestamp_extension(_, module_target_erlang_code) = ".erl_date".
Index: compiler/matching.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/matching.m,v
retrieving revision 1.12
diff -u -r1.12 matching.m
--- compiler/matching.m 6 Jan 2007 09:23:40 -0000 1.12
+++ compiler/matching.m 21 Nov 2007 05:30:26 -0000
@@ -509,9 +509,11 @@
= cost_node is semidet.
find_unmatched_cost([CostNode - MaybeBenefitNode | Matches]) = Unmatched :-
- ( MaybeBenefitNode = no ->
+ (
+ MaybeBenefitNode = no,
Unmatched = CostNode
;
+ MaybeBenefitNode = yes(_),
Unmatched = find_unmatched_cost(Matches)
).
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.453
diff -u -r1.453 mercury_compile.m
--- compiler/mercury_compile.m 1 Nov 2007 06:23:21 -0000 1.453
+++ compiler/mercury_compile.m 22 Nov 2007 01:41:52 -0000
@@ -1216,12 +1216,14 @@
split_into_submodules(ModuleName, Items, SubModuleList0, [], Specs),
write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors,
!IO),
- ( MaybeModulesToRecompile = some_modules(ModulesToRecompile) ->
+ (
+ MaybeModulesToRecompile = some_modules(ModulesToRecompile),
ToRecompile = (pred((SubModule - _)::in) is semidet :-
list.member(SubModule, ModulesToRecompile)
),
list.filter(ToRecompile, SubModuleList0, SubModuleListToCompile)
;
+ MaybeModulesToRecompile = all_modules,
SubModuleListToCompile = SubModuleList0
),
assoc_list.keys(SubModuleList0, NestedSubModules0),
@@ -1411,7 +1413,13 @@
TimestampSuffix = ".java_date"
;
CompilationTarget = target_asm,
- TimestampSuffix = (Pic = yes -> ".pic_s_date" ; ".s_date")
+ (
+ Pic = yes,
+ TimestampSuffix = ".pic_s_date"
+ ;
+ Pic = no,
+ TimestampSuffix = ".s_date"
+ )
;
CompilationTarget = target_x86_64,
TimestampSuffix = ".s_date"
@@ -2175,40 +2183,41 @@
globals.lookup_bool_option(Globals, typecheck_only, TypecheckOnly),
(
TypecheckOnly = yes
- ->
- true
;
- ( FoundTypeError = yes
- ; FoundPostTypecheckError = yes
- )
- ->
- % XXX It would be nice if we could go on and mode-check the
- % predicates which didn't have type errors, but we need to run
- % polymorphism before running mode analysis, and currently
- % polymorphism may get internal errors if any of the predicates
- % are not type-correct.
-
- !:FoundError = yes
- ;
- % Only write out the `.opt' file if there are no errors.
+ TypecheckOnly = no,
(
- !.FoundError = no,
- FoundUndefModeError = no
+ ( FoundTypeError = yes
+ ; FoundPostTypecheckError = yes
+ )
->
- maybe_write_optfile(MakeOptInt, !HLDS, !DumpInfo, !IO)
- ;
- true
- ),
- % If our job was to write out the `.opt' file, then we're done.
- (
- MakeOptInt = yes
+ % XXX It would be nice if we could go on and mode-check the
+ % predicates which didn't have type errors, but we need to run
+ % polymorphism before running mode analysis, and currently
+ % polymorphism may get internal errors if any of the predicates
+ % are not type-correct.
+
+ !:FoundError = yes
;
- MakeOptInt = no,
- % Now go ahead and do the rest of mode checking
- % and determinism analysis.
- frontend_pass_by_phases(!HLDS,
- FoundModeOrDetError, !DumpInfo, !IO),
- !:FoundError = !.FoundError `or` FoundModeOrDetError
+ % Only write out the `.opt' file if there are no errors.
+ (
+ !.FoundError = no,
+ FoundUndefModeError = no
+ ->
+ maybe_write_optfile(MakeOptInt, !HLDS, !DumpInfo, !IO)
+ ;
+ true
+ ),
+ % If our job was to write out the `.opt' file, then we're done.
+ (
+ MakeOptInt = yes
+ ;
+ MakeOptInt = no,
+ % Now go ahead and do the rest of mode checking
+ % and determinism analysis.
+ frontend_pass_by_phases(!HLDS,
+ FoundModeOrDetError, !DumpInfo, !IO),
+ !:FoundError = !.FoundError `or` FoundModeOrDetError
+ )
)
)
).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.321
diff -u -r1.321 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 16 Nov 2007 03:44:52 -0000 1.321
+++ compiler/mercury_to_mercury.m 22 Nov 2007 01:33:12 -0000
@@ -1164,9 +1164,14 @@
mercury_format_tabs(Indent, !U),
(
GroundInstInfo = higher_order(pred_inst_info(PredOrFunc, Modes, Det)),
- ( Uniq = shared ->
- true
+ (
+ Uniq = shared
;
+ ( Uniq = unique
+ ; Uniq = mostly_unique
+ ; Uniq = clobbered
+ ; Uniq = mostly_clobbered
+ ),
add_string("/* ", !U),
mercury_format_uniqueness(Uniq, "ground", !U),
add_string(" */", !U)
@@ -1254,9 +1259,14 @@
mercury_format_inst(ground(Uniq, GroundInstInfo), InstInfo, !U) :-
(
GroundInstInfo = higher_order(pred_inst_info(PredOrFunc, Modes, Det)),
- ( Uniq = shared ->
- true
+ (
+ Uniq = shared
;
+ ( Uniq = unique
+ ; Uniq = mostly_unique
+ ; Uniq = clobbered
+ ; Uniq = mostly_clobbered
+ ),
add_string("/* ", !U),
mercury_format_uniqueness(Uniq, "ground", !U),
add_string(" */", !U)
@@ -3905,15 +3915,17 @@
),
add_string(")", !U)
;
- Args = [Y | Ys]
- ->
- mercury_format_constant(Functor, NextToGraphicToken, !U),
- add_string("(", !U),
- mercury_format_term(VarSet, AppendVarnums, Y, !U),
- mercury_format_remaining_terms(VarSet, AppendVarnums, Ys, !U),
- add_string(")", !U)
- ;
- mercury_format_bracketed_constant(Functor, NextToGraphicToken, !U)
+ (
+ Args = [Y | Ys],
+ mercury_format_constant(Functor, NextToGraphicToken, !U),
+ add_string("(", !U),
+ mercury_format_term(VarSet, AppendVarnums, Y, !U),
+ mercury_format_remaining_terms(VarSet, AppendVarnums, Ys, !U),
+ add_string(")", !U)
+ ;
+ Args = [],
+ mercury_format_bracketed_constant(Functor, NextToGraphicToken, !U)
+ )
).
:- pred mercury_format_list_args(varset(T)::in, bool::in, term(T)::in,
@@ -4518,12 +4530,13 @@
;
MaybeTerminationInfo = yes(can_loop(Error)),
io.write_string("can_loop", !IO),
- ( Verbose = yes ->
+ (
+ Verbose = yes,
io.write_string("(", !IO),
io.write(Error, !IO),
io.write_string(")", !IO)
;
- true
+ Verbose = no
)
).
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.79
diff -u -r1.79 ml_call_gen.m
--- compiler/ml_call_gen.m 29 Aug 2007 02:53:12 -0000 1.79
+++ compiler/ml_call_gen.m 22 Nov 2007 00:38:48 -0000
@@ -619,8 +619,8 @@
ml_gen_arg_list(VarNames, VarLvals, CallerTypes, CalleeTypes, Modes,
PredOrFunc, CodeModel, Context, ForClosureWrapper, ArgNum,
- InputRvals, OutputLvals, OutputTypes, ConvDecls, ConvOutputStatements,
- !Info) :-
+ !:InputRvals, !:OutputLvals, !:OutputTypes, !:ConvDecls,
+ !:ConvOutputStatements, !Info) :-
(
VarNames = [],
VarLvals = [],
@@ -628,91 +628,82 @@
CalleeTypes = [],
Modes = []
->
- InputRvals = [],
- OutputLvals = [],
- OutputTypes = [],
- ConvDecls = [],
- ConvOutputStatements = []
- ;
- VarNames = [VarName | VarNames1],
- VarLvals = [VarLval | VarLvals1],
- CallerTypes = [CallerType | CallerTypes1],
- CalleeTypes = [CalleeType | CalleeTypes1],
- Modes = [Mode | Modes1]
+ !:InputRvals = [],
+ !:OutputLvals = [],
+ !:OutputTypes = [],
+ !:ConvDecls = [],
+ !:ConvOutputStatements = []
+ ;
+ VarNames = [VarName | VarNamesTail],
+ VarLvals = [VarLval | VarLvalsTail],
+ CallerTypes = [CallerType | CallerTypesTail],
+ CalleeTypes = [CalleeType | CalleeTypesTail],
+ Modes = [Mode | ModesTail]
->
- ml_gen_arg_list(VarNames1, VarLvals1, CallerTypes1, CalleeTypes1,
- Modes1, PredOrFunc, CodeModel, Context, ForClosureWrapper,
- ArgNum + 1, InputRvals1, OutputLvals1, OutputTypes1,
- ConvDecls1, ConvOutputStatements1, !Info),
+ ml_gen_arg_list(VarNamesTail, VarLvalsTail, CallerTypesTail,
+ CalleeTypesTail, ModesTail, PredOrFunc, CodeModel, Context,
+ ForClosureWrapper, ArgNum + 1, !:InputRvals, !:OutputLvals,
+ !:OutputTypes, !:ConvDecls, !:ConvOutputStatements, !Info),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
mode_to_arg_mode(ModuleInfo, Mode, CalleeType, ArgMode),
- (
- ( is_dummy_argument_type(ModuleInfo, CalleeType)
- ; ArgMode = top_unused
- )
- ->
+ ( is_dummy_argument_type(ModuleInfo, CalleeType) ->
% Exclude arguments of type io.state etc.
- % Also exclude those with arg_mode `top_unused'.
- InputRvals = InputRvals1,
- OutputLvals = OutputLvals1,
- OutputTypes = OutputTypes1,
- ConvDecls = ConvDecls1,
- ConvOutputStatements = ConvOutputStatements1
+ true
;
- ArgMode = top_in
- ->
- % It's an input argument.
- ( is_dummy_argument_type(ModuleInfo, CallerType) ->
- % The variable may not have been declared, so we need to
- % generate a dummy value for it. Using `0' here is more
- % efficient than using private_builtin.dummy_var, which is
- % what ml_gen_var will have generated for this variable.
- VarRval = const(mlconst_int(0))
+ (
+ ArgMode = top_unused
+ % Also exclude those with arg_mode `top_unused'.
;
- VarRval = lval(VarLval)
- ),
- ml_gen_box_or_unbox_rval(CallerType, CalleeType,
- native_if_possible, VarRval, ArgRval, !Info),
- InputRvals = [ArgRval | InputRvals1],
- OutputLvals = OutputLvals1,
- OutputTypes = OutputTypes1,
- ConvDecls = ConvDecls1,
- ConvOutputStatements = ConvOutputStatements1
- ;
- % It's an output argument.
- ml_gen_box_or_unbox_lval(CallerType, CalleeType,
- native_if_possible, VarLval, VarName, Context,
- ForClosureWrapper, ArgNum, ArgLval, ThisArgConvDecls,
- _ThisArgConvInput, ThisArgConvOutput, !Info),
- ConvDecls = ThisArgConvDecls ++ ConvDecls1,
- ConvOutputStatements = ThisArgConvOutput ++ ConvOutputStatements1,
+ ArgMode = top_in,
+ % It's an input argument.
+ ( is_dummy_argument_type(ModuleInfo, CallerType) ->
+ % The variable may not have been declared, so we need to
+ % generate a dummy value for it. Using `0' here is more
+ % efficient than using private_builtin.dummy_var, which is
+ % what ml_gen_var will have generated for this variable.
+ VarRval = const(mlconst_int(0))
+ ;
+ VarRval = lval(VarLval)
+ ),
+ ml_gen_box_or_unbox_rval(CallerType, CalleeType,
+ native_if_possible, VarRval, ArgRval, !Info),
+ !:InputRvals = [ArgRval | !.InputRvals]
+ ;
+ ArgMode = top_out,
+ % It's an output argument.
+ ml_gen_box_or_unbox_lval(CallerType, CalleeType,
+ native_if_possible, VarLval, VarName, Context,
+ ForClosureWrapper, ArgNum, ArgLval, ThisArgConvDecls,
+ _ThisArgConvInput, ThisArgConvOutput, !Info),
+ !:ConvDecls = ThisArgConvDecls ++ !.ConvDecls,
+ !:ConvOutputStatements = ThisArgConvOutput ++
+ !.ConvOutputStatements,
- ml_gen_info_get_globals(!.Info, Globals),
- CopyOut = get_copy_out_option(Globals, CodeModel),
- (
+ ml_gen_info_get_globals(!.Info, Globals),
+ CopyOut = get_copy_out_option(Globals, CodeModel),
(
- % If the target language allows multiple return values,
- % then use them.
- CopyOut = yes
+ (
+ % If the target language allows multiple return values,
+ % then use them.
+ CopyOut = yes
+ ;
+ % If this is the result argument of a model_det
+ % function, and it has an output mode, then return it
+ % as a value.
+ VarNamesTail = [],
+ CodeModel = model_det,
+ PredOrFunc = pf_function,
+ ArgMode = top_out
+ )
+ ->
+ !:OutputLvals = [ArgLval | !.OutputLvals],
+ ml_gen_type(!.Info, CalleeType, OutputType),
+ !:OutputTypes = [OutputType | !.OutputTypes]
;
- % If this is the result argument of a model_det function,
- % and it has an output mode, then return it as a value.
- VarNames1 = [],
- CodeModel = model_det,
- PredOrFunc = pf_function,
- ArgMode = top_out
+ % Otherwise use the traditional C style of passing the
+ % address of the output value.
+ !:InputRvals = [ml_gen_mem_addr(ArgLval) | !.InputRvals]
)
- ->
- InputRvals = InputRvals1,
- OutputLvals = [ArgLval | OutputLvals1],
- ml_gen_type(!.Info, CalleeType, OutputType),
- OutputTypes = [OutputType | OutputTypes1]
- ;
- % Otherwise use the traditional C style of passing the address
- % of the output value.
- InputRvals = [ml_gen_mem_addr(ArgLval) | InputRvals1],
- OutputLvals = OutputLvals1,
- OutputTypes = OutputTypes1
)
)
;
@@ -732,72 +723,75 @@
!Info) :-
% Convert VarRval, of type SourceType, to ArgRval, of type DestType.
(
- BoxPolicy = always_boxed
- ->
+ BoxPolicy = always_boxed,
ArgRval = VarRval
;
- % If converting from polymorphic type to concrete type, then unbox.
- SourceType = type_variable(_, _),
- DestType \= type_variable(_, _)
- ->
- ml_gen_type(!.Info, DestType, MLDS_DestType),
- ArgRval = unop(unbox(MLDS_DestType), VarRval)
- ;
- % If converting from concrete type to polymorphic type, then box.
- SourceType \= type_variable(_, _),
- DestType = type_variable(_, _)
- ->
- ml_gen_type(!.Info, SourceType, MLDS_SourceType),
- ArgRval = unop(box(MLDS_SourceType), VarRval)
- ;
- % If converting to float, cast to mlds_generic_type and then unbox.
- DestType = builtin_type(builtin_type_float),
- SourceType \= builtin_type(builtin_type_float)
- ->
- ml_gen_type(!.Info, DestType, MLDS_DestType),
- ArgRval = unop(unbox(MLDS_DestType),
- unop(cast(mlds_generic_type), VarRval))
- ;
- % If converting from float, box and then cast the result.
- SourceType = builtin_type(builtin_type_float),
- DestType \= builtin_type(builtin_type_float)
- ->
- ml_gen_type(!.Info, SourceType, MLDS_SourceType),
- ml_gen_type(!.Info, DestType, MLDS_DestType),
- ArgRval = unop(cast(MLDS_DestType),
- unop(box(MLDS_SourceType), VarRval))
- ;
- % If converting from an array(T) to array(X) where X is a concrete
- % instance, we should insert a cast to the concrete instance.
- % Also when converting to array(T) from array(X) we should cast
- % to array(T).
- type_to_ctor_and_args(SourceType, SourceTypeCtor, SourceTypeArgs),
- type_to_ctor_and_args(DestType, DestTypeCtor, DestTypeArgs),
+ BoxPolicy = native_if_possible,
(
- type_ctor_is_array(SourceTypeCtor),
- SourceTypeArgs = [type_variable(_, _)]
+ % If converting from polymorphic type to concrete type, then unbox.
+ SourceType = type_variable(_, _),
+ DestType \= type_variable(_, _)
+ ->
+ ml_gen_type(!.Info, DestType, MLDS_DestType),
+ ArgRval = unop(unbox(MLDS_DestType), VarRval)
;
- type_ctor_is_array(DestTypeCtor),
- DestTypeArgs = [type_variable(_, _)]
- ),
- % Don't insert redundant casts if the types are the same, since
- % the extra assignments introduced can inhibit tail call optimisation.
- SourceType \= DestType
- ->
- ml_gen_type(!.Info, DestType, MLDS_DestType),
- ArgRval = unop(cast(MLDS_DestType), VarRval)
- ;
- % If converting from one concrete type to a different one, then cast.
- % This is needed to handle construction/deconstruction unifications
- % for no_tag types.
- %
- \+ type_unify(SourceType, DestType, [], map.init, _)
- ->
- ml_gen_type(!.Info, DestType, MLDS_DestType),
- ArgRval = unop(cast(MLDS_DestType), VarRval)
- ;
- % Otherwise leave unchanged.
- ArgRval = VarRval
+ % If converting from concrete type to polymorphic type, then box.
+ SourceType \= type_variable(_, _),
+ DestType = type_variable(_, _)
+ ->
+ ml_gen_type(!.Info, SourceType, MLDS_SourceType),
+ ArgRval = unop(box(MLDS_SourceType), VarRval)
+ ;
+ % If converting to float, cast to mlds_generic_type and then unbox.
+ DestType = builtin_type(builtin_type_float),
+ SourceType \= builtin_type(builtin_type_float)
+ ->
+ ml_gen_type(!.Info, DestType, MLDS_DestType),
+ ArgRval = unop(unbox(MLDS_DestType),
+ unop(cast(mlds_generic_type), VarRval))
+ ;
+ % If converting from float, box and then cast the result.
+ SourceType = builtin_type(builtin_type_float),
+ DestType \= builtin_type(builtin_type_float)
+ ->
+ ml_gen_type(!.Info, SourceType, MLDS_SourceType),
+ ml_gen_type(!.Info, DestType, MLDS_DestType),
+ ArgRval = unop(cast(MLDS_DestType),
+ unop(box(MLDS_SourceType), VarRval))
+ ;
+ % If converting from an array(T) to array(X) where X is a concrete
+ % instance, we should insert a cast to the concrete instance.
+ % Also when converting to array(T) from array(X) we should cast
+ % to array(T).
+ type_to_ctor_and_args(SourceType, SourceTypeCtor, SourceTypeArgs),
+ type_to_ctor_and_args(DestType, DestTypeCtor, DestTypeArgs),
+ (
+ type_ctor_is_array(SourceTypeCtor),
+ SourceTypeArgs = [type_variable(_, _)]
+ ;
+ type_ctor_is_array(DestTypeCtor),
+ DestTypeArgs = [type_variable(_, _)]
+ ),
+ % Don't insert redundant casts if the types are the same, since
+ % the extra assignments introduced can inhibit tail call
+ % optimisation.
+ SourceType \= DestType
+ ->
+ ml_gen_type(!.Info, DestType, MLDS_DestType),
+ ArgRval = unop(cast(MLDS_DestType), VarRval)
+ ;
+ % If converting from one concrete type to a different one, then
+ % cast. This is needed to handle construction/deconstruction
+ % unifications for no_tag types.
+ %
+ \+ type_unify(SourceType, DestType, [], map.init, _)
+ ->
+ ml_gen_type(!.Info, DestType, MLDS_DestType),
+ ArgRval = unop(cast(MLDS_DestType), VarRval)
+ ;
+ % Otherwise leave unchanged.
+ ArgRval = VarRval
+ )
).
ml_gen_box_or_unbox_lval(CallerType, CalleeType, BoxPolicy, VarLval, VarName,
@@ -971,8 +965,8 @@
ml_gen_simple_expr(float_const(Float)) = const(mlconst_float(Float)).
ml_gen_simple_expr(unary(Op, Expr)) =
unop(std_unop(Op), ml_gen_simple_expr(Expr)).
-ml_gen_simple_expr(binary(Op, Expr1, Expr2)) =
- binop(Op, ml_gen_simple_expr(Expr1), ml_gen_simple_expr(Expr2)).
+ml_gen_simple_expr(binary(Op, ExprA, ExprB)) =
+ binop(Op, ml_gen_simple_expr(ExprA), ml_gen_simple_expr(ExprB)).
%-----------------------------------------------------------------------------%
Index: compiler/ml_closure_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_closure_gen.m,v
retrieving revision 1.53
diff -u -r1.53 ml_closure_gen.m
--- compiler/ml_closure_gen.m 21 Aug 2007 17:40:31 -0000 1.53
+++ compiler/ml_closure_gen.m 22 Nov 2007 01:07:36 -0000
@@ -717,11 +717,15 @@
% assignment to `closure_arg' and some unbox operations).
WrapperArgs1 = list.map(arg_delete_gc_statement, WrapperArgs0),
- % then insert the `closure_arg' parameter, if needed.
- ( ClosureKind = special_pred ->
+ % Then insert the `closure_arg' parameter, if needed.
+ (
+ ClosureKind = special_pred,
MaybeClosureA = no,
WrapperArgs = WrapperArgs1
;
+ ( ClosureKind = higher_order_proc_closure
+ ; ClosureKind = typeclass_info_closure
+ ),
ClosureArgType = mlds_generic_type,
ClosureArgName = mlds_var_name("closure_arg", no),
ClosureArgDeclType = list.det_head(ml_make_boxed_types(1)),
@@ -786,7 +790,12 @@
% If the wrapper function is model_non, then set up the initial success
% continuation; this is needed by ml_gen_call which we call below.
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_det
+ ;
+ CodeModel = model_semi
+ ;
+ CodeModel = model_non,
globals.lookup_bool_option(Globals, nondet_copy_out, NondetCopyOut),
(
NondetCopyOut = yes,
@@ -804,8 +813,6 @@
ml_initial_cont(!.Info, [], [], InitialCont)
),
ml_gen_info_push_success_cont(InitialCont, !Info)
- ;
- true
),
% Generate code to call the function:
@@ -859,11 +866,15 @@
),
% For semidet code, add the declaration `MR_bool succeeded;'.
- ( CodeModel = model_semi ->
+ (
+ ( CodeModel = model_det
+ ; CodeModel = model_non
+ ),
+ Decls2 = Decls1
+ ;
+ CodeModel = model_semi,
SucceededVarDecl = ml_gen_succeeded_var_decl(MLDS_Context),
Decls2 = [SucceededVarDecl | Decls1]
- ;
- Decls2 = Decls1
),
% Add an appropriate `return' statement.
@@ -890,10 +901,13 @@
% If the wrapper function was model_non, then pop the success continuation
% that we pushed.
- ( CodeModel = model_non ->
- ml_gen_info_pop_success_cont(!Info)
+ (
+ CodeModel = model_det
;
- true
+ CodeModel = model_semi
+ ;
+ CodeModel = model_non,
+ ml_gen_info_pop_success_cont(!Info)
),
% Put it all together.
@@ -989,21 +1003,25 @@
CopyOutLvals = [],
Defns = []
;
- Names = [Name | Names1],
- Types = [Type | Types1],
- Modes = [Mode | Modes1]
+ Names = [Name | NamesTail],
+ Types = [Type | TypesTail],
+ Modes = [Mode | ModesTail]
->
- ml_gen_wrapper_arg_lvals(Names1, Types1, Modes1, PredOrFunc, CodeModel,
- Context, ArgNum + 1, Defns1, Lvals1, CopyOutLvals1, !Info),
+ ml_gen_wrapper_arg_lvals(NamesTail, TypesTail, ModesTail, PredOrFunc,
+ CodeModel, Context, ArgNum + 1, DefnsTail, LvalsTail,
+ CopyOutLvalsTail, !Info),
ml_gen_type(!.Info, Type, MLDS_Type),
ml_gen_var_lval(!.Info, Name, MLDS_Type, VarLval),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
( ArgMode = top_in ->
Lval = VarLval,
- CopyOutLvals = CopyOutLvals1,
- Defns = Defns1
+ CopyOutLvals = CopyOutLvalsTail,
+ Defns = DefnsTail
;
+ % ( ArgMode = top_out
+ % ; ArgMode = top_unused
+ % ),
% Handle output variables.
ml_gen_info_get_globals(!.Info, Globals),
CopyOut = get_copy_out_option(Globals, CodeModel),
@@ -1016,7 +1034,7 @@
PredOrFunc = pf_function,
CodeModel = model_det,
ArgMode = top_out,
- Types1 = [],
+ TypesTail = [],
\+ type_util.is_dummy_argument_type(ModuleInfo, Type)
)
->
@@ -1024,23 +1042,23 @@
% a local declaration for them here.
Lval = VarLval,
( is_dummy_argument_type(ModuleInfo, Type) ->
- CopyOutLvals = CopyOutLvals1,
- Defns = Defns1
+ CopyOutLvals = CopyOutLvalsTail,
+ Defns = DefnsTail
;
- CopyOutLvals = [Lval | CopyOutLvals1],
+ CopyOutLvals = [Lval | CopyOutLvalsTail],
ml_gen_local_for_output_arg(Name, Type,
ArgNum, Context, Defn, !Info),
- Defns = [Defn | Defns1]
+ Defns = [Defn | DefnsTail]
)
;
% Output arguments are passed by reference, so we need to
% dereference them.
Lval = mem_ref(lval(VarLval), MLDS_Type),
- CopyOutLvals = CopyOutLvals1,
- Defns = Defns1
+ CopyOutLvals = CopyOutLvalsTail,
+ Defns = DefnsTail
)
),
- Lvals = [Lval | Lvals1]
+ Lvals = [Lval | LvalsTail]
;
sorry(this_file, "ml_gen_wrapper_arg_lvals: length mismatch")
).
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.206
diff -u -r1.206 ml_code_gen.m
--- compiler/ml_code_gen.m 19 Nov 2007 06:36:24 -0000 1.206
+++ compiler/ml_code_gen.m 22 Nov 2007 00:54:37 -0000
@@ -1362,11 +1362,15 @@
% Also figure out which output variables are returned by value
% (rather than being passed by reference) and remove them from
% the byref_output_vars field in the ml_gen_info.
- ( CodeModel = model_non ->
+ (
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
+ ml_det_copy_out_vars(ModuleInfo, CopiedOutputVars, !Info)
+ ;
+ CodeModel = model_non,
ml_set_up_initial_succ_cont(ModuleInfo, CopiedOutputVars,
!Info)
- ;
- ml_det_copy_out_vars(ModuleInfo, CopiedOutputVars, !Info)
),
% This would generate all the local variables at the top of
@@ -1431,23 +1435,26 @@
(
% If --det-copy-out is enabled, all output variables are returned
% by value, rather than passing them by reference.
- DetCopyOut = yes
- ->
+ DetCopyOut = yes,
ByRefOutputVars = [],
CopiedOutputVars = OutputVars
;
- % For det functions, the function result variable is returned by value,
- % and any remaining output variables are passed by reference.
- ml_gen_info_get_pred_id(!.Info, PredId),
- ml_gen_info_get_proc_id(!.Info, ProcId),
- ml_is_output_det_function(ModuleInfo, PredId, ProcId, ResultVar)
- ->
- CopiedOutputVars = [ResultVar],
- list.delete_all(OutputVars, ResultVar, ByRefOutputVars)
- ;
- % Otherwise, all output vars are passed by reference.
- CopiedOutputVars = [],
- ByRefOutputVars = OutputVars
+ DetCopyOut = no,
+ (
+ % For det functions, the function result variable is returned by
+ % value, and any remaining output variables are passed by
+ % reference.
+ ml_gen_info_get_pred_id(!.Info, PredId),
+ ml_gen_info_get_proc_id(!.Info, ProcId),
+ ml_is_output_det_function(ModuleInfo, PredId, ProcId, ResultVar)
+ ->
+ CopiedOutputVars = [ResultVar],
+ list.delete_all(OutputVars, ResultVar, ByRefOutputVars)
+ ;
+ % Otherwise, all output vars are passed by reference.
+ CopiedOutputVars = [],
+ ByRefOutputVars = OutputVars
+ )
),
ml_gen_info_set_byref_output_vars(ByRefOutputVars, !Info),
ml_gen_info_set_value_output_vars(CopiedOutputVars, !Info).
@@ -1595,16 +1602,16 @@
InputStatements = [],
OutputStatements = []
;
- Vars = [Var | Vars1],
- HeadTypes = [HeadType | HeadTypes1],
- ArgModes = [ArgMode | ArgModes1]
+ Vars = [Var | VarsTail],
+ HeadTypes = [HeadType | HeadTypesTail],
+ ArgModes = [ArgMode | ArgModesTail]
->
ml_variable_type(!.Info, Var, BodyType),
(
% Arguments with mode `top_unused' do not need to be converted.
ArgMode = top_unused
->
- ml_gen_convert_headvars(Vars1, HeadTypes1, ArgModes1,
+ ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
CopiedOutputVars, Context, Decls,
InputStatements, OutputStatements, !Info)
;
@@ -1614,7 +1621,7 @@
type_unify(HeadType, BodyType, [], Subst0, Subst),
map.is_empty(Subst)
->
- ml_gen_convert_headvars(Vars1, HeadTypes1, ArgModes1,
+ ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
CopiedOutputVars, Context, Decls,
InputStatements, OutputStatements, !Info)
;
@@ -1634,9 +1641,9 @@
% HeadVarLval (which has type HeadType).
ml_gen_info_set_var_lval(Var, BodyLval, !Info),
- ml_gen_convert_headvars(Vars1, HeadTypes1, ArgModes1,
- CopiedOutputVars, Context, Decls1,
- InputStatements1, OutputStatements1, !Info),
+ ml_gen_convert_headvars(VarsTail, HeadTypesTail, ArgModesTail,
+ CopiedOutputVars, Context, DeclsTail,
+ InputStatementsTail, OutputStatementsTail, !Info),
% Add the code to convert this input or output.
ml_gen_info_get_byref_output_vars(!.Info, ByRefOutputVars),
@@ -1645,13 +1652,13 @@
; list.member(Var, CopiedOutputVars)
)
->
- InputStatements = InputStatements1,
- OutputStatements = OutputStatements1 ++ ConvOutputStatements
+ InputStatements = InputStatementsTail,
+ OutputStatements = OutputStatementsTail ++ ConvOutputStatements
;
- InputStatements = ConvInputStatements ++ InputStatements1,
- OutputStatements = OutputStatements1
+ InputStatements = ConvInputStatements ++ InputStatementsTail,
+ OutputStatements = OutputStatementsTail
),
- Decls = ConvDecls ++ Decls1
+ Decls = ConvDecls ++ DeclsTail
)
;
unexpected(this_file, "ml_gen_convert_headvars: length mismatch")
@@ -2192,7 +2199,8 @@
ml_gen_goal_expr(plain_call(PredId, ProcId, ArgVars, BuiltinState, _, _),
CodeModel, Context, Decls, Statements, !Info) :-
- ( BuiltinState = not_builtin ->
+ (
+ BuiltinState = not_builtin,
ml_gen_var_list(!.Info, ArgVars, ArgLvals),
ml_gen_info_get_varset(!.Info, VarSet),
ArgNames = ml_gen_var_names(VarSet, ArgVars),
@@ -2200,6 +2208,9 @@
ml_gen_call(PredId, ProcId, ArgNames, ArgLvals, ActualArgTypes,
CodeModel, Context, no, Decls, Statements, !Info)
;
+ ( BuiltinState = inline_builtin
+ ; BuiltinState = out_of_line_builtin
+ ),
ml_gen_builtin(PredId, ProcId, ArgVars, CodeModel, Context,
Decls, Statements, !Info)
).
@@ -2400,7 +2411,8 @@
ml_gen_info_get_module_info(!.Info, ModuleInfo),
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
% For IL code, we can't call continutations because there is no syntax
% for calling managed function pointers in C#. Instead we have
@@ -2427,6 +2439,9 @@
"ml_gen_nondet_pragma_foreign_proc: target erlang")
)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
unexpected(this_file,
"ml_gen_nondet_pragma_foreign_proc: unexpected code model")
),
@@ -2518,9 +2533,14 @@
_PredInfo, ProcInfo),
proc_info_interface_determinism(ProcInfo, Detism),
determinism_components(Detism, _, MaxSoln),
- ( MaxSoln = at_most_zero ->
+ (
+ MaxSoln = at_most_zero,
OrdinaryKind = kind_failure
;
+ ( MaxSoln = at_most_one
+ ; MaxSoln = at_most_many
+ ; MaxSoln = at_most_many_cc
+ ),
OrdinaryKind = kind_semi
)
;
@@ -3252,10 +3272,13 @@
% `MR_Box' in the MLDS back-end.
( OrigType = type_variable(_, _) ->
Cast = "(MR_Word) "
- ; MaybeCast = yes(CastPrime) ->
- Cast = CastPrime
;
- Cast = ""
+ (
+ MaybeCast = yes(Cast)
+ ;
+ MaybeCast = no,
+ Cast = ""
+ )
)
),
string.format("\t%s = %s ", [s(ArgName), s(Cast)], AssignToArgName),
@@ -3705,7 +3728,8 @@
ml_gen_disj([First | Rest], CodeModel, Context, Decls, Statements, !Info) :-
Rest = [_ | _],
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
% model_non disj:
%
% <(Goal ; Goals) && SUCCEED()>
@@ -3727,6 +3751,9 @@
)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
% model_det/model_semi disj:
%
% model_det goal:
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.128
diff -u -r1.128 ml_code_util.m
--- compiler/ml_code_util.m 21 Aug 2007 17:40:31 -0000 1.128
+++ compiler/ml_code_util.m 22 Nov 2007 00:51:23 -0000
@@ -777,8 +777,7 @@
ml_append_return_statement(Info, CodeModel, CopiedOutputVarLvals, Context,
!Statements) :-
(
- CodeModel = model_semi
- ->
+ CodeModel = model_semi,
ml_gen_test_success(Info, Succeeded),
CopiedOutputVarRvals = list.map(func(Lval) = lval(Lval),
CopiedOutputVarLvals),
@@ -787,17 +786,20 @@
mlds_make_context(Context)),
!:Statements = !.Statements ++ [ReturnStatement]
;
- CodeModel \= model_non,
- CopiedOutputVarLvals = [_ | _]
- ->
- CopiedOutputVarRvals = list.map(func(Lval) = lval(Lval),
- CopiedOutputVarLvals),
- ReturnStmt = ml_stmt_return(CopiedOutputVarRvals),
- ReturnStatement = statement(ReturnStmt,
- mlds_make_context(Context)),
- !:Statements = !.Statements ++ [ReturnStatement]
+ CodeModel = model_det,
+ (
+ CopiedOutputVarLvals = [_ | _],
+ CopiedOutputVarRvals = list.map(func(Lval) = lval(Lval),
+ CopiedOutputVarLvals),
+ ReturnStmt = ml_stmt_return(CopiedOutputVarRvals),
+ ReturnStatement = statement(ReturnStmt,
+ mlds_make_context(Context)),
+ !:Statements = !.Statements ++ [ReturnStatement]
+ ;
+ CopiedOutputVarLvals = []
+ )
;
- true
+ CodeModel = model_non
).
ml_gen_block(VarDecls, Statements, Context) =
@@ -1216,9 +1218,13 @@
ml_gen_arg_decl(ModuleInfo, Var, Type, ArgMode, FuncArg, !MaybeInfo) :-
MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
- ( ArgMode = top_in ->
+ (
+ ArgMode = top_in,
MLDS_ArgType = MLDS_Type
;
+ ( ArgMode = top_out
+ ; ArgMode = top_unused
+ ),
MLDS_ArgType = mlds_ptr_type(MLDS_Type)
),
Name = entity_data(var(Var)),
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.95
diff -u -r1.95 ml_elim_nested.m
--- compiler/ml_elim_nested.m 31 Aug 2007 05:59:22 -0000 1.95
+++ compiler/ml_elim_nested.m 22 Nov 2007 00:52:42 -0000
@@ -598,11 +598,13 @@
%
% Add unlink statements before any explicit returns or tail
% calls.
- ( Action = chain_gc_stack_frames ->
+ (
+ Action = hoist_nested_funcs,
+ FuncBody2 = FuncBody1
+ ;
+ Action = chain_gc_stack_frames,
add_unchain_stack_to_statement(FuncBody1, FuncBody2,
ElimInfo, _ElimInfo)
- ;
- FuncBody2 = FuncBody1
),
% Add a final unlink statement at the end of the function,
% if needed. This is only needed if the function has no
@@ -1560,16 +1562,19 @@
% rather than as local / per_instance,
% if we're about to hoist it out to the top level.
Action = !.Info ^ action,
- ( Action = hoist_nested_funcs ->
+ (
+ Action = hoist_nested_funcs,
Flags1 = set_access(Flags0, private),
Flags = set_per_instance(Flags1, one_copy)
;
+ Action = chain_gc_stack_frames,
Flags = Flags0
),
DefnBody = mlds_function(PredProcId, Params, FuncBody, Attributes,
EnvVarNames),
Defn = mlds_defn(Name, Context, Flags, DefnBody),
- ( Action = hoist_nested_funcs ->
+ (
+ Action = hoist_nested_funcs,
% Note that we assume that we can safely hoist stuff inside nested
% functions into the containing function. If that wasn't the case,
% we'd need code something like this:
@@ -1585,6 +1590,7 @@
elim_info_add_nested_func(Defn, !Info),
Defns = []
;
+ Action = chain_gc_stack_frames,
Defns = [Defn]
),
InitStatements = []
Index: compiler/ml_simplify_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_simplify_switch.m,v
retrieving revision 1.23
diff -u -r1.23 ml_simplify_switch.m
--- compiler/ml_simplify_switch.m 21 Aug 2007 17:40:32 -0000 1.23
+++ compiler/ml_simplify_switch.m 22 Nov 2007 00:53:31 -0000
@@ -192,9 +192,13 @@
FirstVal = Min,
LastVal = Max
;
- ( Default = default_is_unreachable ->
+ (
+ Default = default_is_unreachable,
NeedRangeCheck = no
;
+ ( Default = default_do_nothing
+ ; Default = default_case(_)
+ ),
NeedRangeCheck = yes
),
find_first_and_last_case(Cases, FirstCaseVal, LastCaseVal),
Index: compiler/ml_tag_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_tag_switch.m,v
retrieving revision 1.23
diff -u -r1.23 ml_tag_switch.m
--- compiler/ml_tag_switch.m 21 Aug 2007 17:40:32 -0000 1.23
+++ compiler/ml_tag_switch.m 22 Nov 2007 01:11:17 -0000
@@ -131,17 +131,19 @@
; SecTagLocn = sectag_remote
),
(
- CanFail = cannot_fail
- ->
- CaseCanFail = cannot_fail
- ;
- list.length(GoalList, GoalCount),
- FullGoalCount = MaxSecondary + 1,
- FullGoalCount = GoalCount
- ->
+ CanFail = cannot_fail,
CaseCanFail = cannot_fail
;
- CaseCanFail = can_fail
+ CanFail = can_fail,
+ (
+ list.length(GoalList, GoalCount),
+ FullGoalCount = MaxSecondary + 1,
+ FullGoalCount = GoalCount
+ ->
+ CaseCanFail = cannot_fail
+ ;
+ CaseCanFail = can_fail
+ )
),
(
GoalList = [_Stag - stag_goal(_ConsId, Goal)],
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.71
diff -u -r1.71 ml_type_gen.m
--- compiler/ml_type_gen.m 25 Sep 2007 04:56:40 -0000 1.71
+++ compiler/ml_type_gen.m 22 Nov 2007 01:14:25 -0000
@@ -722,12 +722,19 @@
% But when targetting C, we want to omit empty base classes.
% So if targetting C, don't include any base class if there is
% no secondary tag.
- ( MaybeSecTagVal = yes(_) ->
+ (
+ MaybeSecTagVal = yes(_),
Inherits = [SecondaryTagClassId]
- ; target_uses_empty_base_classes(Target) = yes ->
- Inherits = [BaseClassId]
;
- Inherits = []
+ MaybeSecTagVal = no,
+ UsesEmptyBaseClasses = target_uses_empty_base_classes(Target),
+ (
+ UsesEmptyBaseClasses = yes,
+ Inherits = [BaseClassId]
+ ;
+ UsesEmptyBaseClasses = no,
+ Inherits = []
+ )
),
Imports = [],
Implements = [],
@@ -847,9 +854,13 @@
gen_init_field(Target, BaseClassId, ClassType, ClassQualifier, Member) =
Statement :-
Member = mlds_defn(EntityName, Context, _Flags, Defn),
- ( Defn = mlds_data(Type0, _Init, _GCStatement) ->
+ (
+ Defn = mlds_data(Type0, _Init, _GCStatement),
Type = Type0
;
+ ( Defn = mlds_function(_, _, _, _, _)
+ ; Defn = mlds_class(_)
+ ),
unexpected(this_file, "gen_init_field: non-data member")
),
(
@@ -861,9 +872,9 @@
;
unexpected(this_file, "gen_init_field: non-var member")
),
+ RequiresQualifiedParams = target_requires_module_qualified_params(Target),
(
- target_requires_module_qualified_params(Target) = yes
- ->
+ RequiresQualifiedParams = yes,
( BaseClassId = mlds_class_type(qual(ModuleName, _, _), _, _) ->
QualVarName = qual(ModuleName, module_qual, VarName)
;
@@ -871,6 +882,7 @@
"gen_init_field: invalid BaseClassId")
)
;
+ RequiresQualifiedParams = no,
QualVarName = qual(ClassQualifier, type_qual, VarName)
),
Param = lval(var(QualVarName, Type)),
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.117
diff -u -r1.117 ml_unify_gen.m
--- compiler/ml_unify_gen.m 25 Sep 2007 04:56:40 -0000 1.117
+++ compiler/ml_unify_gen.m 22 Nov 2007 01:22:44 -0000
@@ -348,13 +348,11 @@
% -- that only makes a difference when constructing, so here
% we ignore that, and just recurse on the representation for
% this constructor.
- Tag = shared_with_reserved_addresses_tag(_, ThisTag)
- ->
+ Tag = shared_with_reserved_addresses_tag(_, ThisTag),
ml_gen_static_const_arg_2(ThisTag, VarType, Var, StaticCons,
Rval, !Info)
;
- Tag = no_tag
- ->
+ Tag = no_tag,
(
ArgVars = [Arg],
StaticArgs = [StaticArg]
@@ -374,8 +372,7 @@
; Tag = single_functor_tag, TagVal = 0
; Tag = unshared_tag(TagVal)
; Tag = shared_remote_tag(TagVal, _SecondaryTag)
- )
- ->
+ ),
% If this argument is something that would normally be allocated
% on the heap, just generate a reference to the static constant
% that we must have already generated for it.
@@ -394,13 +391,28 @@
),
Rval = unop(cast(MLDS_VarType), TaggedRval)
;
- % If this argument is just a constant, then generate the rval
- % for the constant.
- StaticArgs = []
- ->
- ml_gen_constant(Tag, VarType, Rval, !Info)
- ;
- unexpected(this_file, "ml_gen_static_const_arg: unknown compound term")
+ ( Tag = string_tag(_)
+ ; Tag = int_tag(_)
+ ; Tag = float_tag(_)
+ ; Tag = shared_local_tag(_, _)
+ ; Tag = reserved_address_tag(_)
+ ; Tag = foreign_tag(_, _)
+ ; Tag = type_ctor_info_tag(_, _, _)
+ ; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = tabling_info_tag(_, _)
+ ; Tag = deep_profiling_proc_layout_tag(_, _)
+ ; Tag = table_io_decl_tag(_, _)
+ ),
+ (
+ % If this argument is just a constant, then generate the rval
+ % for the constant.
+ StaticArgs = [],
+ ml_gen_constant(Tag, VarType, Rval, !Info)
+ ;
+ StaticArgs = [_ | _],
+ unexpected(this_file,
+ "ml_gen_static_const_arg: unknown compound term")
+ )
).
% Generate the rval for a given constant.
@@ -489,7 +501,8 @@
unop(cast(MLDS_Type), const(mlconst_int(Int))).
ml_gen_reserved_address(ModuleInfo, reserved_object(TypeCtor, QualCtorName,
CtorArity), _Type) = Rval :-
- ( QualCtorName = qualified(ModuleName, CtorName) ->
+ (
+ QualCtorName = qualified(ModuleName, CtorName),
module_info_get_globals(ModuleInfo, Globals),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
TypeCtor = type_ctor(TypeName, TypeArity),
@@ -519,6 +532,7 @@
Rval = unop(cast(MLDS_Type), Rval0)
)
;
+ QualCtorName = unqualified(_),
unexpected(this_file,
"unqualified ctor name in reserved_object")
).
@@ -705,7 +719,13 @@
% Generate a local static constant for this term.
ml_gen_static_const_name(Var, ConstName, !Info),
- UsesBaseClass = (MaybeCtorName = yes(_) -> no ; yes),
+ (
+ MaybeCtorName = yes(_),
+ UsesBaseClass = no
+ ;
+ MaybeCtorName = no,
+ UsesBaseClass = yes
+ ),
ConstType = get_type_for_cons_id(MLDS_Type, UsesBaseClass,
MaybeConsId, HighLevelData, Globals),
% XXX If the secondary tag is in a base class, then ideally its
@@ -1026,21 +1046,28 @@
FieldTypes = [],
ArgRvals = []
->
- BoxConstDefns = [], FieldRvals = []
+ BoxConstDefns = [],
+ FieldRvals = []
;
- ArgTypes = [ArgType | ArgTypes1],
- FieldTypes = [FieldType | FieldTypes1],
- ArgRvals = [ArgRval | ArgRvals1]
+ ArgTypes = [ArgType | ArgTypesTail],
+ FieldTypes = [FieldType | FieldTypesTail],
+ ArgRvals = [ArgRval | ArgRvalsTail]
->
(
% Handle the case where the field type is a boxed type
% -- in that case, we can just box the argument type.
- FieldType = type_variable(_, _)
- ->
+ FieldType = type_variable(_, _),
ml_gen_type(!.Info, ArgType, MLDS_ArgType),
ml_gen_box_const_rval(MLDS_ArgType, ArgRval, Context,
BoxConstDefns0, FieldRval, !Info)
;
+ ( FieldType = defined_type(_, _, _)
+ ; FieldType = builtin_type(_)
+ ; FieldType = tuple_type(_, _)
+ ; FieldType = higher_order_type(_, _, _, _)
+ ; FieldType = apply_n_type(_, _, _)
+ ; FieldType = kinded_type(_, _)
+ ),
% Otherwise, fall back on ml_gen_box_or_unbox_rval.
% XXX This might still generate stuff which is not legal
% in a static initializer!
@@ -1048,10 +1075,10 @@
ArgRval, FieldRval, !Info),
BoxConstDefns0 = []
),
- ml_gen_box_or_unbox_const_rval_list(ArgTypes1, FieldTypes1, ArgRvals1,
- Context, BoxConstDefns1, FieldRvals1, !Info),
- BoxConstDefns = BoxConstDefns0 ++ BoxConstDefns1,
- FieldRvals = [FieldRval | FieldRvals1]
+ ml_gen_box_or_unbox_const_rval_list(ArgTypesTail, FieldTypesTail,
+ ArgRvalsTail, Context, BoxConstDefnsTail, FieldRvalsTail, !Info),
+ BoxConstDefns = BoxConstDefns0 ++ BoxConstDefnsTail,
+ FieldRvals = [FieldRval | FieldRvalsTail]
;
unexpected(this_file,
"ml_gen_box_or_unbox_const_rval_list: list length mismatch")
@@ -1508,9 +1535,7 @@
FieldId = offset(const(mlconst_int(Offset)))
;
FieldName = ml_gen_field_name(MaybeFieldName, ArgNum),
- (
- ConsId = cons(ConsName, ConsArity)
- ->
+ ( ConsId = cons(ConsName, ConsArity) ->
UnqualConsName = unqualify_name(ConsName),
FieldId = ml_gen_field_id(VarType, Tag, UnqualConsName,
ConsArity, FieldName, Globals)
@@ -1794,8 +1819,8 @@
TypeDefn = map.lookup(TypeTable, TypeCtor),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
(
- TypeDefnBody = hlds_du_type(Ctors, TagValues, _, _, _ReservedTag, _, _)
- ->
+ TypeDefnBody =
+ hlds_du_type(Ctors, TagValues, _, _, _ReservedTag, _, _),
% XXX we probably shouldn't ignore ReservedTag here
(
some [Ctor] (
@@ -1819,6 +1844,11 @@
ClassArity = TypeArity
)
;
+ ( TypeDefnBody = hlds_eqv_type(_)
+ ; TypeDefnBody = hlds_foreign_type(_)
+ ; TypeDefnBody = hlds_solver_type(_, _)
+ ; TypeDefnBody = hlds_abstract_type(_)
+ ),
unexpected(this_file, "ml_gen_hl_tag_field_id: non-du type")
),
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.226
diff -u -r1.226 mlds_to_c.m
--- compiler/mlds_to_c.m 11 Sep 2007 03:12:31 -0000 1.226
+++ compiler/mlds_to_c.m 22 Nov 2007 01:26:31 -0000
@@ -1414,12 +1414,19 @@
mlds_output_defn(Indent, Separate, ModuleName, Defn, !IO) :-
Defn = mlds_defn(Name, Context, Flags, DefnBody),
- ( DefnBody \= mlds_data(_, _, _) ->
- io.nl(!IO)
- ; Separate = yes ->
+ (
+ ( DefnBody = mlds_function(_, _, _, _, _)
+ ; DefnBody = mlds_class(_)
+ ),
io.nl(!IO)
;
- true
+ DefnBody = mlds_data(_, _, _),
+ (
+ Separate = yes,
+ io.nl(!IO)
+ ;
+ Separate = no
+ )
),
mlds_indent(Context, Indent, !IO),
mlds_output_decl_flags(Flags, definition, Name, DefnBody, !IO),
@@ -1660,12 +1667,16 @@
mlds_output_enum_constant(Indent, EnumModuleName, Defn, !IO) :-
Defn = mlds_defn(Name, Context, _Flags, DefnBody),
- ( DefnBody = mlds_data(Type, Initializer, _GCStatement) ->
+ (
+ DefnBody = mlds_data(Type, Initializer, _GCStatement),
mlds_indent(Context, Indent, !IO),
mlds_output_fully_qualified_name(
qual(EnumModuleName, type_qual, Name), !IO),
mlds_output_initializer(Type, Initializer, !IO)
;
+ ( DefnBody = mlds_function(_, _, _, _, _)
+ ; DefnBody = mlds_class(_)
+ ),
unexpected(this_file,
"mlds_output_enum_constant: constant is not data")
).
@@ -3179,7 +3190,8 @@
% For --gc accurate, we need to insert a call to GC_check()
% before every allocation.
globals.io_get_gc_method(GC_Method, !IO),
- ( GC_Method = gc_accurate ->
+ (
+ GC_Method = gc_accurate,
mlds_indent(Context, Indent + 1, !IO),
io.write_string("MR_GC_check();\n", !IO),
% For types which hold RTTI that will be traversed by the collector
@@ -3188,17 +3200,24 @@
% word of the object in the "from" space, but this can't be done for
% objects which will be referenced during the garbage collection
% process.
- ( type_needs_forwarding_pointer_space(Type) = yes ->
+ NeedsForwardingSpace = type_needs_forwarding_pointer_space(Type),
+ (
+ NeedsForwardingSpace = yes,
mlds_indent(Context, Indent + 1, !IO),
io.write_string("/* reserve space for " ++
"GC forwarding pointer*/\n", !IO),
mlds_indent(Context, Indent + 1, !IO),
io.write_string("MR_hp_alloc(1);\n", !IO)
;
- true
+ NeedsForwardingSpace = no
)
;
- true
+ ( GC_Method = gc_none
+ ; GC_Method = gc_boehm
+ ; GC_Method = gc_boehm_debug
+ ; GC_Method = gc_mps
+ ; GC_Method = gc_automatic
+ )
),
FuncInfo = func_info(FuncName, _FuncSignature),
Index: compiler/mode_debug.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_debug.m,v
retrieving revision 1.29
diff -u -r1.29 mode_debug.m
--- compiler/mode_debug.m 6 Nov 2006 07:55:10 -0000 1.29
+++ compiler/mode_debug.m 21 Nov 2007 06:39:25 -0000
@@ -70,18 +70,25 @@
mode_checkpoint_write(Verbose, Minimal, Statistics, Port, Msg, !ModeInfo,
!IO) :-
mode_info_get_errors(!.ModeInfo, Errors),
- ( Port = enter ->
+ (
+ Port = enter,
io.write_string("Enter ", !IO),
Detail = yes
- ; Port = wakeup ->
+ ;
+ Port = wakeup,
io.write_string("Wake ", !IO),
Detail = no
- ; Errors = [] ->
- io.write_string("Exit ", !IO),
- Detail = yes
;
- io.write_string("Delay ", !IO),
- Detail = no
+ Port = exit,
+ (
+ Errors = [],
+ io.write_string("Exit ", !IO),
+ Detail = yes
+ ;
+ Errors = [_ | _],
+ io.write_string("Delay ", !IO),
+ Detail = no
+ )
),
io.write_string(Msg, !IO),
(
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.120
diff -u -r1.120 mode_errors.m
--- compiler/mode_errors.m 27 Aug 2007 06:22:14 -0000 1.120
+++ compiler/mode_errors.m 21 Nov 2007 07:02:51 -0000
@@ -383,15 +383,21 @@
VerboseErrors = no,
% In the absence of --verbose-errors, report only one error.
% We prefer that this be an important error.
- ( ImportantErrors = [FirstImportantError | _] ->
+ (
+ ImportantErrors = [FirstImportantError | _],
ConjMsgs = mode_error_conjunct_to_msgs(Context, ModeInfo,
FirstImportantError)
- ; OtherErrors = [FirstOtherError | _] ->
- ConjMsgs = mode_error_conjunct_to_msgs(Context, ModeInfo,
- FirstOtherError)
;
- unexpected(this_file,
- "mode_error_conj_to_spec: no errors of any kind")
+ ImportantErrors = [],
+ (
+ OtherErrors = [FirstOtherError | _],
+ ConjMsgs = mode_error_conjunct_to_msgs(Context, ModeInfo,
+ FirstOtherError)
+ ;
+ OtherErrors = [],
+ unexpected(this_file,
+ "mode_error_conj_to_spec: no errors of any kind")
+ )
),
% MoreMsg is there to indicate that --verbose-errors would yield
% more information.
@@ -702,9 +708,13 @@
mode_info_get_context(ModeInfo, Context),
mode_info_get_varset(ModeInfo, VarSet),
mode_info_get_mode_context(ModeInfo, ModeContext),
- ( ModeContext = mode_context_call(CallId, _) ->
+ (
+ ModeContext = mode_context_call(CallId, _),
CallIdStr = hlds_out.call_id_to_string(CallId)
;
+ ( ModeContext = mode_context_unify(_, _)
+ ; ModeContext = mode_context_uninitialized
+ ),
unexpected(this_file,
"report_mode_error_no_matching_mode: invalid context")
),
@@ -1060,11 +1070,14 @@
Preamble = mode_info_context_preamble(ModeInfo),
mode_info_get_context(ModeInfo, Context),
mode_info_get_varset(ModeInfo, VarSet),
- ( Reason = too_instantiated ->
+ (
+ Reason = too_instantiated,
Problem = " became too instantiated."
- ; Reason = not_instantiated_enough ->
+ ;
+ Reason = not_instantiated_enough,
Problem = "did not get sufficiently instantiated."
;
+ Reason = wrongly_instantiated,
% I don't think this can happen. But just in case...
Problem = "had the wrong instantiatedness."
),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.199
diff -u -r1.199 mode_util.m
--- compiler/mode_util.m 7 Aug 2007 07:10:00 -0000 1.199
+++ compiler/mode_util.m 21 Nov 2007 06:44:32 -0000
@@ -1328,11 +1328,11 @@
% instmap_delta.
ModuleInfo = RI ^ module_info,
(
- Uni = deconstruct(Var, _ConsId, Vars, UniModes, _, _CanCGC)
- ->
+ Uni = deconstruct(Var, _ConsId, Vars, UniModes, _, _CanCGC),
+
% Get the final inst of the deconstructed var, which will be the same
% as in the old instmap.
- %
+
OldInstMapDelta = goal_info_get_instmap_delta(GoalInfo),
instmap.lookup_var(InstMap, Var, InitialInst),
( instmap_delta_search_var(OldInstMapDelta, Var, FinalInst1) ->
@@ -1348,7 +1348,8 @@
% change.
FinalInst = InitialInst
),
- UniModeToRhsMode = (pred(UMode::in, Mode::out) is det :-
+ UniModeToRhsMode =
+ (pred(UMode::in, Mode::out) is det :-
UMode = ((_ - Inst0) -> (_ - Inst)),
Mode = (Inst0 -> Inst)
),
@@ -1359,17 +1360,27 @@
UniMode = UniMode0
;
Uni = construct(Var, ConsId, Args, _, _, _, _),
- NonLocals = goal_info_get_nonlocals(GoalInfo),
- set.member(Var, NonLocals),
- OldInstMapDelta = goal_info_get_instmap_delta(GoalInfo),
- \+ instmap_delta_search_var(OldInstMapDelta, Var, _),
- MaybeInst = cons_id_to_shared_inst(ModuleInfo, ConsId, length(Args)),
- MaybeInst = yes(Inst)
- ->
- UniMode = UniMode0,
- instmap_delta_init_reachable(InstMapDelta0),
- instmap_delta_set(Var, Inst, InstMapDelta0, InstMapDelta)
+ (
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ set.member(Var, NonLocals),
+ OldInstMapDelta = goal_info_get_instmap_delta(GoalInfo),
+ \+ instmap_delta_search_var(OldInstMapDelta, Var, _),
+ MaybeInst = cons_id_to_shared_inst(ModuleInfo, ConsId,
+ length(Args)),
+ MaybeInst = yes(Inst)
+ ->
+ UniMode = UniMode0,
+ instmap_delta_init_reachable(InstMapDelta0),
+ instmap_delta_set(Var, Inst, InstMapDelta0, InstMapDelta)
+ ;
+ InstMapDelta = goal_info_get_instmap_delta(GoalInfo),
+ UniMode = UniMode0
+ )
;
+ ( Uni = assign(_, _)
+ ; Uni = simple_test(_, _)
+ ; Uni = complicated_unify(_, _, _)
+ ),
InstMapDelta = goal_info_get_instmap_delta(GoalInfo),
UniMode = UniMode0
).
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.81
diff -u -r1.81 modecheck_call.m
--- compiler/modecheck_call.m 31 Oct 2007 03:58:27 -0000 1.81
+++ compiler/modecheck_call.m 21 Nov 2007 07:00:15 -0000
@@ -108,13 +108,15 @@
map.lookup(Preds, PredId, PredInfo),
pred_info_get_purity(PredInfo, Purity),
pred_info_get_procedures(PredInfo, Procs),
- ( MayChangeCalledProc = may_not_change_called_proc ->
+ (
+ MayChangeCalledProc = may_not_change_called_proc,
( ProcId0 = invalid_proc_id ->
unexpected(this_file, "modecheck_call_pred: invalid proc_id")
;
ProcIds = [ProcId0]
)
;
+ MayChangeCalledProc = may_change_called_proc,
% Get the list of different possible modes for the called predicate.
ProcIds = pred_info_all_procids(PredInfo)
),
@@ -188,7 +190,8 @@
ArgVars0, TheProcId, InstVarSub, ProcArgModes),
map.lookup(Procs, TheProcId, ProcInfo),
CalleeModeErrors = ProcInfo ^ mode_errors,
- ( CalleeModeErrors = [_|_] ->
+ (
+ CalleeModeErrors = [_ | _],
% mode error in callee for this mode
ArgVars = ArgVars0,
WaitingVars = set.list_to_set(ArgVars),
@@ -200,6 +203,7 @@
CalleeModeErrors),
!ModeInfo)
;
+ CalleeModeErrors = [],
modecheck_end_of_call(ProcInfo, Purity, ProcArgModes, ArgVars0,
ArgOffset, InstVarSub, ArgVars, ExtraGoals, !ModeInfo)
)
@@ -884,7 +888,8 @@
; Arg_mf_A = no, Arg_mf_B = no, Result0 = same
)
),
- ( Result0 = same ->
+ (
+ Result0 = same,
%
% If the actual arg inst is not available, or comparing with
% the arg inst doesn't help, then compare the two proc insts.
@@ -911,6 +916,9 @@
; A_mf_B = yes, B_mf_A = yes, Result = same
)
;
+ ( Result0 = better
+ ; Result0 = worse
+ ),
Result = Result0
)
).
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.121
diff -u -r1.121 modecheck_unify.m
--- compiler/modecheck_unify.m 1 Nov 2007 04:46:54 -0000 1.121
+++ compiler/modecheck_unify.m 21 Nov 2007 06:51:12 -0000
@@ -917,26 +917,30 @@
% For free-free unifications, we pretend for a moment that they are
% an assignment to the dead variable - they will then be optimized
% away.
- ( LiveX = is_dead ->
+ (
+ LiveX = is_dead,
Unification = assign(X, Y)
- ; LiveY = is_dead ->
- Unification = assign(Y, X)
;
- unexpected(this_file, "categorize_unify_var_var: free-free unify!")
+ LiveX = is_live,
+ (
+ LiveY = is_dead,
+ Unification = assign(Y, X)
+ ;
+ LiveY = is_live,
+ unexpected(this_file,
+ "categorize_unify_var_var: free-free unify!")
+ )
)
;
- %
- % Check for unreachable unifications
- %
+ % Check for unreachable unifications.
( mode_get_insts(ModuleInfo0, ModeOfX, not_reached, _)
; mode_get_insts(ModuleInfo0, ModeOfY, not_reached, _)
)
->
- %
% For these, we can generate any old junk here --
% we just need to avoid calling modecheck_complicated_unify,
% since that might abort.
- %
+
Unification = simple_test(X, Y)
;
map.lookup(VarTypes, X, Type),
@@ -1149,7 +1153,8 @@
RHS0, RHS, Unification0, Unification, !ModeInfo) :-
% If we are re-doing mode analysis, preserve the existing cons_id.
list.length(ArgVars, Arity),
- ( Unification0 = construct(_, ConsIdPrime, _, _, _, _, SubInfo0) ->
+ (
+ Unification0 = construct(_, ConsIdPrime, _, _, _, _, SubInfo0),
(
SubInfo0 = construct_sub_info(MaybeTakeAddr, _MaybeSize),
expect(unify(MaybeTakeAddr, no), this_file,
@@ -1159,10 +1164,15 @@
),
SubInfo = SubInfo0,
ConsId = ConsIdPrime
- ; Unification0 = deconstruct(_, ConsIdPrime, _, _, _, _) ->
+ ;
+ Unification0 = deconstruct(_, ConsIdPrime, _, _, _, _),
SubInfo = no_construct_sub_info,
ConsId = ConsIdPrime
;
+ ( Unification0 = assign(_, _)
+ ; Unification0 = simple_test(_, _)
+ ; Unification0 = complicated_unify(_, _, _)
+ ),
% The real cons_id will be computed by lambda.m;
% we just put in a dummy one for now.
SubInfo = no_construct_sub_info,
@@ -1240,7 +1250,8 @@
mode_info_get_module_info(!.ModeInfo, ModuleInfo),
map.lookup(VarTypes, X, TypeOfX),
% If we are re-doing mode analysis, preserve the existing cons_id.
- ( Unification0 = construct(_, ConsIdPrime, _, _, _, _, SubInfo0) ->
+ (
+ Unification0 = construct(_, ConsIdPrime, _, _, _, _, SubInfo0),
(
SubInfo0 = construct_sub_info(MaybeTakeAddr, _MaybeSize0),
expect(unify(MaybeTakeAddr, no), this_file,
@@ -1250,10 +1261,15 @@
),
SubInfo = SubInfo0,
ConsId = ConsIdPrime
- ; Unification0 = deconstruct(_, ConsIdPrime, _, _, _, _) ->
+ ;
+ Unification0 = deconstruct(_, ConsIdPrime, _, _, _, _),
SubInfo = no_construct_sub_info,
ConsId = ConsIdPrime
;
+ ( Unification0 = assign(_, _)
+ ; Unification0 = simple_test(_, _)
+ ; Unification0 = complicated_unify(_, _, _)
+ ),
SubInfo = no_construct_sub_info,
ConsId = NewConsId
),
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.362
diff -u -r1.362 modes.m
--- compiler/modes.m 1 Nov 2007 01:07:25 -0000 1.362
+++ compiler/modes.m 21 Nov 2007 06:52:25 -0000
@@ -1204,27 +1204,29 @@
prepend_initialisation_call(Var, Type, VarInst, !Goal,
!ModeInfo)
;
- % If we're inferring the mode, then don't report an error,
- % just set changed to yes to make sure that we will do another
- % fixpoint pass.
- InferModes = yes
- ->
- true
- ;
- % XXX This might need to be reconsidered now we have
- % unique modes.
- ( inst_matches_initial(VarInst, Inst, Type, ModuleInfo) ->
- Reason = too_instantiated
- ; inst_matches_initial(Inst, VarInst, Type, ModuleInfo) ->
- Reason = not_instantiated_enough
+ (
+ % If we're inferring the mode, then don't report an error,
+ % just set changed to yes to make sure that we will do
+ % another fixpoint pass.
+ InferModes = yes
;
- % I don't think this can happen. But just in case...
- Reason = wrongly_instantiated
- ),
- set.init(WaitingVars),
- mode_info_error(WaitingVars,
- mode_error_final_inst(ArgNum, Var, VarInst, Inst, Reason),
- !ModeInfo)
+ InferModes = no,
+ % XXX This might need to be reconsidered now we have
+ % unique modes.
+ ( inst_matches_initial(VarInst, Inst, Type, ModuleInfo) ->
+ Reason = too_instantiated
+ ; inst_matches_initial(Inst, VarInst, Type, ModuleInfo) ->
+ Reason = not_instantiated_enough
+ ;
+ % I don't think this can happen. But just in case...
+ Reason = wrongly_instantiated
+ ),
+ set.init(WaitingVars),
+ mode_info_error(WaitingVars,
+ mode_error_final_inst(ArgNum, Var, VarInst, Inst,
+ Reason),
+ !ModeInfo)
+ )
)
),
check_final_insts(VarsTail, InstsTail, VarInstsTail,
@@ -2110,11 +2112,15 @@
modecheck_conj_list_3(ConjType, Goal0, Goals0, Goals, !ImpurityErrors,
!ModeInfo, !IO) :-
Purity = goal_get_purity(Goal0),
- ( Purity = purity_impure ->
+ (
+ Purity = purity_impure,
Impure = yes,
check_for_impurity_error(Goal0, ScheduledSolverGoals,
!ImpurityErrors, !ModeInfo, !IO)
;
+ ( Purity = purity_pure
+ ; Purity = purity_semipure
+ ),
Impure = no,
ScheduledSolverGoals = []
),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.159
diff -u -r1.159 module_qual.m
--- compiler/module_qual.m 19 Nov 2007 06:11:16 -0000 1.159
+++ compiler/module_qual.m 21 Nov 2007 15:40:14 -0000
@@ -440,11 +440,9 @@
add_imports_2(Imports, !Info) :-
mq_info_get_import_status(!.Info, Status),
- %
% Modules imported from the the private interface of ancestors of
% the current module are treated as if they were directly imported
% by the current module.
- %
(
( Status = mq_status_local
; Status = mq_status_exported
@@ -458,10 +456,8 @@
true
),
- %
% We check that all modules imported in the interface are
% used in the interface.
- %
(
Status = mq_status_exported
->
@@ -473,10 +469,8 @@
true
),
- %
% Only modules imported in the interface or in the private
% interface of ancestor modules may be used in the interface.
- %
(
( Status = mq_status_exported
; Status = mq_status_imported(import_locn_ancestor_private_interface)
@@ -572,7 +566,8 @@
Success = no
).
process_assert(call_expr(SymName, Args0, _Purity) - _, Symbols, Success) :-
- ( SymName = qualified(_, _) ->
+ (
+ SymName = qualified(_, _),
list.map(term.coerce, Args0, Args),
( term_qualified_symbols_list(Args, Symbols0) ->
Symbols = [SymName | Symbols0],
@@ -582,6 +577,7 @@
Success = no
)
;
+ SymName = unqualified(_),
Symbols = [],
Success = no
).
@@ -1571,23 +1567,26 @@
Pieces2 = [words("(The module"), sym_name(ModuleName),
words("has not been imported.)"), nl]
;
- MatchingModules = [_ | MatchingModules1]
- ->
(
- MatchingModules1 = [],
- ModuleWord = "module",
- HasWord = "has"
+ MatchingModules = [_ | MatchingModulesTail],
+ (
+ MatchingModulesTail = [],
+ ModuleWord = "module",
+ HasWord = "has"
+ ;
+ MatchingModulesTail = [_ | _],
+ ModuleWord = "modules",
+ HasWord = "have"
+ ),
+ MatchingSymNames = list.map(wrap_module_name, MatchingModules),
+ Pieces2 = [words("(The"), fixed(ModuleWord)] ++
+ component_list_to_pieces(MatchingSymNames) ++
+ [fixed(HasWord),
+ words("not been imported in the interface.)"), nl]
;
- MatchingModules1 = [_ | _],
- ModuleWord = "modules",
- HasWord = "have"
- ),
- MatchingSymNames = list.map(wrap_module_name, MatchingModules),
- Pieces2 = [words("(The"), fixed(ModuleWord)] ++
- component_list_to_pieces(MatchingSymNames) ++
- [fixed(HasWord), words("not been imported in the interface.)"), nl]
- ;
- Pieces2 = []
+ MatchingModules = [],
+ Pieces2 = []
+ )
),
Msg = simple_msg(Context, [always(Pieces1 ++ Pieces2)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
@@ -2016,26 +2015,24 @@
get_partial_qualifiers_2(ImplicitPart, ExplicitPart, ModuleIdSet,
!Qualifiers) :-
- %
% If the ImplicitPart module was imported, rather than just being
% used, then insert the ExplicitPart module into the list of
% valid partial qualifiers.
- %
+
( parent_module_is_imported(ImplicitPart, ExplicitPart, ModuleIdSet) ->
!:Qualifiers = [ExplicitPart | !.Qualifiers]
;
true
),
- %
% Recursively try to add the other possible partial qualifiers.
- %
- ( ImplicitPart = qualified(Parent, Child) ->
+ (
+ ImplicitPart = qualified(Parent, Child),
NextImplicitPart = Parent,
NextExplicitPart = insert_module_qualifier(Child, ExplicitPart),
get_partial_qualifiers_2(NextImplicitPart, NextExplicitPart,
ModuleIdSet, !Qualifiers)
;
- true
+ ImplicitPart = unqualified(_)
).
% Check whether the parent module was imported, given the name of a
Index: compiler/optimize.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/optimize.m,v
retrieving revision 1.63
diff -u -r1.63 optimize.m
--- compiler/optimize.m 13 Aug 2007 03:01:43 -0000 1.63
+++ compiler/optimize.m 21 Nov 2007 10:52:06 -0000
@@ -182,7 +182,8 @@
),
FileName = BaseName ++ ".opt" ++ num_to_str(0),
io.open_output(FileName, Res, !IO),
- ( Res = ok(FileStream) ->
+ (
+ Res = ok(FileStream),
io.set_output_stream(FileStream, OutputStream, !IO),
counter.allocate(NextLabel, Counter, _),
opt_debug.msg(yes, NextLabel, "before optimization", !IO),
@@ -190,6 +191,7 @@
io.set_output_stream(OutputStream, _, !IO),
io.close_output(FileStream, !IO)
;
+ Res = error(_),
unexpected(this_file, "cannot open " ++ FileName)
),
OptDebugInfo = opt_debug_info(BaseName, 0, FileName, 0, FileName,
@@ -230,7 +232,8 @@
DiffFileName = BaseName ++ ".diff" ++ num_to_str(OptNum)
++ "." ++ Suffix,
io.open_output(OptFileName, Res, !IO),
- ( Res = ok(FileStream) ->
+ (
+ Res = ok(FileStream),
io.set_output_stream(FileStream, OutputStream, !IO),
counter.allocate(NextLabel, Counter, _),
opt_debug.msg(yes, NextLabel, Msg, !IO),
@@ -244,6 +247,7 @@
io.set_output_stream(OutputStream, _, !IO),
io.close_output(FileStream, !IO)
;
+ Res = error(_),
ErrorMsg = "cannot open " ++ OptFileName,
unexpected(this_file, ErrorMsg)
),
Index: compiler/options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.603
diff -u -r1.603 options.m
--- compiler/options.m 22 Nov 2007 17:12:06 -0000 1.603
+++ compiler/options.m 23 Nov 2007 04:45:30 -0000
@@ -124,6 +124,7 @@
; warn_obsolete
; warn_insts_without_matching_type
; warn_unused_imports
+ ; inform_ite_instead_of_switch
% Verbosity options
; verbose
@@ -959,7 +960,8 @@
% removes all the unused imports from
% the compiler itself which is compiled
% with --halt-at-warn by default.
- warn_unused_imports - bool(no)
+ warn_unused_imports - bool(no),
+ inform_ite_instead_of_switch - bool(no)
]).
option_defaults_2(verbosity_option, [
% Verbosity Options
@@ -1732,7 +1734,8 @@
long_option("warn-obsolete", warn_obsolete).
long_option("warn-insts-without-matching-type",
warn_insts_without_matching_type).
-long_option("warn-unused-imports", warn_unused_imports).
+long_option("warn-unused-imports", warn_unused_imports).
+long_option("inform-ite-instead-of-switch", inform_ite_instead_of_switch).
% verbosity options
long_option("verbose", verbose).
@@ -2507,6 +2510,8 @@
compiler_sufficiently_recent).
long_option("foreign-enum-switch-fix",
compiler_sufficiently_recent).
+long_option("failing-disjunct-in-switch-dup-fix",
+ compiler_sufficiently_recent).
long_option("experiment", experiment).
long_option("feedback-file", feedback_file).
@@ -2954,22 +2959,25 @@
;
ArgList = quote_arg_unix(string.to_char_list(Arg0)),
(
- ArgList = []
- ->
+ ArgList = [],
Arg = """"""
;
- list.member(Char, ArgList),
- \+ ( char.is_alnum_or_underscore(Char)
- ; Char = ('-')
- ; Char = ('/')
- ; Char = ('.')
- ; Char = (',')
- ; Char = (':')
+ ArgList = [_ | _],
+ (
+ list.member(Char, ArgList),
+ \+
+ ( char.is_alnum_or_underscore(Char)
+ ; Char = ('-')
+ ; Char = ('/')
+ ; Char = ('.')
+ ; Char = (',')
+ ; Char = (':')
+ )
+ ->
+ Arg = """" ++ string.from_char_list(ArgList) ++ """"
+ ;
+ Arg = string.from_char_list(ArgList)
)
- ->
- Arg = """" ++ string.from_char_list(ArgList) ++ """"
- ;
- Arg = string.from_char_list(ArgList)
)
).
@@ -3140,7 +3148,10 @@
"\tbetween the format string and the supplied values.",
"--no-warn-obsolete",
"\tDo not warn about calls to predicates or functions that have",
- "\tbeen marked as obsolete."
+ "\tbeen marked as obsolete.",
+ "--inform-ite-instead-of-switch",
+ "\tGenerate informational messages for if-then-elses that could be",
+ "\treplaced by switches."
]).
:- pred options_help_verbosity(io::di, io::uo) is det.
Index: compiler/options_file.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options_file.m,v
retrieving revision 1.47
diff -u -r1.47 options_file.m
--- compiler/options_file.m 31 Jul 2007 05:02:11 -0000 1.47
+++ compiler/options_file.m 21 Nov 2007 15:08:16 -0000
@@ -242,12 +242,16 @@
( dir.path_name_is_absolute(OptionsDir) ->
FileToFind = OptionsFile,
Dirs = [OptionsDir]
- ; MaybeDirName = yes(DirName) ->
- FileToFind = OptionsFile,
- Dirs = [DirName/OptionsDir | SearchDirs]
;
- Dirs = SearchDirs,
- FileToFind = OptionsFile0
+ (
+ MaybeDirName = yes(DirName),
+ FileToFind = OptionsFile,
+ Dirs = [DirName/OptionsDir | SearchDirs]
+ ;
+ MaybeDirName = no,
+ Dirs = SearchDirs,
+ FileToFind = OptionsFile0
+ )
)
;
Dirs = SearchDirs,
@@ -385,10 +389,13 @@
read_options_line(FoundEOF, list.reverse(RevChars), !IO) :-
io.ignore_whitespace(SpaceResult, !IO),
- ( SpaceResult = error(Error) ->
- throw(options_file_error(io.error_message(Error)))
+ (
+ SpaceResult = ok
;
- true
+ SpaceResult = eof
+ ;
+ SpaceResult = error(Error),
+ throw(options_file_error(io.error_message(Error)))
),
read_options_line_2(FoundEOF, [], RevChars, !IO).
@@ -436,39 +443,42 @@
Words1 = split_into_words(NewValue1),
io.get_environment_var(VarName, MaybeEnvValue, !IO),
(
- MaybeEnvValue = yes(EnvValue)
- ->
+ MaybeEnvValue = yes(EnvValue),
Value = string.to_char_list(EnvValue),
Words = split_into_words(Value),
OptVarValue = options_variable_value(string.to_char_list(EnvValue),
Words, environment),
map.set(!.Variables, VarName, OptVarValue, !:Variables)
;
- map.search(!.Variables, VarName,
- options_variable_value(OldValue, OldWords, Source))
- ->
+ MaybeEnvValue = no,
(
- Source = environment
- ;
- Source = command_line
- ;
- Source = options_file,
+ map.search(!.Variables, VarName,
+ options_variable_value(OldValue, OldWords, Source))
+ ->
(
- AddToValue = yes,
- NewValue = OldValue ++ [' ' | NewValue1],
- Words = OldWords ++ Words1
+ Source = environment
;
- AddToValue = no,
- NewValue = NewValue1,
- Words = Words1
- ),
- OptVarValue = options_variable_value(NewValue, Words,
+ Source = command_line
+ ;
+ Source = options_file,
+ (
+ AddToValue = yes,
+ NewValue = OldValue ++ [' ' | NewValue1],
+ Words = OldWords ++ Words1
+ ;
+ AddToValue = no,
+ NewValue = NewValue1,
+ Words = Words1
+ ),
+ OptVarValue = options_variable_value(NewValue, Words,
+ options_file),
+ svmap.set(VarName, OptVarValue, !Variables)
+ )
+ ;
+ OptVarValue = options_variable_value(NewValue1, Words1,
options_file),
svmap.set(VarName, OptVarValue, !Variables)
)
- ;
- OptVarValue = options_variable_value(NewValue1, Words1, options_file),
- svmap.set(VarName, OptVarValue, !Variables)
).
:- pred expand_variables(options_variables::in, list(char)::in,
@@ -1028,10 +1038,14 @@
VarName = options_variable_name(FlagsVar),
lookup_variable_words_report_error(Vars, "DEFAULT_" ++ VarName,
DefaultFlagsResult, !IO),
- ( OptionsVariableClass = default ->
+ (
+ OptionsVariableClass = default,
FlagsResult = var_result_unset,
ExtraFlagsResult = var_result_unset
;
+ ( OptionsVariableClass = module_specific(_)
+ ; OptionsVariableClass = non_module_specific
+ ),
lookup_variable_words_report_error(Vars, VarName, FlagsResult, !IO),
lookup_variable_words_report_error(Vars, "EXTRA_" ++ VarName,
ExtraFlagsResult, !IO)
@@ -1047,51 +1061,47 @@
;
ModuleFlagsResult = var_result_unset
),
- %
- % NOTE: the order in which these lists of flags are added together is
- % important. In the resulting set the flags from DefaultFlagsResult
- % *must* occur before those in FlagsResult, which in turn *must*
- % occur before those in ExtraFlagsResult ... etc.
- % Failing to maintain this order will result in the user being unable
- % to override the default value of many of the compiler's options.
- %
+
+ % NOTE: The order in which these lists of flags are added together is
+ % important. In the resulting set the flags from DefaultFlagsResult
+ % *must* occur before those in FlagsResult, which in turn *must* occur
+ % before those in ExtraFlagsResult ... etc. Failing to maintain this order
+ % will result in the user being unable to override the default value
+ % of many of the compiler's options.
+
Result0 =
DefaultFlagsResult `combine_var_results`
FlagsResult `combine_var_results`
ExtraFlagsResult `combine_var_results`
ModuleFlagsResult,
- %
% Check the result is valid for the variable type.
- %
(
- Result0 = var_result_unset, Result = var_result_unset
+ Result0 = var_result_unset,
+ Result = var_result_unset
;
- Result0 = var_result_error(E), Result = var_result_error(E)
+ Result0 = var_result_error(E),
+ Result = var_result_error(E)
;
Result0 = var_result_set(V),
( FlagsVar = ml_libs ->
- BadLibs = list.filter(
- (pred(LibFlag::in) is semidet :-
- \+ string.prefix(LibFlag, "-l")
-
- ), V),
+ NotLibLPrefix =
+ (pred(LibFlag::in) is semidet :-
+ \+ string.prefix(LibFlag, "-l")
+ ),
+ BadLibs = list.filter(NotLibLPrefix, V),
(
BadLibs = [],
Result = Result0
;
BadLibs = [_ | _],
+ Pieces = [words("Error: MLLIBS must contain only"),
+ words("`-l' options, found") |
+ list_to_pieces(
+ list.map(func(Lib) = add_quotes(Lib), BadLibs))]
+ ++ [suffix(".")],
ErrorSpec = error_spec(severity_error, phase_read_files,
- [error_msg(no, no, 0,
- [always([words("Error: MLLIBS must contain only"),
- words("`-l' options, found") |
- list_to_pieces(
- list.map(func(Lib) =
- add_quotes(Lib), BadLibs))]
- ++ [suffix(".")]
- )]
- )]
- ),
+ [error_msg(no, no, 0, [always(Pieces)])]),
globals.io_get_globals(Globals, !IO),
write_error_spec(ErrorSpec, Globals, 0, _, 0, _, !IO),
Result = var_result_error(ErrorSpec)
@@ -1121,11 +1131,14 @@
lookup_variable_words_report_error(Vars, VarName, Result, !IO) :-
lookup_variable_words(Vars, VarName, Result, !IO),
- ( Result = var_result_error(ErrorSpec) ->
+ (
+ Result = var_result_error(ErrorSpec),
globals.io_get_globals(Globals, !IO),
write_error_spec(ErrorSpec, Globals, 0, _, 0, _, !IO)
;
- true
+ Result = var_result_set(_)
+ ;
+ Result = var_result_unset
).
:- pred lookup_variable_words(options_variables::in, options_variable::in,
@@ -1156,23 +1169,22 @@
SplitResult = error(Msg),
ErrorSpec = error_spec(severity_error, phase_read_files,
- [error_msg(no, no, 0,
- [always([words("Error: in environment variable"),
- quote(VarName), suffix(":"), words(Msg)
- ])]
- )]
- ),
- Result = var_result_error(ErrorSpec)
- )
- ;
- MaybeEnvValue = no,
- ( map.search(Vars, VarName, MapValue) ->
- MapValue = options_variable_value(_, Words, _),
- Result = var_result_set(Words)
- ;
- Result = var_result_unset
- )
- ).
+ [error_msg(no, no, 0,
+ [always([words("Error: in environment variable"),
+ quote(VarName), suffix(":"), words(Msg)
+ ])]
+ )]),
+ Result = var_result_error(ErrorSpec)
+)
+;
+MaybeEnvValue = no,
+( map.search(Vars, VarName, MapValue) ->
+ MapValue = options_variable_value(_, Words, _),
+ Result = var_result_set(Words)
+;
+ Result = var_result_unset
+)
+).
:- pred lookup_variable_chars(options_variables::in, string::in,
list(char)::out, list(string)::in, list(string)::out,
Index: compiler/pd_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pd_info.m,v
retrieving revision 1.35
diff -u -r1.35 pd_info.m
--- compiler/pd_info.m 7 Aug 2007 07:10:01 -0000 1.35
+++ compiler/pd_info.m 22 Nov 2007 03:02:11 -0000
@@ -596,20 +596,18 @@
instmap.lookup_var(NewInstMap, NewVar, NewVarInst),
map.lookup(VarTypes, NewVar, Type),
inst_matches_initial(NewVarInst, OldVarInst, Type, ModuleInfo),
- ( !.ExactSoFar = exact ->
+ (
+ !.ExactSoFar = exact,
% Does inst_matches_initial(Inst1, Inst2, M) and
% inst_matches_initial(Inst2, Inst1, M) imply that Inst1
% and Inst2 are interchangable?
- (
- inst_matches_initial(OldVarInst, NewVarInst, Type,
- ModuleInfo)
- ->
+ ( inst_matches_initial(OldVarInst, NewVarInst, Type, ModuleInfo) ->
!:ExactSoFar = exact
;
!:ExactSoFar = more_general
)
;
- !:ExactSoFar = more_general
+ !.ExactSoFar = more_general
),
pd_info.check_insts(ModuleInfo, Vars, VarRenaming, OldInstMap,
NewInstMap, VarTypes, !ExactSoFar).
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.63
diff -u -r1.63 pd_util.m
--- compiler/pd_util.m 7 Aug 2007 07:10:02 -0000 1.63
+++ compiler/pd_util.m 22 Nov 2007 03:05:39 -0000
@@ -657,7 +657,8 @@
get_sub_branch_vars_goal(ProcArgInfo, [Goal | GoalList],
VarTypes, InstMap0, Vars0, SubVars, !ModuleInfo) :-
Goal = hlds_goal(GoalExpr, GoalInfo),
- ( GoalExpr = if_then_else(_, Cond, Then, Else) ->
+ (
+ GoalExpr = if_then_else(_, Cond, Then, Else),
Cond = hlds_goal(_, CondInfo),
CondDelta = goal_info_get_instmap_delta(CondInfo),
instmap.apply_instmap_delta(InstMap0, CondDelta, InstMap1),
@@ -667,14 +668,27 @@
goal_to_conj_list(Else, ElseList),
examine_branch(!.ModuleInfo, ProcArgInfo, 2, ElseList,
VarTypes, InstMap0, Vars1, Vars2)
- ; GoalExpr = disj(Goals) ->
+ ;
+ GoalExpr = disj(Goals),
examine_branch_list(!.ModuleInfo, ProcArgInfo,
1, Goals, VarTypes, InstMap0, Vars0, Vars2)
- ; GoalExpr = switch(Var, _, Cases) ->
+ ;
+ GoalExpr = switch(Var, _, Cases),
examine_case_list(ProcArgInfo, 1, Var,
Cases, VarTypes, InstMap0, Vars0, Vars2, !ModuleInfo)
;
+ ( GoalExpr = unify(_, _, _, _, _)
+ ; GoalExpr = plain_call(_, _, _, _, _, _)
+ ; GoalExpr = generic_call(_, _, _, _)
+ ; GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
+ ; GoalExpr = conj(_, _)
+ ; GoalExpr = negation(_)
+ ; GoalExpr = scope(_, _)
+ ),
Vars2 = Vars0
+ ;
+ GoalExpr = shorthand(_),
+ unexpected(this_file, "get_sub_branch_vars_goal: shorthand")
),
InstMapDelta = goal_info_get_instmap_delta(GoalInfo),
instmap.apply_instmap_delta(InstMap0, InstMapDelta, InstMap),
Index: compiler/peephole.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/peephole.m,v
retrieving revision 1.99
diff -u -r1.99 peephole.m
--- compiler/peephole.m 23 Jan 2007 07:00:38 -0000 1.99
+++ compiler/peephole.m 21 Nov 2007 10:54:05 -0000
@@ -270,9 +270,11 @@
(
% A mkframe sets curfr to point to the new frame
% only for ordinary frames, not temp frames.
- ( NondetFrameInfo = ordinary_frame(_, _, _) ->
+ (
+ NondetFrameInfo = ordinary_frame(_, _, _),
AllowedBases = [maxfr, curfr]
;
+ NondetFrameInfo = temp_frame(_),
AllowedBases = [maxfr]
),
opt_util.next_assign_to_redoip(Instrs0, AllowedBases, [], Redoip1,
@@ -438,9 +440,16 @@
:- pred invalid_peephole_opts(gc_method::in, list(pattern)::out) is det.
invalid_peephole_opts(GC_Method, InvalidPatterns) :-
- ( GC_Method = gc_accurate ->
+ (
+ GC_Method = gc_accurate,
InvalidPatterns = [incr_sp]
;
+ ( GC_Method = gc_automatic
+ ; GC_Method = gc_none
+ ; GC_Method = gc_boehm
+ ; GC_Method = gc_boehm_debug
+ ; GC_Method = gc_mps
+ ),
InvalidPatterns = []
).
Index: compiler/polyhedron.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polyhedron.m,v
retrieving revision 1.5
diff -u -r1.5 polyhedron.m
--- compiler/polyhedron.m 1 Dec 2006 15:04:14 -0000 1.5
+++ compiler/polyhedron.m 21 Nov 2007 14:22:01 -0000
@@ -11,7 +11,7 @@
%
% Provides closed convex polyhedra over Q^n.
% These are useful as an abstract domain for describing numerical relational
-% information.
+% information.
%
% The set of closed convex polyhedra is partially ordered by subset inclusion.
% It forms a lattice with intersection as the binary meet operation and convex
@@ -28,11 +28,11 @@
%
% It also includes an implementation of widening for convex polyhedra.
%
-% NOTE: many of the operations in this module require you to pass in
+% NOTE: many of the operations in this module require you to pass in
% the varset that the variables in the constraints that define the polyhedron
% were allocated from. This because the code for computing the convex hull
% and the linear solver in lp_rational.m need to allocate fresh temporary
-% variables.
+% variables.
%
% XXX We could avoid this with some extra work.
%
@@ -54,7 +54,7 @@
%-----------------------------------------------------------------------------%
-:- type polyhedron.
+:- type polyhedron.
:- type polyhedra == list(polyhedron).
@@ -65,7 +65,7 @@
:- func polyhedron.empty = polyhedron.
% The `universe' polyhedron. Equivalent to the constraint `true'.
- %
+ %
:- func polyhedron.universe = polyhedron.
% Constructs a convex polyhedron from a system of linear constraints.
@@ -76,18 +76,18 @@
% the given polyhedron.
%
:- func polyhedron.constraints(polyhedron) = constraints.
-
+
% As above but throws an exception if the given polyhedron is empty.
%
:- func polyhedron.non_false_constraints(polyhedron) = constraints.
% Succeeds iff the given polyhedron is the empty polyhedron.
%
- % NOTE: this only succeeds if the polyhedron is actually *known*
+ % NOTE: this only succeeds if the polyhedron is actually *known*
% to be empty. It might fail even when the constraint set is
% is inconsistent. You currently need to call polyhedron.optimize
- % to force this to always work.
- %
+ % to force this to always work.
+ %
:- pred polyhedron.is_empty(polyhedron::in) is semidet.
% Succeeds iff the given polyhedron is the `universe' polyhedron,
@@ -105,16 +105,16 @@
% polyhedron.intersection(A, B, C).
% The polyhedron `C' is the intersection of the the
- % polyhedra `A' and `B'.
+ % polyhedra `A' and `B'.
%
:- func polyhedron.intersection(polyhedron, polyhedron) = polyhedron.
:- pred polyhedron.intersection(polyhedron::in, polyhedron::in,
polyhedron::out) is det.
- % Returns a polyhedron that is a closed convex approximation of
+ % Returns a polyhedron that is a closed convex approximation of
% union of the two polyhedra.
%
-:- func polyhedron.convex_union(lp_varset, polyhedron, polyhedron) =
+:- func polyhedron.convex_union(lp_varset, polyhedron, polyhedron) =
polyhedron.
:- pred polyhedron.convex_union(lp_varset::in, polyhedron::in, polyhedron::in,
polyhedron::out) is det.
@@ -122,8 +122,8 @@
% As above but takes an extra argument that weakens the approximation even
% further if the size of the internal matrices exceeds the supplied
% threshold
- %
-:- func polyhedron.convex_union(lp_varset, maybe(int), polyhedron,
+ %
+:- func polyhedron.convex_union(lp_varset, maybe(int), polyhedron,
polyhedron) = polyhedron.
:- pred polyhedron.convex_union(lp_varset::in, maybe(int)::in, polyhedron::in,
polyhedron::in, polyhedron::out) is det.
@@ -134,16 +134,16 @@
:- func polyhedron.bounding_box(polyhedron, lp_varset) = polyhedron.
% polyhedron.widen(A, B, Varset) = C.
- % Remove faces from the polyhedron `A' to form the polyhedron `C'
+ % Remove faces from the polyhedron `A' to form the polyhedron `C'
% according to the rules that the smallest number of faces
% should be removed and that `C' must be a superset of `B'.
% This operation is not commutative.
%
-:- func polyhedron.widen(polyhedron, polyhedron, lp_varset) = polyhedron.
+:- func polyhedron.widen(polyhedron, polyhedron, lp_varset) = polyhedron.
% project_all(Varset, Variables, Polyhedra) returns a list
% of polyhedra in which the variables listed have been eliminated
- % from each polyhedron.
+ % from each polyhedron.
%
:- func polyhedron.project_all(lp_varset, lp_vars, polyhedra) = polyhedra.
@@ -158,7 +158,7 @@
% constraints anyway.
%
:- func polyhedron.substitute_vars(lp_vars, lp_vars, polyhedron) = polyhedron.
-:- func polyhedron.substitute_vars(map(lp_var, lp_var), polyhedron) =
+:- func polyhedron.substitute_vars(map(lp_var, lp_var), polyhedron) =
polyhedron.
% polyhedron.zero_vars(Set, Polyhedron0) = Polyhedron <=>
@@ -170,10 +170,10 @@
%
% This is a little more efficient than the above because
% we don't end up traversing the list of constraints as much.
- %
+ %
:- func polyhedron.zero_vars(set(lp_var), polyhedron) = polyhedron.
- % Print out the polyhedron using the names of the variables in the
+ % Print out the polyhedron using the names of the variables in the
% varset.
%
:- pred polyhedron.write_polyhedron(polyhedron::in, lp_varset::in, io::di,
@@ -197,7 +197,7 @@
% XXX The constructor eqns/1 should really be called something
% more meaningful.
%
-:- type polyhedron
+:- type polyhedron
---> eqns(constraints)
; empty_poly.
@@ -209,7 +209,7 @@
polyhedron.empty = empty_poly.
polyhedron.universe = eqns([]).
-
+
% This does the following:
% - checks if the constraint is false.
% - simplifies the representation of the constraint.
@@ -228,7 +228,7 @@
polyhedron.constraints(empty_poly) = [lp_rational.false_constraint].
polyhedron.non_false_constraints(eqns(Constraints)) = Constraints.
-polyhedron.non_false_constraints(empty_poly) =
+polyhedron.non_false_constraints(empty_poly) =
unexpected(this_file, "non_false_constraints/1: empty polyhedron.").
polyhedron.is_empty(empty_poly).
@@ -237,13 +237,13 @@
list.all_true(lp_rational.nonneg_constr, Constraints).
polyhedron.optimize(_, empty_poly, empty_poly).
-polyhedron.optimize(Varset, eqns(Constraints0), Result) :-
+polyhedron.optimize(Varset, eqns(Constraints0), Result) :-
Constraints = simplify_constraints(Constraints0),
( inconsistent(Varset, Constraints) ->
Result = empty_poly
- ;
+ ;
Result = eqns(Constraints)
- ).
+ ).
%-----------------------------------------------------------------------------%
%
@@ -255,7 +255,7 @@
polyhedron.intersection(empty_poly, _) = empty_poly.
polyhedron.intersection(eqns(_), empty_poly) = empty_poly.
polyhedron.intersection(eqns(MatrixA), eqns(MatrixB)) = eqns(Constraints) :-
- Constraints0 = MatrixA ++ MatrixB,
+ Constraints0 = MatrixA ++ MatrixB,
restore_equalities(Constraints0, Constraints1),
Constraints = simplify_constraints(Constraints1).
@@ -265,7 +265,7 @@
%
% XXX At the moment this just calls convex_hull; it should actually back
% out of the convex_hull calculation if it gets too expensive (we can
-% keep track of the size of the matrices during projection) and use a
+% keep track of the size of the matrices during projection) and use a
% bounding box approximation instead.
%
@@ -275,9 +275,9 @@
polyhedron.convex_union(Varset, PolyhedronA, PolyhedronB, Polyhedron) :-
convex_union(Varset, no, PolyhedronA, PolyhedronB, Polyhedron).
-polyhedron.convex_union(Varset, MaxMatrixSize, PolyhedronA, PolyhedronB)
+polyhedron.convex_union(Varset, MaxMatrixSize, PolyhedronA, PolyhedronB)
= Polyhedron :-
- convex_union(Varset, MaxMatrixSize, PolyhedronA, PolyhedronB,
+ convex_union(Varset, MaxMatrixSize, PolyhedronA, PolyhedronB,
Polyhedron).
polyhedron.convex_union(_, _, empty_poly, empty_poly, empty_poly).
@@ -301,7 +301,7 @@
% Logic-based Program Synthesis and Transformation,
% LNCS 1207: pp. 204-223, 1997.
%
-% Further details can be found in:
+% Further details can be found in:
%
% F. Benoy, A. King, and F. Mesnard.
% Computing Convex Hulls with a Linear Solver
@@ -309,7 +309,7 @@
:- type convex_hull_result
---> ok(polyhedron)
- ; aborted.
+ ; aborted.
:- type var_map == map(lp_var, lp_var).
@@ -322,37 +322,31 @@
:- type sigma_vars == list(sigma_var).
-:- type polyhedra_info
+:- type polyhedra_info
---> polyhedra_info(
- var_maps :: var_maps,
- % There is one of these for each polyhedron.
- % It maps the original variables in the
- % constraints to the temporary variables
- % introduced by the the transformation.
- % A variable that occurs in more than one
- % polyhedron is mapped to a separate
- % temporary variable for each one.
-
- sigmas :: sigma_vars,
- % The sigma variables introduced by the
- % transformation.
-
- poly_varset :: lp_varset
- % The varset the variables are allocated.
- % The temporary and sigma variables need
- % to be allocated from this as well in order
- % to prevent clashes when using the solver.
+ % There is one of these for each polyhedron. It maps the
+ % original variables in the constraints to the temporary
+ % variables introduced by the the transformation.
+ % A variable that occurs in more than one polyhedron
+ % is mapped to a separate temporary variable for each one.
+ var_maps :: var_maps,
+
+ % The sigma variables introduced by the transformation.
+ sigmas :: sigma_vars,
+
+ % The varset the variables are allocated. The temporary
+ % and sigma variables need to be allocated from this as well
+ % in order to prevent clashes when using the solver.
+ poly_varset :: lp_varset
).
:- type constr_info
---> constr_info(
- var_map :: var_map,
- % Map from original variables
- % to new (temporary) ones.
- % There is one of these for
- % each constraint.
-
- constr_varset :: lp_varset
+ % Map from original variables to new (temporary) ones.
+ % There is one of these for each constraint.
+ var_map :: var_map,
+
+ constr_varset :: lp_varset
).
:- pred convex_hull(list(constraints)::in, polyhedron::out, maybe(int)::in,
@@ -366,14 +360,14 @@
% Rename variables and add sigma constraints as necessary.
%
PolyInfo0 = polyhedra_info([], [], Varset0),
- transform_polyhedra(Polys, Matrix0, PolyInfo0, PolyInfo),
+ transform_polyhedra(Polys, Matrix0, PolyInfo0, PolyInfo),
PolyInfo = polyhedra_info(VarMaps, Sigmas, Varset),
add_sigma_constraints(Sigmas, Matrix0, Matrix1),
Matrix = add_last_constraints(Matrix1, VarMaps),
AppendValues = (func(Map, Varlist0) = Varlist :-
Varlist = Varlist0 ++ map.values(Map)
),
- VarsToEliminate = Sigmas ++ list.foldl(AppendValues, VarMaps, []),
+ VarsToEliminate = Sigmas ++ list.foldl(AppendValues, VarMaps, []),
%
% Calculate the closure of the convex hull of the original polyhedra by
% projecting the constraints in the transformed matrix onto the original
@@ -385,14 +379,14 @@
ProjectionResult),
(
% XXX We should try using a bounding box first.
- ProjectionResult = aborted,
+ ProjectionResult = pr_res_aborted,
ConvexHull = eqns(lp_rational.nonneg_box(VarsToEliminate, Matrix))
;
- ProjectionResult = inconsistent,
+ ProjectionResult = pr_res_inconsistent,
ConvexHull = empty_poly
;
some [!Hull] (
- ProjectionResult = ok(!:Hull),
+ ProjectionResult = pr_res_ok(!:Hull),
restore_equalities(!Hull),
% XXX We should try removing this call to simplify constraints.
% It seems unnecessary.
@@ -400,23 +394,23 @@
( remove_some_entailed_constraints(Varset, !Hull) ->
ConvexHull = eqns(!.Hull)
;
- ConvexHull = empty_poly
- )
+ ConvexHull = empty_poly
+ )
)
).
-:- pred transform_polyhedra(list(constraints)::in, constraints::out,
+:- pred transform_polyhedra(list(constraints)::in, constraints::out,
polyhedra_info::in, polyhedra_info::out) is det.
transform_polyhedra(Polys, Eqns, !PolyInfo) :-
list.foldl2(transform_polyhedron, Polys, [], Eqns, !PolyInfo).
-:- pred transform_polyhedron(constraints::in, constraints::in,
+:- pred transform_polyhedron(constraints::in, constraints::in,
constraints::out, polyhedra_info::in, polyhedra_info::out) is det.
transform_polyhedron(Poly, Polys0, Polys, !PolyInfo) :-
some [!Varset] (
- !.PolyInfo = polyhedra_info(VarMaps, Sigmas, !:Varset),
+ !.PolyInfo = polyhedra_info(VarMaps, Sigmas, !:Varset),
svvarset.new_var(Sigma, !Varset),
list.map_foldl2(transform_constraint(Sigma), Poly, NewEqns,
map.init, VarMap, !Varset),
@@ -424,13 +418,13 @@
!:PolyInfo = polyhedra_info([VarMap | VarMaps], [Sigma | Sigmas],
!.Varset)
).
-
+
% transform_constraint: takes a constraint (with original variables) and
% the sigma variable to add, and returns the constraint where the original
% variables are substituted for new ones and where the sigma variable is
% included. The map of old to new variables is updated if necessary.
%
-:- pred transform_constraint(lp_var::in, constraint::in, constraint::out,
+:- pred transform_constraint(lp_var::in, constraint::in, constraint::out,
var_map::in, var_map::out, lp_varset::in, lp_varset::out) is det.
transform_constraint(Sigma, !Constraint, !VarMap, !Varset) :-
@@ -446,7 +440,7 @@
% old to new variables if necessary.
%
:- pred change_var(lp_term::in, lp_term::out, var_map::in, var_map::out,
- lp_varset::in, lp_varset::out) is det.
+ lp_varset::in, lp_varset::out) is det.
change_var(!Term, !VarMap, !Varset) :-
some [!Var] (
@@ -454,7 +448,7 @@
%
% Have we already mapped this original variable to a new one?
%
- ( !:Var = !.VarMap ^ elem(!.Var) ->
+ ( !:Var = !.VarMap ^ elem(!.Var) ->
true
;
svvarset.new_var(NewVar, !Varset),
@@ -467,7 +461,7 @@
:- pred add_sigma_constraints(sigma_vars::in,
constraints::in, constraints::out) is det.
-add_sigma_constraints(Sigmas, !Constraints) :-
+add_sigma_constraints(Sigmas, !Constraints) :-
%
% Add non-negativity constraints for each sigma variable.
%
@@ -475,10 +469,10 @@
list.append(SigmaConstraints, !Constraints),
%
% The sum of all the sigma variables is one.
- %
+ %
SigmaTerms = list.map(lp_term, Sigmas),
list.cons(constraint(SigmaTerms, (=), one), !Constraints).
-
+
% Add a constraint specifying that each variable is the sum of the
% temporary variables to which it has been mapped.
%
@@ -488,7 +482,7 @@
Keys = get_keys_from_maps(VarMaps),
NewLastConstraints = set.filter_map(make_last_constraint(VarMaps), Keys),
list.append(set.to_sorted_list(NewLastConstraints), !Constraints).
-
+
% Return the set of keys in the given list of maps.
%
:- func get_keys_from_maps(var_maps) = set(lp_var).
@@ -501,7 +495,7 @@
:- func make_last_constraint(var_maps, lp_var) = constraint is semidet.
-make_last_constraint(VarMaps, OriginalVar) = Constraint :-
+make_last_constraint(VarMaps, OriginalVar) = Constraint :-
list.foldl(make_last_terms(OriginalVar), VarMaps, [], LastTerms),
Constraint = constraint([OriginalVar - one | LastTerms], (=), zero).
@@ -518,8 +512,8 @@
%
polyhedron.bounding_box(empty_poly, _) = empty_poly.
-polyhedron.bounding_box(eqns(Constraints), Varset) =
- eqns(lp_rational.bounding_box(Varset, Constraints)).
+polyhedron.bounding_box(eqns(Constraints), Varset) =
+ eqns(lp_rational.bounding_box(Varset, Constraints)).
%-----------------------------------------------------------------------------%
%
@@ -530,7 +524,7 @@
polyhedron.widen(eqns(_), empty_poly, _) =
unexpected(this_file, "widen/2: empty polyhedron").
polyhedron.widen(empty_poly, eqns(_), _) =
- unexpected(this_file, "widen/2: empty polyhedron").
+ unexpected(this_file, "widen/2: empty polyhedron").
polyhedron.widen(eqns(Poly1), eqns(Poly2), Varset) = eqns(WidenedEqns) :-
WidenedEqns = list.filter(entailed(Varset, Poly2), Poly1).
@@ -539,20 +533,20 @@
% Projection
%
-polyhedron.project_all(Varset, Locals, Polyhedra) =
+polyhedron.project_all(Varset, Locals, Polyhedra) =
list.map((func(Poly0) = Poly :-
(
Poly0 = eqns(Constraints0),
lp_rational.project(Locals, Varset, Constraints0,
ProjectionResult),
(
- ProjectionResult = aborted,
+ ProjectionResult = pr_res_aborted,
unexpected(this_file, "project_all/4: abort from project.")
;
- ProjectionResult = inconsistent,
+ ProjectionResult = pr_res_inconsistent,
Poly = empty_poly
;
- ProjectionResult = ok(Constraints1),
+ ProjectionResult = pr_res_ok(Constraints1),
restore_equalities(Constraints1, Constraints),
Poly = eqns(Constraints)
)
@@ -569,13 +563,13 @@
polyhedron.project(Vars, Varset, eqns(Constraints0), Result) :-
lp_rational.project(Vars, Varset, Constraints0, ProjectionResult),
(
- ProjectionResult = aborted,
+ ProjectionResult = pr_res_aborted,
unexpected(this_file, "project/4: abort from project")
;
- ProjectionResult = inconsistent,
+ ProjectionResult = pr_res_inconsistent,
Result = empty_poly
;
- ProjectionResult = ok(Constraints1),
+ ProjectionResult = pr_res_ok(Constraints1),
restore_equalities(Constraints1, Constraints),
Result = eqns(Constraints)
).
@@ -586,12 +580,12 @@
polyhedron.substitute_vars(OldVars, NewVars, Polyhedron0) = Polyhedron :-
Constraints0 = polyhedron.non_false_constraints(Polyhedron0),
- Constraints = lp_rational.substitute_vars(OldVars, NewVars, Constraints0),
+ Constraints = lp_rational.substitute_vars(OldVars, NewVars, Constraints0),
Polyhedron = polyhedron.from_constraints(Constraints).
polyhedron.substitute_vars(SubstMap, Polyhedron0) = Polyhedron :-
Constraints0 = polyhedron.non_false_constraints(Polyhedron0),
- Constraints = lp_rational.substitute_vars(SubstMap, Constraints0),
+ Constraints = lp_rational.substitute_vars(SubstMap, Constraints0),
Polyhedron = polyhedron.from_constraints(Constraints).
%-----------------------------------------------------------------------------%
@@ -613,7 +607,7 @@
polyhedron.write_polyhedron(eqns([]), _, !IO) :-
io.write_string("\tUniverse\n", !IO).
polyhedron.write_polyhedron(eqns(Constraints @ [_|_]), Varset, !IO) :-
- lp_rational.write_constraints(Constraints, Varset, !IO).
+ lp_rational.write_constraints(Constraints, Varset, !IO).
%-----------------------------------------------------------------------------%
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.322
diff -u -r1.322 polymorphism.m
--- compiler/polymorphism.m 12 Nov 2007 03:52:44 -0000 1.322
+++ compiler/polymorphism.m 21 Nov 2007 07:03:47 -0000
@@ -681,13 +681,21 @@
ExistHeadTypeClassInfoVars, !Info) :-
pred_info_get_origin(PredInfo, Origin),
ExtraArgModes0 = poly_arg_vector_init : poly_arg_vector(mer_mode),
- ( Origin = origin_instance_method(InstanceMethodConstraints) ->
+ (
+ Origin = origin_instance_method(InstanceMethodConstraints),
setup_headvars_instance_method(PredInfo,
InstanceMethodConstraints, !HeadVars,
UnconstrainedTVars, ExtraHeadTypeInfoVars,
ExistHeadTypeClassInfoVars,
ExtraArgModes0, ExtraArgModes, !Info)
;
+ ( Origin = origin_special_pred(_)
+ ; Origin = origin_transformed(_, _, _)
+ ; Origin = origin_created(_)
+ ; Origin = origin_assertion(_, _)
+ ; Origin = origin_lambda(_, _, _)
+ ; Origin = origin_user(_)
+ ),
pred_info_get_class_context(PredInfo, ClassContext),
InstanceTVars = [],
InstanceUnconstrainedTVars = [],
@@ -1229,13 +1237,18 @@
% so that quantification.m can recompute variable scopes properly.
% This field is also used by modecheck_unify.m -- for complicated
% unifications, it checks that all these variables are ground.
- ( !.Unification = complicated_unify(Modes, CanFail, _) ->
+ (
+ !.Unification = complicated_unify(Modes, CanFail, _),
!:Unification = complicated_unify(Modes, CanFail, TypeInfoVars)
;
% This can happen if an earlier stage of compilation has already
% determined that this unification is particular kind of unification.
% In that case, the type_info vars won't be needed.
- true
+ ( !.Unification = construct(_, _, _, _, _, _, _)
+ ; !.Unification = deconstruct(_, _, _, _, _, _)
+ ; !.Unification = assign(_, _)
+ ; !.Unification = simple_test(_, _)
+ )
).
:- pred polymorphism_process_unify_functor(prog_var::in, cons_id::in,
@@ -1512,13 +1525,17 @@
ArgVars0 = list.map(foreign_arg_var, Args0),
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
ExtraVars, ExtraGoals, !Info),
- ( Impl0 = fc_impl_import(_, _, _, _) ->
+ (
+ Impl0 = fc_impl_import(_, _, _, _),
% The reference manual guarantees a one-to-one correspondence between
% the arguments of the predicate (as augmented by with type_info and/or
% typeclass_info arguments by polymorphism.m) and the arguments of the
% imported function.
CanOptAwayUnnamed = no
;
+ ( Impl0 = fc_impl_ordinary(_, _)
+ ; Impl0 = fc_impl_model_non(_, _, _, _, _, _, _, _, _)
+ ),
CanOptAwayUnnamed = yes
),
polymorphism_process_foreign_proc_args(PredInfo, CanOptAwayUnnamed, Impl0,
@@ -1527,10 +1544,14 @@
% Add the type info arguments to the list of variables
% to call for a pragma import.
- ( Impl0 = fc_impl_import(Name, HandleReturn, Variables0, MaybeContext) ->
+ (
+ Impl0 = fc_impl_import(Name, HandleReturn, Variables0, MaybeContext),
Variables = type_info_vars(ModuleInfo, ExtraArgs, Variables0),
Impl = fc_impl_import(Name, HandleReturn, Variables, MaybeContext)
;
+ ( Impl0 = fc_impl_ordinary(_, _)
+ ; Impl0 = fc_impl_model_non(_, _, _, _, _, _, _, _, _)
+ ),
Impl = Impl0
),
@@ -2477,20 +2498,28 @@
% it should get included in the RTTI.
polymorphism_construct_type_info(Type, TypeCtor, TypeArgs, yes,
Context, Var, ExtraGoals, !Info)
- ; type_to_ctor_and_args(Type, TypeCtor, TypeArgs) ->
- % This occurs for code where a predicate calls a polymorphic predicate
- % with a known value of the type variable. The transformation we
- % perform is shown in the comment at the top of the module.
- polymorphism_construct_type_info(Type, TypeCtor, TypeArgs, no,
- Context, Var, ExtraGoals, !Info)
;
- % Now handle the cases of types which are not known statically
- % (i.e. type variables)
- ( Type = type_variable(TypeVar, _) ->
+ (
+ ( Type = defined_type(_, _, _)
+ ; Type = builtin_type(_)
+ ; Type = tuple_type(_, _)
+ ; Type = higher_order_type(_,_, _, _)
+ ; Type = apply_n_type(_, _, _)
+ ; Type = kinded_type(_, _)
+ ),
+ type_to_ctor_and_args_det(Type, TypeCtor, TypeArgs),
+ % This occurs for code where a predicate calls a polymorphic
+ % predicate with a known value of the type variable. The
+ % transformation we perform is shown in the comment at the top
+ % of the module.
+ polymorphism_construct_type_info(Type, TypeCtor, TypeArgs, no,
+ Context, Var, ExtraGoals, !Info)
+ ;
+ % Now handle the cases of types which are not known statically
+ % (i.e. type variables)
+ Type = type_variable(TypeVar, _),
get_type_info_locn(TypeVar, TypeInfoLocn, !Info),
get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, !Info)
- ;
- unexpected(this_file, "make_var: unknown type")
)
).
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.120
diff -u -r1.120 post_typecheck.m
--- compiler/post_typecheck.m 7 Aug 2007 07:10:02 -0000 1.120
+++ compiler/post_typecheck.m 21 Nov 2007 07:39:16 -0000
@@ -1365,10 +1365,16 @@
module_info_get_type_table(ModuleInfo, Types),
map.lookup(Types, TermTypeCtor, TermTypeDefn),
hlds_data.get_type_defn_body(TermTypeDefn, TermTypeBody),
- ( Ctors = TermTypeBody ^ du_type_ctors ->
+ (
+ TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _),
get_constructor_containing_field_2(Ctors, FieldName, ConsId,
FieldNumber)
;
+ ( TermTypeBody = hlds_eqv_type(_)
+ ; TermTypeBody = hlds_foreign_type(_)
+ ; TermTypeBody = hlds_solver_type(_, _)
+ ; TermTypeBody = hlds_abstract_type(_)
+ ),
unexpected(this_file, "get_constructor_containing_field: not du type")
).
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.109
diff -u -r1.109 pragma_c_gen.m
--- compiler/pragma_c_gen.m 19 Nov 2007 06:36:25 -0000 1.109
+++ compiler/pragma_c_gen.m 21 Nov 2007 10:56:03 -0000
@@ -665,7 +665,7 @@
no, no, no, MaybeFailLabel, RefersToLLDSSTack, MayDupl),
"foreign_proc inclusion")
]),
- %
+
% For semidet code, we need to insert the failure handling code here:
%
% goto skip_label;
@@ -677,8 +677,9 @@
% handling code here:
%
% <code to fail>
- %
- ( MaybeFailLabel = yes(TheFailLabel) ->
+
+ (
+ MaybeFailLabel = yes(TheFailLabel),
code_info.get_next_label(SkipLabel, !CI),
code_info.generate_failure(FailCode, !CI),
GotoSkipLabelCode = node([
@@ -688,10 +689,13 @@
FailLabelCode = node([llds_instr(label(TheFailLabel), "")]),
FailureCode = tree_list([GotoSkipLabelCode, FailLabelCode,
FailCode, SkipLabelCode])
- ; Detism = detism_failure ->
- code_info.generate_failure(FailureCode, !CI)
;
- FailureCode = empty
+ MaybeFailLabel = no,
+ ( Detism = detism_failure ->
+ code_info.generate_failure(FailureCode, !CI)
+ ;
+ FailureCode = empty
+ )
),
% Join all code fragments together.
@@ -1281,9 +1285,13 @@
foreign_proc_select_out_args(Rest, OutTail),
Arg = c_arg(_, _, _, _, ArgInfo),
ArgInfo = arg_info(_Loc, Mode),
- ( Mode = top_out ->
+ (
+ Mode = top_out,
Out = [Arg | OutTail]
;
+ ( Mode = top_in
+ ; Mode = top_unused
+ ),
Out = OutTail
).
@@ -1297,9 +1305,13 @@
foreign_proc_select_in_args(Rest, InTail),
Arg = c_arg(_, _, _, _, ArgInfo),
ArgInfo = arg_info(_Loc, Mode),
- ( Mode = top_in ->
+ (
+ Mode = top_in,
In = [Arg | InTail]
;
+ ( Mode = top_out
+ ; Mode = top_unused
+ ),
In = InTail
).
Index: compiler/process_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/process_util.m,v
retrieving revision 1.26
diff -u -r1.26 process_util.m
--- compiler/process_util.m 17 Aug 2007 02:04:14 -0000 1.26
+++ compiler/process_util.m 21 Nov 2007 09:43:44 -0000
@@ -385,7 +385,13 @@
call_child_process_io_pred(P, Status, !IO) :-
setup_child_signal_handlers(!IO),
P(Success, !IO),
- Status = ( Success = yes -> 0 ; 1 ).
+ (
+ Success = yes,
+ Status = 0
+ ;
+ Success = no,
+ Status = 1
+ ).
% do_wait(Pid, WaitedPid, Status, !IO)
%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.198
diff -u -r1.198 prog_data.m
--- compiler/prog_data.m 16 Nov 2007 03:44:52 -0000 1.198
+++ compiler/prog_data.m 22 Nov 2007 01:29:13 -0000
@@ -1258,6 +1258,9 @@
% they will be the most commonly used and therefore we want them to
% get the primary tags on a 32-bit machine.
+ ; tuple_type(list(mer_type), kind)
+ % Tuple types.
+
; higher_order_type(
% A type for higher-order values. If the second argument
% is yes(T) then the values are functions returning T,
@@ -1269,9 +1272,6 @@
lambda_eval_method
)
- ; tuple_type(list(mer_type), kind)
- % Tuple types.
-
; apply_n_type(tvar, list(mer_type), kind)
% An apply/N expression. `apply_n(V, [T1, ...], K)'
% would be the representation of type `V(T1, ...)'
@@ -2135,9 +2135,14 @@
% the determinism of the first goal.
determinism_components(DetismA, CanFailA, MaxSolnA),
- ( MaxSolnA = at_most_zero ->
+ (
+ MaxSolnA = at_most_zero,
Detism = DetismA
;
+ ( MaxSolnA = at_most_one
+ ; MaxSolnA = at_most_many
+ ; MaxSolnA = at_most_many_cc
+ ),
determinism_components(DetismB, CanFailB, MaxSolnB),
det_conjunction_canfail(CanFailA, CanFailB, CanFail),
det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
Index: compiler/prog_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_out.m,v
retrieving revision 1.82
diff -u -r1.82 prog_out.m
--- compiler/prog_out.m 9 Aug 2007 03:45:52 -0000 1.82
+++ compiler/prog_out.m 21 Nov 2007 15:42:15 -0000
@@ -372,17 +372,24 @@
pred_or_func_to_str(pf_function) = "func".
write_purity_prefix(Purity, !IO) :-
- ( Purity = purity_pure ->
- true
+ (
+ Purity = purity_pure
;
+ ( Purity = purity_impure
+ ; Purity = purity_semipure
+ ),
write_purity(Purity, !IO),
io.write_string(" ", !IO)
).
purity_prefix_to_string(Purity) = String :-
- ( Purity = purity_pure ->
+ (
+ Purity = purity_pure,
String = ""
;
+ ( Purity = purity_impure
+ ; Purity = purity_semipure
+ ),
purity_name(Purity, PurityName),
String = string.append(PurityName, " ")
).
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.55
diff -u -r1.55 prog_rep.m
--- compiler/prog_rep.m 12 Sep 2007 06:21:08 -0000 1.55
+++ compiler/prog_rep.m 21 Nov 2007 10:56:50 -0000
@@ -270,13 +270,17 @@
PredName = pred_info_name(PredInfo),
string_to_byte_list(ModuleName, !StackInfo, ModuleNameBytes),
string_to_byte_list(PredName, !StackInfo, PredNameBytes),
- ( Builtin = not_builtin ->
+ (
+ Builtin = not_builtin,
Bytes = [goal_type_to_byte(goal_plain_call)] ++
ModuleNameBytes ++
PredNameBytes ++
vars_to_byte_list(Info, Args) ++
AtomicBytes
;
+ ( Builtin = inline_builtin
+ ; Builtin = out_of_line_builtin
+ ),
Bytes = [goal_type_to_byte(goal_builtin_call)] ++
ModuleNameBytes ++
PredNameBytes ++
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.41
diff -u -r1.41 prog_type.m
--- compiler/prog_type.m 25 Sep 2007 04:56:41 -0000 1.41
+++ compiler/prog_type.m 22 Nov 2007 01:35:37 -0000
@@ -952,25 +952,38 @@
qualify_cons_id(Type, Args, ConsId0, ConsId, InstConsId) :-
(
ConsId0 = cons(Name0, OrigArity),
- type_to_ctor_and_args(Type, TypeCtor, _),
- TypeCtor = type_ctor(qualified(TypeModule, _), _)
- ->
- UnqualName = unqualify_name(Name0),
- Name = qualified(TypeModule, UnqualName),
- ConsId = cons(Name, OrigArity),
- InstConsId = ConsId
+ (
+ type_to_ctor_and_args(Type, TypeCtor, _),
+ TypeCtor = type_ctor(qualified(TypeModule, _), _)
+ ->
+ UnqualName = unqualify_name(Name0),
+ Name = qualified(TypeModule, UnqualName),
+ ConsId = cons(Name, OrigArity),
+ InstConsId = ConsId
+ ;
+ ConsId = ConsId0,
+ InstConsId = ConsId
+ )
;
- ConsId0 = type_info_cell_constructor(CellCtor)
- ->
+ ConsId0 = type_info_cell_constructor(CellCtor),
ConsId = ConsId0,
InstConsId = cell_inst_cons_id(type_info_cell(CellCtor),
list.length(Args))
;
- ConsId0 = typeclass_info_cell_constructor
- ->
+ ConsId0 = typeclass_info_cell_constructor,
ConsId = typeclass_info_cell_constructor,
InstConsId = cell_inst_cons_id(typeclass_info_cell, list.length(Args))
;
+ ( ConsId0 = int_const(_)
+ ; ConsId0 = float_const(_)
+ ; ConsId0 = string_const(_)
+ ; ConsId0 = pred_const(_, _)
+ ; ConsId0 = type_ctor_info_const(_, _, _)
+ ; ConsId0 = base_typeclass_info_const(_, _, _, _)
+ ; ConsId0 = table_io_decl(_)
+ ; ConsId0 = tabling_info_const(_)
+ ; ConsId0 = deep_profiling_proc_layout(_)
+ ),
ConsId = ConsId0,
InstConsId = ConsId
).
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.101
diff -u -r1.101 prog_util.m
--- compiler/prog_util.m 28 Sep 2007 03:17:13 -0000 1.101
+++ compiler/prog_util.m 22 Nov 2007 01:36:51 -0000
@@ -338,9 +338,11 @@
split_types_and_modes(TypesAndModes, Types, MaybeModes) :-
split_types_and_modes_2(TypesAndModes, yes, Types, Modes, Result),
- ( Result = yes ->
+ (
+ Result = yes,
MaybeModes = yes(Modes)
;
+ Result = no,
MaybeModes = no
).
Index: compiler/pseudo_type_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pseudo_type_info.m,v
retrieving revision 1.29
diff -u -r1.29 pseudo_type_info.m
--- compiler/pseudo_type_info.m 19 Jan 2007 07:04:29 -0000 1.29
+++ compiler/pseudo_type_info.m 21 Nov 2007 06:00:54 -0000
@@ -88,7 +88,15 @@
).
construct_pseudo_type_info(Type, NumUnivQTvars, ExistQTvars, PseudoTypeInfo) :-
- ( type_to_ctor_and_args(Type, TypeCtor, TypeArgs) ->
+ (
+ ( Type = defined_type(_, _, _)
+ ; Type = builtin_type(_)
+ ; Type = tuple_type(_, _)
+ ; Type = higher_order_type(_, _, _, _)
+ ; Type = apply_n_type(_, _, _)
+ ; Type = kinded_type(_, _)
+ ),
+ type_to_ctor_and_args_det(Type, TypeCtor, TypeArgs),
( type_is_var_arity(Type, VarArityId) ->
TypeCtor = type_ctor(_QualTypeName, RealArity),
generate_pseudo_args(TypeArgs, NumUnivQTvars, ExistQTvars,
@@ -116,7 +124,8 @@
plain_pseudo_type_info(RttiTypeCtor, PseudoArgs)
)
)
- ; Type = type_variable(Var, _) ->
+ ;
+ Type = type_variable(Var, _),
% In the case of a type variable, we need to assign a
% variable number *for this constructor*, i.e. taking
% only the existentially quantified variables of
@@ -149,9 +158,6 @@
expect(VarInt =< pseudo_typeinfo_max_var, this_file,
"construct_pseudo_type_info: type var exceeds limit"),
PseudoTypeInfo = type_var(VarInt)
- ;
- unexpected(this_file,
- "construct_pseudo_type_info: neither var nor non-var")
).
construct_type_info(Type, TypeInfo) :-
@@ -188,9 +194,13 @@
check_var_arity(VarArityId, Args, RealArity) :-
list.length(Args, NumPseudoArgs),
- ( VarArityId = func_type_info ->
+ (
+ VarArityId = func_type_info,
NumPseudoArgs = RealArity + 1
;
+ ( VarArityId = pred_type_info
+ ; VarArityId = tuple_type_info
+ ),
NumPseudoArgs = RealArity
).
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.114
diff -u -r1.114 purity.m
--- compiler/purity.m 7 Aug 2007 07:10:03 -0000 1.114
+++ compiler/purity.m 21 Nov 2007 07:47:48 -0000
@@ -257,10 +257,15 @@
% Finish processing of promise declarations.
pred_info_get_goal_type(PredInfo, GoalType),
- ( GoalType = goal_type_promise(PromiseType) ->
+ (
+ GoalType = goal_type_promise(PromiseType),
post_typecheck_finish_promise(PromiseType, PredId, !ModuleInfo, !Specs)
;
- true
+ ( GoalType = goal_type_clause
+ ; GoalType = goal_type_foreign
+ ; GoalType = goal_type_clause_and_foreign
+ ; GoalType = goal_type_none
+ )
),
check_preds_purity(PredIds, !ModuleInfo, !Specs).
@@ -533,12 +538,15 @@
% the unification itself is always pure,
% even if the lambda expression body is impure
DeclaredPurity = goal_info_get_purity(GoalInfo),
- ( DeclaredPurity \= purity_pure ->
+ (
+ ( DeclaredPurity = purity_impure
+ ; DeclaredPurity = purity_semipure
+ ),
Context = goal_info_get_context(GoalInfo),
Spec = impure_unification_expr_error(Context, DeclaredPurity),
purity_info_add_message(Spec, !Info)
;
- true
+ DeclaredPurity = purity_pure
),
ActualPurity = purity_pure,
ContainsTrace = contains_no_trace_goal
@@ -781,9 +789,13 @@
;
less_pure(ActualPurity, DeclaredPurity)
->
- ( PromisedPurity = purity_impure ->
+ (
+ PromisedPurity = purity_impure,
PurityCheckResult = insufficient_decl
;
+ ( PromisedPurity = purity_pure
+ ; PromisedPurity = purity_semipure
+ ),
PurityCheckResult = no_worries
)
;
@@ -837,42 +849,44 @@
% If implicit_purity = make_implicit_promises then
% we don't report purity errors or warnings.
ImplicitPurity = make_implicit_promises
- ->
- true
- ;
- % The purity of the callee should match the
- % purity declared at the call.
- ActualPurity = DeclaredPurity
- ->
- true
;
- % Don't require purity annotations on calls in
- % compiler-generated code.
- is_unify_or_compare_pred(PredInfo)
- ->
- true
- ;
- less_pure(ActualPurity, DeclaredPurity)
- ->
- Spec = error_missing_body_impurity_decl(ModuleInfo, PredId, Context),
- purity_info_add_message(Spec, !Info)
- ;
- % We don't warn about exaggerated impurity decls in class methods
- % or instance methods --- it just means that the predicate provided
- % as an implementation was more pure than necessary.
-
- pred_info_get_markers(PredInfo, Markers),
+ ImplicitPurity = dont_make_implicit_promises,
(
- check_marker(Markers, marker_class_method)
+ % The purity of the callee should match the
+ % purity declared at the call.
+ ActualPurity = DeclaredPurity
+ ->
+ true
;
- check_marker(Markers, marker_class_instance_method)
+ % Don't require purity annotations on calls in
+ % compiler-generated code.
+ is_unify_or_compare_pred(PredInfo)
+ ->
+ true
+ ;
+ less_pure(ActualPurity, DeclaredPurity)
+ ->
+ Spec = error_missing_body_impurity_decl(ModuleInfo, PredId,
+ Context),
+ purity_info_add_message(Spec, !Info)
+ ;
+ % We don't warn about exaggerated impurity decls in class methods
+ % or instance methods --- it just means that the predicate provided
+ % as an implementation was more pure than necessary.
+
+ pred_info_get_markers(PredInfo, Markers),
+ (
+ check_marker(Markers, marker_class_method)
+ ;
+ check_marker(Markers, marker_class_instance_method)
+ )
+ ->
+ true
+ ;
+ Spec = warn_unnecessary_body_impurity_decl(ModuleInfo, PredId,
+ Context, DeclaredPurity),
+ purity_info_add_message(Spec, !Info)
)
- ->
- true
- ;
- Spec = warn_unnecessary_body_impurity_decl(ModuleInfo, PredId, Context,
- DeclaredPurity),
- purity_info_add_message(Spec, !Info)
).
:- pred compute_goal_purity(hlds_goal::in, hlds_goal::out, purity::out,
@@ -1100,9 +1114,13 @@
Pieces1 = [words("In call to")] ++ PredPieces ++ [suffix(":"), nl,
words("warning: unnecessary"), quote(DeclaredPurityName),
words("indicator."), nl],
- ( ActualPurity = purity_pure ->
+ (
+ ActualPurity = purity_pure,
Pieces2 = [words("No purity indicator is necessary."), nl]
;
+ ( ActualPurity = purity_impure
+ ; ActualPurity = purity_semipure
+ ),
Pieces2 = [words("A purity indicator of"), quote(ActualPurityName),
words("is sufficient."), nl]
),
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.121
diff -u -r1.121 quantification.m
--- compiler/quantification.m 28 Sep 2007 03:17:13 -0000 1.121
+++ compiler/quantification.m 21 Nov 2007 09:34:11 -0000
@@ -520,7 +520,8 @@
get_outside(!.Info, OutsideVars),
get_lambda_outside(!.Info, LambdaOutsideVars),
TypeInfoVars = get_unify_typeinfos(Unification0),
- ( Unification0 = construct(_, _, _, _, How, _, SubInfo) ->
+ (
+ Unification0 = construct(_, _, _, _, How, _, SubInfo),
(
How = reuse_cell(cell_to_reuse(ReuseVar0, _, SetArgs)),
MaybeSetArgs = yes(SetArgs),
@@ -548,6 +549,11 @@
MaybeSizeVar = no
)
;
+ ( Unification0 = deconstruct(_, _, _, _, _, _)
+ ; Unification0 = assign(_, _)
+ ; Unification0 = simple_test(_, _)
+ ; Unification0 = complicated_unify(_, _, _)
+ ),
MaybeSetArgs = no,
MaybeReuseVar = no,
MaybeSizeVar = no,
@@ -804,8 +810,7 @@
(
!.Unification = construct(ConstructVar, ConsId, Args0,
- ArgModes0, HowToConstruct, Uniq, SubInfo)
- ->
+ ArgModes0, HowToConstruct, Uniq, SubInfo),
(
SubInfo = no_construct_sub_info
;
@@ -824,7 +829,11 @@
% After mode analysis, unifications with lambda variables should always
% be construction unifications, but quantification gets invoked before
% mode analysis, so we need to allow this case...
- true
+ ( !.Unification = deconstruct(_, _, _, _, _, _)
+ ; !.Unification = assign(_, _)
+ ; !.Unification = simple_test(_, _)
+ ; !.Unification = complicated_unify(_, _, _)
+ )
).
:- pred implicitly_quantify_conj(list(hlds_goal)::in, list(hlds_goal)::out,
@@ -1144,7 +1153,8 @@
goal_vars_2(NonLocalsToRecompute, unify(LHS, RHS, _, Unification, _),
!Set, !LambdaSet) :-
insert(!.Set, LHS, !:Set),
- ( Unification = construct(_, _, _, _, How, _, SubInfo) ->
+ (
+ Unification = construct(_, _, _, _, How, _, SubInfo),
(
How = reuse_cell(cell_to_reuse(ReuseVar, _, SetArgs)),
MaybeSetArgs = yes(SetArgs),
@@ -1167,10 +1177,15 @@
;
true
)
- ; Unification = complicated_unify(_, _, TypeInfoVars) ->
+ ;
+ Unification = complicated_unify(_, _, TypeInfoVars),
MaybeSetArgs = no,
insert_list(!.Set, TypeInfoVars, !:Set)
;
+ ( Unification = deconstruct(_, _, _, _, _, _)
+ ; Unification = assign(_, _)
+ ; Unification = simple_test(_, _)
+ ),
MaybeSetArgs = no
),
unify_rhs_vars(NonLocalsToRecompute, RHS, MaybeSetArgs, !Set, !LambdaSet).
@@ -1330,11 +1345,16 @@
:- func get_unify_typeinfos(unification) = list(prog_var).
-get_unify_typeinfos(Unification) =
- ( Unification = complicated_unify(_, _, TypeInfoVars0) ->
- TypeInfoVars0
+get_unify_typeinfos(Unification) = TypeInfoVars :-
+ (
+ Unification = complicated_unify(_, _, TypeInfoVars)
;
- []
+ ( Unification = construct(_, _, _, _, _, _, _)
+ ; Unification = deconstruct(_, _, _, _, _, _)
+ ; Unification = assign(_, _)
+ ; Unification = simple_test(_, _)
+ ),
+ TypeInfoVars = []
).
%-----------------------------------------------------------------------------%
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.86
diff -u -r1.86 rtti.m
--- compiler/rtti.m 11 Sep 2007 03:12:33 -0000 1.86
+++ compiler/rtti.m 21 Nov 2007 07:02:22 -0000
@@ -2079,11 +2079,24 @@
%
% This decision is implemented separately in tc_name_to_string.
-module_qualify_name_of_tc_rtti_name(TCRttiName) =
- ( TCRttiName = type_class_base_typeclass_info(_, _) ->
- no
+module_qualify_name_of_tc_rtti_name(TCRttiName) = ModuleQualify :-
+ (
+ TCRttiName = type_class_base_typeclass_info(_, _),
+ ModuleQualify = no
;
- yes
+ ( TCRttiName = type_class_id
+ ; TCRttiName = type_class_id_var_names
+ ; TCRttiName = type_class_id_method_ids
+ ; TCRttiName = type_class_decl
+ ; TCRttiName = type_class_decl_super(_, _)
+ ; TCRttiName = type_class_decl_supers
+ ; TCRttiName = type_class_instance(_)
+ ; TCRttiName = type_class_instance_tc_type_vector(_)
+ ; TCRttiName = type_class_instance_constraint(_, _, _)
+ ; TCRttiName = type_class_instance_constraints(_)
+ ; TCRttiName = type_class_instance_methods(_)
+ ),
+ ModuleQualify = yes
).
rtti_id_emits_type_ctor_info(RttiId, TypeCtor) :-
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.220
diff -u -r1.220 simplify.m
--- compiler/simplify.m 19 Nov 2007 06:11:17 -0000 1.220
+++ compiler/simplify.m 22 Nov 2007 01:08:16 -0000
@@ -135,6 +135,7 @@
:- import_module check_hlds.polymorphism.
:- import_module check_hlds.type_util.
:- import_module check_hlds.unify_proc.
+:- import_module hlds.hlds_data.
:- import_module hlds.goal_form.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_error_util.
@@ -677,13 +678,12 @@
simplify_info_incr_cost_delta(CostDelta, !Info),
Goal1 = fail_goal_with_context(Context)
;
- %
% If --no-fully-strict, replace goals which cannot fail and have
% no output variables with `true'. However, we don't do this for
% erroneous goals, since these may occur in conjunctions where there
% are no producers for some variables, and the code generator would
% fail for these.
- %
+
determinism_components(Detism, cannot_fail, MaxSoln),
MaxSoln \= at_most_zero,
InstMapDelta = goal_info_get_instmap_delta(GoalInfo0),
@@ -1201,15 +1201,8 @@
simplify_goal_2_unify(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info, !IO) :-
GoalExpr0 = unify(LT0, RT0, M, U0, C),
(
- % A unification of the form X = X can be safely optimised away.
- RT0 = rhs_var(LT0)
- ->
- Context = goal_info_get_context(GoalInfo0),
- hlds_goal(GoalExpr, GoalInfo) = true_goal_with_context(Context)
- ;
RT0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocals,
- Vars, Modes, LambdaDeclaredDet, LambdaGoal0)
- ->
+ Vars, Modes, LambdaDeclaredDet, LambdaGoal0),
simplify_info_enter_lambda(!Info),
simplify_info_get_common_info(!.Info, Common1),
simplify_info_get_module_info(!.Info, ModuleInfo),
@@ -1232,40 +1225,49 @@
GoalExpr = unify(LT0, RT, M, U0, C),
GoalInfo = GoalInfo0
;
- U0 = complicated_unify(UniMode, CanFail, TypeInfoVars)
- ->
+ ( RT0 = rhs_functor(_, _, _)
+ ; RT0 = rhs_var(_)
+ ),
(
- RT0 = rhs_var(V),
- process_compl_unify(LT0, V, UniMode, CanFail, TypeInfoVars, C,
- GoalInfo0, GoalExpr1, !Info, !IO),
- GoalExpr1 = hlds_goal(GoalExpr, GoalInfo)
+ % A unification of the form X = X can be safely optimised away.
+ RT0 = rhs_var(LT0)
+ ->
+ Context = goal_info_get_context(GoalInfo0),
+ hlds_goal(GoalExpr, GoalInfo) = true_goal_with_context(Context)
;
- ( RT0 = rhs_functor(_, _, _)
- ; RT0 = rhs_lambda_goal(_, _, _, _, _, _, _, _)
- ),
- unexpected(this_file, "invalid RHS for complicated unify")
- )
- ;
- simplify_do_common_struct(!.Info)
- ->
- common_optimise_unification(U0, LT0, RT0, M, C,
- GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info)
- ;
- ( simplify_do_opt_duplicate_calls(!.Info)
- ; simplify_do_warn_duplicate_calls(!.Info)
+ U0 = complicated_unify(UniMode, CanFail, TypeInfoVars)
+ ->
+ (
+ RT0 = rhs_var(V),
+ process_compl_unify(LT0, V, UniMode, CanFail, TypeInfoVars, C,
+ GoalInfo0, GoalExpr1, !Info, !IO),
+ GoalExpr1 = hlds_goal(GoalExpr, GoalInfo)
+ ;
+ RT0 = rhs_functor(_, _, _),
+ unexpected(this_file, "invalid RHS for complicated unify")
+ )
+ ;
+ simplify_do_common_struct(!.Info)
+ ->
+ common_optimise_unification(U0, LT0, RT0, M, C,
+ GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info)
+ ;
+ ( simplify_do_opt_duplicate_calls(!.Info)
+ ; simplify_do_warn_duplicate_calls(!.Info)
+ )
+ ->
+ % We need to do the pass, to record the variable equivalences
+ % used for optimizing or warning about duplicate calls.
+ % But we don't want to perform the optimization, so we disregard
+ % the optimized goal and instead use the original one.
+ common_optimise_unification(U0, LT0, RT0, M, C,
+ GoalExpr0, _GoalExpr1, GoalInfo0, _GoalInfo1, !Info),
+ GoalExpr = GoalExpr0,
+ GoalInfo = GoalInfo0
+ ;
+ GoalExpr = GoalExpr0,
+ GoalInfo = GoalInfo0
)
- ->
- % We need to do the pass, to record the variable equivalences
- % used for optimizing or warning about duplicate calls.
- % But we don't want to perform the optimization, so we disregard
- % the optimized goal and instead use the original one.
- common_optimise_unification(U0, LT0, RT0, M, C,
- GoalExpr0, _GoalExpr1, GoalInfo0, _GoalInfo1, !Info),
- GoalExpr = GoalExpr0,
- GoalInfo = GoalInfo0
- ;
- GoalExpr = GoalExpr0,
- GoalInfo = GoalInfo0
).
:- pred simplify_goal_2_ite(
@@ -1303,7 +1305,8 @@
Cond0 = hlds_goal(_, CondInfo0),
CondDetism0 = goal_info_get_determinism(CondInfo0),
determinism_components(CondDetism0, CondCanFail0, CondSolns0),
- ( CondCanFail0 = cannot_fail ->
+ (
+ CondCanFail0 = cannot_fail,
goal_to_conj_list(Cond0, CondList),
goal_to_conj_list(Then0, ThenList),
list.append(CondList, ThenList, List),
@@ -1332,67 +1335,88 @@
),
simplify_info_set_requantify(!Info),
simplify_info_set_rerun_det(!Info)
- ; CondSolns0 = at_most_zero ->
- % Optimize away the condition and the `then' part.
- det_negation_det(CondDetism0, MaybeNegDetism),
- (
- Cond0 = hlds_goal(negation(NegCond), _),
- % XXX BUG! This optimization is only safe if it preserves mode
- % correctness, which means in particular that the negated goal
- % must not clobber any variables. For now I've just disabled
- % the optimization.
- semidet_fail
- ->
- Cond = NegCond
- ;
+ ;
+ CondCanFail0 = can_fail,
+ (
+ CondSolns0 = at_most_zero,
+ % Optimize away the condition and the `then' part.
+ det_negation_det(CondDetism0, MaybeNegDetism),
(
- MaybeNegDetism = yes(NegDetism1),
+ Cond0 = hlds_goal(negation(NegCond), _),
+ % XXX BUG! This optimization is only safe if it preserves mode
+ % correctness, which means in particular that the negated goal
+ % must not clobber any variables. For now I've just disabled
+ % the optimization.
+ semidet_fail
+ ->
+ Cond = NegCond
+ ;
(
- NegDetism1 = detism_erroneous,
- instmap_delta_init_unreachable(NegInstMapDelta1)
+ MaybeNegDetism = yes(NegDetism1),
+ (
+ NegDetism1 = detism_erroneous,
+ instmap_delta_init_unreachable(NegInstMapDelta1)
+ ;
+ NegDetism1 = detism_det,
+ instmap_delta_init_reachable(NegInstMapDelta1)
+ )
+ ->
+ NegDetism = NegDetism1,
+ NegInstMapDelta = NegInstMapDelta1
;
- NegDetism1 = detism_det,
- instmap_delta_init_reachable(NegInstMapDelta1)
- )
- ->
- NegDetism = NegDetism1,
- NegInstMapDelta = NegInstMapDelta1
+ unexpected(this_file,
+ "goal_2: cannot get negated determinism")
+ ),
+ goal_info_set_determinism(NegDetism, CondInfo0, NegCondInfo0),
+ goal_info_set_instmap_delta(NegInstMapDelta,
+ NegCondInfo0, NegCondInfo),
+ Cond = hlds_goal(negation(Cond0), NegCondInfo)
+ ),
+ goal_to_conj_list(Else0, ElseList),
+ List = [Cond | ElseList],
+ simplify_goal(hlds_goal(conj(plain_conj, List), GoalInfo0),
+ hlds_goal(GoalExpr, GoalInfo), !Info, !IO),
+ simplify_info_get_inside_duplicated_for_switch(!.Info,
+ InsideDuplForSwitch),
+ (
+ InsideDuplForSwitch = yes
+ % Do not generate the warning, since it is quite likely to be
+ % spurious: though the condition cannot succeed in this arm
+ % of the switch, it likely can succeed in other arms that
+ % derive from the exact same piece of source code.
;
- unexpected(this_file, "goal_2: cannot get negated determinism")
+ InsideDuplForSwitch = no,
+ Context = goal_info_get_context(GoalInfo0),
+ Pieces = [words("Warning: the condition of this if-then-else"),
+ words("cannot succeed.")],
+ Msg = simple_msg(Context,
+ [option_is_set(warn_simple_code, yes, [always(Pieces)])]),
+ Severity = severity_conditional(warn_simple_code, yes,
+ severity_warning, no),
+ Spec = error_spec(Severity,
+ phase_simplify(report_only_if_in_all_modes), [Msg]),
+ simplify_info_add_error_spec(Spec, !Info)
),
- goal_info_set_determinism(NegDetism, CondInfo0, NegCondInfo0),
- goal_info_set_instmap_delta(NegInstMapDelta,
- NegCondInfo0, NegCondInfo),
- Cond = hlds_goal(negation(Cond0), NegCondInfo)
- ),
- goal_to_conj_list(Else0, ElseList),
- List = [Cond | ElseList],
- simplify_goal(hlds_goal(conj(plain_conj, List), GoalInfo0),
- hlds_goal(GoalExpr, GoalInfo), !Info, !IO),
- simplify_info_get_inside_duplicated_for_switch(!.Info,
- InsideDuplForSwitch),
- (
- InsideDuplForSwitch = yes
- % Do not generate the warning, since it is quite likely to be
- % spurious: though the condition cannot succeed in this arm of the
- % switch, it likely can succeed in other arms that derive from
- % the exact same piece of source code.
+ simplify_info_set_requantify(!Info),
+ simplify_info_set_rerun_det(!Info)
;
- InsideDuplForSwitch = no,
- Context = goal_info_get_context(GoalInfo0),
- Pieces = [words("Warning: the condition of this if-then-else"),
- words("cannot succeed.")],
- Msg = simple_msg(Context,
- [option_is_set(warn_simple_code, yes, [always(Pieces)])]),
- Severity = severity_conditional(warn_simple_code, yes,
- severity_warning, no),
- Spec = error_spec(Severity,
- phase_simplify(report_only_if_in_all_modes), [Msg]),
- simplify_info_add_error_spec(Spec, !Info)
- ),
- simplify_info_set_requantify(!Info),
- simplify_info_set_rerun_det(!Info)
- ; Else0 = hlds_goal(disj([]), _) ->
+ ( CondSolns0 = at_most_one
+ ; CondSolns0 = at_most_many
+ ; CondSolns0 = at_most_many_cc
+ ),
+ simplify_goal_2_ordinary_ite(Vars, Cond0, Then0, Else0, GoalExpr,
+ GoalInfo0, GoalInfo, !Info, !IO)
+ )
+ ).
+
+:- pred simplify_goal_2_ordinary_ite(list(prog_var)::in,
+ hlds_goal::in, hlds_goal::in, hlds_goal::in, hlds_goal_expr::out,
+ hlds_goal_info::in, hlds_goal_info::out,
+ simplify_info::in, simplify_info::out, io::di, io::uo) is det.
+
+simplify_goal_2_ordinary_ite(Vars, Cond0, Then0, Else0, GoalExpr,
+ GoalInfo0, GoalInfo, !Info, !IO) :-
+ ( Else0 = hlds_goal(disj([]), _) ->
% (A -> C ; fail) is equivalent to (A, C)
goal_to_conj_list(Cond0, CondList),
goal_to_conj_list(Then0, ThenList),
@@ -1402,8 +1426,8 @@
simplify_info_set_requantify(!Info),
simplify_info_set_rerun_det(!Info)
;
- % Recursively simplify the sub-goals,
- % and rebuild the resulting if-then-else.
+ % Recursively simplify the sub-goals, and rebuild the resulting
+ % if-then-else.
Info0 = !.Info,
simplify_info_get_instmap(!.Info, InstMap0),
@@ -1422,12 +1446,13 @@
Else = hlds_goal(_, ElseInfo),
ElseDelta = goal_info_get_instmap_delta(ElseInfo),
NonLocals = goal_info_get_nonlocals(GoalInfo0),
- simplify_info_get_module_info(!.Info, ModuleInfo0),
- simplify_info_get_var_types(!.Info, VarTypes),
- merge_instmap_deltas(InstMap0, NonLocals, VarTypes,
- [CondThenDelta, ElseDelta], NewDelta,
- ModuleInfo0, ModuleInfo1),
- simplify_info_set_module_info(ModuleInfo1, !Info),
+ some [!ModuleInfo] (
+ simplify_info_get_module_info(!.Info, !:ModuleInfo),
+ simplify_info_get_var_types(!.Info, VarTypes),
+ merge_instmap_deltas(InstMap0, NonLocals, VarTypes,
+ [CondThenDelta, ElseDelta], NewDelta, !ModuleInfo),
+ simplify_info_set_module_info(!.ModuleInfo, !Info)
+ ),
goal_info_set_instmap_delta(NewDelta, GoalInfo0, GoalInfo1),
IfThenElse = if_then_else(Vars, Cond, Then, Else),
@@ -1441,23 +1466,51 @@
% Check again if we can apply one of the above simplifications
% after having simplified the sub-goals (we need to do this
% to ensure that the goal is fully simplified, to maintain the
- % invariants that the MLDS back-end depends on)
+ % invariants that the MLDS back-end depends on).
( CondCanFail = cannot_fail
; CondSolns = at_most_zero
; Else = hlds_goal(disj([]), _)
)
->
simplify_info_undo_goal_updates(Info0, !Info),
- simplify_goal_2(IfThenElse, GoalExpr, GoalInfo1, GoalInfo, !Info,
- !IO)
+ simplify_goal_2(IfThenElse, GoalExpr, GoalInfo1, GoalInfo,
+ !Info, !IO)
;
+ simplify_info_get_module_info(!.Info, ModuleInfo),
+ warn_switch_for_ite_cond(ModuleInfo, VarTypes, Cond,
+ cond_can_switch_uncommitted, CanSwitch),
+ (
+ CanSwitch = cond_can_switch_on(SwitchVar),
+ Context = goal_info_get_context(CondInfo),
+ VarSet = !.Info ^ varset,
+ Pieces0 = [words("Warning: this if-then-else"),
+ words("could be replaced by a switch")],
+ ( varset.search_name(VarSet, SwitchVar, SwitchVarName) ->
+ OnPieces = [words("on"), quote(SwitchVarName)]
+ ;
+ OnPieces = []
+ ),
+ Pieces = Pieces0 ++ OnPieces ++ [suffix("."), nl],
+ Msg = simple_msg(Context,
+ [option_is_set(inform_ite_instead_of_switch, yes,
+ [always(Pieces)])]),
+ Severity = severity_conditional(inform_ite_instead_of_switch,
+ yes, severity_informational, no),
+ Spec = error_spec(Severity, phase_simplify(report_in_any_mode),
+ [Msg]),
+ simplify_info_add_error_spec(Spec, !Info)
+ ;
+ CanSwitch = cond_can_switch_uncommitted
+ ;
+ CanSwitch = cond_cannot_switch
+ ),
(
% If-then-elses that are det or semidet may nevertheless
- % contain nondet or multidet conditions. If this happens,
- % the if-then-else must be put inside a `scope' to appease the
- % code generator. (Both the MLDS and LLDS back-ends rely
- % on this.)
- %
+ % contain nondet or multi conditions. If this happens,
+ % the if-then-else must be put inside a `scope' to appease
+ % the code generator. (Both the MLDS and LLDS back-ends
+ % rely on this.)
+
simplify_do_once(!.Info),
CondSolns = at_most_many,
IfThenElseNumSolns \= at_most_many
@@ -1474,6 +1527,142 @@
)
).
+:- type cond_can_switch
+ ---> cond_can_switch_uncommitted
+ ; cond_can_switch_on(prog_var)
+ ; cond_cannot_switch.
+
+:- pred warn_switch_for_ite_cond(module_info::in, vartypes::in, hlds_goal::in,
+ cond_can_switch::in, cond_can_switch::out) is det.
+
+warn_switch_for_ite_cond(ModuleInfo, VarTypes, Cond, !CondCanSwitch) :-
+ Cond = hlds_goal(CondExpr, _CondInfo),
+ (
+ CondExpr = unify(_LHSVar, _RHS, _Mode, Unification, _UContext),
+ (
+ ( Unification = construct(_, _, _, _, _, _, _)
+ ; Unification = assign(_, _)
+ ; Unification = simple_test(_, _)
+ ),
+ !:CondCanSwitch = cond_cannot_switch
+ ;
+ Unification = deconstruct(LHSVar, _ConsId, _Args, _ArgModes,
+ _CanFail, _CanCGC),
+ map.lookup(VarTypes, LHSVar, LHSVarType),
+ ( type_to_type_defn_body(ModuleInfo, LHSVarType, TypeBody) ->
+ CanSwitchOnType = can_switch_on_type(TypeBody),
+ (
+ CanSwitchOnType = no,
+ !:CondCanSwitch = cond_cannot_switch
+ ;
+ CanSwitchOnType = yes,
+ (
+ !.CondCanSwitch = cond_can_switch_uncommitted,
+ !:CondCanSwitch = cond_can_switch_on(LHSVar)
+ ;
+ !.CondCanSwitch = cond_can_switch_on(SwitchVar),
+ ( SwitchVar = LHSVar ->
+ true
+ ;
+ !:CondCanSwitch = cond_cannot_switch
+ )
+ ;
+ !.CondCanSwitch = cond_cannot_switch
+ )
+ )
+ ;
+ % You cannot have a switch on a type with no body (e.g. a
+ % builtin type such as int).
+ !:CondCanSwitch = cond_cannot_switch
+ )
+ ;
+ Unification = complicated_unify(_, _, _),
+ unexpected(this_file,
+ "warn_ite_instead_of_switch: complicated unify")
+ )
+ ;
+ CondExpr = disj(Disjuncts),
+ list.foldl(warn_switch_for_ite_cond(ModuleInfo, VarTypes), Disjuncts,
+ !CondCanSwitch)
+ ;
+ CondExpr = negation(SubGoal),
+ (
+ !.CondCanSwitch = cond_can_switch_uncommitted,
+ warn_switch_for_ite_cond(ModuleInfo, VarTypes, SubGoal,
+ !CondCanSwitch)
+ ;
+ !.CondCanSwitch = cond_can_switch_on(_),
+ % The condition cannot do both.
+ !:CondCanSwitch = cond_cannot_switch
+ ;
+ !.CondCanSwitch = cond_cannot_switch
+ )
+ ;
+ ( CondExpr = plain_call(_, _, _, _, _, _)
+ ; CondExpr = generic_call(_, _, _, _)
+ ; CondExpr = call_foreign_proc(_, _, _, _, _, _, _)
+ ; CondExpr = conj(_, _)
+ ; CondExpr = switch(_, _, _)
+ ; CondExpr = scope(_, _)
+ ; CondExpr = if_then_else(_, _, _, _)
+ ),
+ !:CondCanSwitch = cond_cannot_switch
+ ;
+ CondExpr = shorthand(_),
+ unexpected(this_file, "warn_ite_instead_of_switch: shorthand")
+ ).
+
+:- func can_switch_on_type(hlds_type_body) = bool.
+
+can_switch_on_type(TypeBody) = CanSwitchOnType :-
+ (
+ TypeBody = hlds_du_type(_Ctors, _TagValues, IsEnumOrDummy,
+ _UserEq, _ReservedTag, _ReservedAddr, _MaybeForeignType),
+ % We don't care about _UserEq, since the unification with *any* functor
+ % of the type indicates that we are deconstructing the physical
+ % representation, not the logical value.
+ %
+ % We don't care about _ReservedTag or _ReservedAddr, since those are
+ % only implementation details.
+ %
+ % We don't care about _MaybeForeignType, since the unification with
+ % *any* functor of the type means that either there is no foreign type
+ % version, or we are using the Mercury version of the type.
+ (
+ ( IsEnumOrDummy = is_mercury_enum
+ ; IsEnumOrDummy = is_foreign_enum(_)
+ ; IsEnumOrDummy = not_enum_or_dummy
+ ),
+ CanSwitchOnType = yes
+ ;
+ IsEnumOrDummy = is_dummy,
+ % We should have already got a warning that the condition cannot
+ % fail; a warning about using a switch would therefore be redundant
+ % (as well as confusing, since you cannot have a switch with one
+ % arm for the one function symbol).
+ CanSwitchOnType = no
+ )
+ ;
+ TypeBody = hlds_eqv_type(_),
+ % The type of the variable should have had any equivalences expanded
+ % out of it before simplify.
+ unexpected(this_file, "warn_switch_for_ite_cond: eqv type")
+ ;
+ TypeBody = hlds_foreign_type(_),
+ % If the type is foreign, how can have a Mercury unification using it?
+ unexpected(this_file, "warn_switch_for_ite_cond: foreign type")
+ ;
+ TypeBody = hlds_abstract_type(_),
+ % If the type is abstract, how can have a Mercury unification using it?
+ unexpected(this_file, "warn_switch_for_ite_cond: foreign type")
+ ;
+ TypeBody = hlds_solver_type(_, _),
+ % Any unifications on constrained variables should be done on the
+ % representation type, and the type of the variable in the unification
+ % should be the representation type, not the solver type.
+ unexpected(this_file, "warn_switch_for_ite_cond: solver type")
+ ).
+
:- pred simplify_goal_2_neg(
hlds_goal_expr::in(goal_expr_neg), hlds_goal_expr::out,
hlds_goal_info::in, hlds_goal_info::out,
@@ -2921,7 +3110,14 @@
% Don't warn where the initial goal was fail, since that can result
% from mode analysis pruning away cases in a switch which cannot
% succeed due to sub-typing in the modes.
- Goal0 \= hlds_goal(disj([]), _)
+ Goal0 \= hlds_goal(disj([]), _),
+ % Don't warn if the code was duplicated, since it is quite likely
+ % to be spurious: though the disjunct cannot succeed in this arm of
+ % the switch, it likely can succeed in other arms that derive from
+ % the exact same piece of source code.
+ simplify_info_get_inside_duplicated_for_switch(!.Info,
+ InsideDuplForSwitch),
+ InsideDuplForSwitch = no
->
Context = goal_info_get_context(GoalInfo),
Pieces = [words("Warning: this disjunct"),
Index: compiler/size_prof.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/size_prof.m,v
retrieving revision 1.53
diff -u -r1.53 size_prof.m
--- compiler/size_prof.m 7 Aug 2007 07:10:04 -0000 1.53
+++ compiler/size_prof.m 22 Nov 2007 03:04:47 -0000
@@ -283,24 +283,35 @@
(
GoalExpr0 = unify(LHS, RHS, UniMode, Unify0, UnifyContext),
(
- Unify0 = construct(Var, ConsId, Args, ArgModes, How, Unique, _)
- ->
+ Unify0 = construct(Var, ConsId, Args, ArgModes, How, Unique, _),
process_construct(LHS, RHS, UniMode, UnifyContext, Var, ConsId,
Args, ArgModes, How, Unique, GoalInfo0, GoalExpr, !Info)
;
Unify0 = deconstruct(Var, ConsId, Args, ArgModes,
_CanFail, _CanCGC),
- % The following test is an optimization. If
- % BindingArgModes = [], which is almost 100% likely,
- % then process_deconstruct would return GoalExpr0 as
- % GoalExpr anyway, but would take longer.
- list.filter(binds_arg_in_cell(!.Info), ArgModes, BindingArgModes),
- BindingArgModes \= []
- ->
- process_deconstruct(Var, ConsId, Args, ArgModes,
- Goal0, GoalExpr, !Info)
+ (
+ % The following test is an optimization. If
+ % BindingArgModes = [], which is almost 100% likely,
+ % then process_deconstruct would return GoalExpr0 as
+ % GoalExpr anyway, but would take longer.
+ list.filter(binds_arg_in_cell(!.Info), ArgModes,
+ BindingArgModes),
+ BindingArgModes = [_ | _]
+ ->
+ process_deconstruct(Var, ConsId, Args, ArgModes,
+ Goal0, GoalExpr, !Info)
+ ;
+ GoalExpr = GoalExpr0
+ )
;
+ ( Unify0 = assign(_, _)
+ ; Unify0 = simple_test(_, _)
+ ),
GoalExpr = GoalExpr0
+ ;
+ Unify0 = complicated_unify(_, _, _),
+ % These should have been expanded out by now.
+ unexpected(this_file, "process_goal: complicated_unify")
)
;
GoalExpr0 = plain_call(_, _, _, _, _, _),
Index: compiler/source_file_map.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/source_file_map.m,v
retrieving revision 1.23
diff -u -r1.23 source_file_map.m
--- compiler/source_file_map.m 7 May 2007 06:59:24 -0000 1.23
+++ compiler/source_file_map.m 21 Nov 2007 15:40:56 -0000
@@ -165,7 +165,13 @@
)
;
CharRes = eof,
- Result = ( Chars0 = [] -> eof ; ok(Chars0) )
+ (
+ Chars0 = [],
+ Result = eof
+ ;
+ Chars0 = [_ | _],
+ Result = ok(Chars0)
+ )
;
CharRes = error(Error),
Result = error(Error)
Index: compiler/stack_alloc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_alloc.m,v
retrieving revision 1.23
diff -u -r1.23 stack_alloc.m
--- compiler/stack_alloc.m 7 Aug 2007 07:10:05 -0000 1.23
+++ compiler/stack_alloc.m 21 Nov 2007 10:57:31 -0000
@@ -236,9 +236,13 @@
allocate_same_stack_slot([], _CodeModel, _Slot, !StackSlots).
allocate_same_stack_slot([Var | Vars], CodeModel, Slot, !StackSlots) :-
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
Locn = nondet_slot(Slot)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
Locn = det_slot(Slot)
),
svmap.det_insert(Var, Locn, !StackSlots),
Index: compiler/stack_layout.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_layout.m,v
retrieving revision 1.138
diff -u -r1.138 stack_layout.m
--- compiler/stack_layout.m 12 Sep 2007 06:21:08 -0000 1.138
+++ compiler/stack_layout.m 21 Nov 2007 13:31:37 -0000
@@ -1134,9 +1134,13 @@
get_name_from_live_value_type(LiveType1, Name1),
get_name_from_live_value_type(LiveType2, Name2),
compare(NameResult, Name1, Name2),
- ( NameResult = (=) ->
+ (
+ NameResult = (=),
compare(Result, Lval1, Lval2)
;
+ ( NameResult = (<)
+ ; NameResult = (>)
+ ),
Result = NameResult
)
),
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.34
diff -u -r1.34 stack_opt.m
--- compiler/stack_opt.m 7 Aug 2007 07:10:05 -0000 1.34
+++ compiler/stack_opt.m 21 Nov 2007 13:39:47 -0000
@@ -491,9 +491,10 @@
( list.all_same(PathViaCellVars) ->
BenefitNodeSets = BenefitNodeSets0,
CostNodeSets = CostNodeSets0,
- ( PathViaCellVars = [ViaCellVarsPrime | _] ->
- ViaCellVars = ViaCellVarsPrime
+ (
+ PathViaCellVars = [ViaCellVars | _]
;
+ PathViaCellVars = [],
ViaCellVars = set.init
)
;
@@ -647,17 +648,21 @@
close_path(Path0) = Path :-
Path0 = path(FlushState, CurSegment, FirstSegment0, OtherSegments0,
FlushAnchors, IntervalIds),
- ( FlushState = current_is_before_first_flush ->
+ (
+ FlushState = current_is_before_first_flush,
expect(set.empty(FirstSegment0), this_file,
"close_path: FirstSegment0 not empty"),
FirstSegment = CurSegment,
OtherSegments = OtherSegments0
- ; set.empty(CurSegment) ->
- FirstSegment = FirstSegment0,
- OtherSegments = OtherSegments0
;
- FirstSegment = FirstSegment0,
- OtherSegments = [CurSegment | OtherSegments0]
+ FlushState = current_is_after_first_flush,
+ ( set.empty(CurSegment) ->
+ FirstSegment = FirstSegment0,
+ OtherSegments = OtherSegments0
+ ;
+ FirstSegment = FirstSegment0,
+ OtherSegments = [CurSegment | OtherSegments0]
+ )
),
Path = path(current_is_after_first_flush, set.init,
FirstSegment, OtherSegments, FlushAnchors, IntervalIds).
@@ -691,11 +696,17 @@
resume_save_status_requires_close(ResumeSaveStatus) :-
map.lookup(IntervalInfo ^ branch_resume_map, GoalPath, ResumeSaveStatus).
anchor_requires_close(_, anchor_cond_then(_)) = no.
-anchor_requires_close(_, anchor_branch_end(BranchConstruct, _)) =
- ( BranchConstruct = branch_neg ->
- no
+anchor_requires_close(_, anchor_branch_end(BranchType, _)) = NeedsClose :-
+ (
+ BranchType = branch_neg,
+ NeedsClose = no
;
- yes
+ ( BranchType = branch_ite
+ ; BranchType = branch_disj
+ ; BranchType = branch_switch
+ ; BranchType = branch_par_conj
+ ),
+ NeedsClose = yes
).
anchor_requires_close(_, anchor_call_site(_)) = yes.
@@ -726,11 +737,17 @@
may_have_more_successors(anchor_proc_start) = no.
may_have_more_successors(anchor_proc_end) = no.
-may_have_more_successors(anchor_branch_start(BranchType, _)) =
- ( BranchType = branch_neg ->
- no
+may_have_more_successors(anchor_branch_start(BranchType, _)) = MaybeHaveMore :-
+ (
+ BranchType = branch_neg,
+ MaybeHaveMore = no
;
- yes
+ ( BranchType = branch_ite
+ ; BranchType = branch_disj
+ ; BranchType = branch_switch
+ ; BranchType = branch_par_conj
+ ),
+ MaybeHaveMore = yes
).
may_have_more_successors(anchor_cond_then(_)) = no.
may_have_more_successors(anchor_branch_end(_, _)) = no.
@@ -816,12 +833,14 @@
find_all_branches_from(End, RelevantVars, MaybeSearchAnchor0, IntervalInfo,
StackOptInfo, SuccessorIds, !AllPaths) :-
- ( anchor_requires_close(IntervalInfo, End) = yes ->
+ AnchorRequiresClose = anchor_requires_close(IntervalInfo, End),
+ (
+ AnchorRequiresClose = yes,
Paths0 = !.AllPaths ^ paths_so_far,
Paths1 = set.map(close_path, Paths0),
!:AllPaths = !.AllPaths ^ paths_so_far := Paths1
;
- true
+ AnchorRequiresClose = no
),
StackOptParams = StackOptInfo ^ stack_opt_params,
FullPath = StackOptParams ^ full_path,
Index: compiler/store_alloc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/store_alloc.m,v
retrieving revision 1.105
diff -u -r1.105 store_alloc.m
--- compiler/store_alloc.m 7 Aug 2007 07:10:05 -0000 1.105
+++ compiler/store_alloc.m 21 Nov 2007 13:40:43 -0000
@@ -72,7 +72,8 @@
allocate_store_maps(RunType, PredId, ModuleInfo, !ProcInfo) :-
module_info_get_globals(ModuleInfo, Globals),
- ( RunType = final_allocation ->
+ (
+ RunType = final_allocation,
proc_info_get_goal(!.ProcInfo, Goal0),
find_final_follow_vars(!.ProcInfo, FollowVarsMap0, NextNonReserved0),
@@ -84,6 +85,7 @@
goal_info_set_follow_vars(yes(FollowVars), GoalInfo1, GoalInfo2),
Goal2 = hlds_goal(GoalExpr1, GoalInfo2)
;
+ RunType = for_stack_opt,
proc_info_get_goal(!.ProcInfo, Goal2)
),
initial_liveness(!.ProcInfo, PredId, ModuleInfo, Liveness0),
@@ -330,9 +332,10 @@
:- pred merge_last_locations(list(last_locns)::in, last_locns::out) is det.
merge_last_locations(LastLocnsList, LastLocns) :-
- ( LastLocnsList = [LastLocnsPrime | _] ->
- LastLocns = LastLocnsPrime
+ (
+ LastLocnsList = [LastLocns | _]
;
+ LastLocnsList = [],
LastLocns = map.init
).
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.62
diff -u -r1.62 stratify.m
--- compiler/stratify.m 7 Sep 2007 15:08:18 -0000 1.62
+++ compiler/stratify.m 21 Nov 2007 08:04:03 -0000
@@ -547,7 +547,7 @@
;
CHOInOut = ho_none,
% XXX : what is a good message for this?
- unexpected(this_file, "merge_calls : this cannot happen!")
+ unexpected(this_file, "merge_calls: this cannot happen!")
),
NewCInfo = info(CHaveAT, CHOInOut),
NewPInfo = info(PHaveAT, PHOInOut),
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.136
diff -u -r1.136 switch_detection.m
--- compiler/switch_detection.m 19 Nov 2007 06:11:17 -0000 1.136
+++ compiler/switch_detection.m 21 Nov 2007 08:11:11 -0000
@@ -480,11 +480,13 @@
;
ConjGoals = [FirstGoal | RestGoals],
FirstGoal = hlds_goal(FirstGoalExpr, _),
- ( FirstGoalExpr = unify(_, _, _, _, _) ->
+ (
+ FirstGoalExpr = unify(_, _, _, _, _),
!:RevUnifies = [FirstGoal | !.RevUnifies],
expand_sub_disj_process_conj(Var, RestGoals, !.RevUnifies,
GoalInfo, !Cases)
- ; FirstGoalExpr = disj(Disjuncts) ->
+ ;
+ FirstGoalExpr = disj(Disjuncts),
Disjuncts = [_ | _],
list.reverse(!.RevUnifies, Unifies),
list.map(
@@ -492,8 +494,6 @@
Disjuncts, ExpandedConjunctions),
partition_disj_trial(ExpandedConjunctions, Var, [], Left, !Cases),
Left = []
- ;
- fail
)
).
@@ -599,28 +599,31 @@
FoundDeconstruct) :-
Goal0 = hlds_goal(GoalExpr0, GoalInfo),
(
- GoalExpr0 = scope(Reason, SubGoal0)
- ->
+ GoalExpr0 = scope(Reason, SubGoal0),
find_bind_var_2(Var, ProcessUnify, SubGoal0, SubGoal, !Subst,
!Result, !Info, FoundDeconstruct),
Goal = hlds_goal(scope(Reason, SubGoal), GoalInfo)
;
GoalExpr0 = conj(ConjType, SubGoals0),
- ConjType = plain_conj
- ->
(
- SubGoals0 = [],
- Goal = Goal0,
- FoundDeconstruct = before_deconstruct
+ ConjType = plain_conj,
+ (
+ SubGoals0 = [],
+ Goal = Goal0,
+ FoundDeconstruct = before_deconstruct
+ ;
+ SubGoals0 = [_ | _],
+ conj_find_bind_var(Var, ProcessUnify, SubGoals0, SubGoals,
+ !Subst, !Result, !Info, FoundDeconstruct),
+ Goal = hlds_goal(conj(ConjType, SubGoals), GoalInfo)
+ )
;
- SubGoals0 = [_ | _],
- conj_find_bind_var(Var, ProcessUnify, SubGoals0, SubGoals,
- !Subst, !Result, !Info, FoundDeconstruct),
- Goal = hlds_goal(conj(ConjType, SubGoals), GoalInfo)
+ ConjType = parallel_conj,
+ Goal = Goal0,
+ FoundDeconstruct = given_up_search
)
;
- GoalExpr0 = unify(LHS, RHS, _, UnifyInfo0, _)
- ->
+ GoalExpr0 = unify(LHS, RHS, _, UnifyInfo0, _),
(
% Check whether the unification is a deconstruction unification
% on either Var or on a variable aliased to Var.
@@ -646,12 +649,23 @@
)
)
;
+ ( GoalExpr0 = plain_call(_, _, _, _, _, _)
+ ; GoalExpr0 = generic_call(_, _, _, _)
+ ; GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _)
+ ; GoalExpr0 = disj(_)
+ ; GoalExpr0 = switch(_, _, _)
+ ; GoalExpr0 = negation(_)
+ ; GoalExpr0 = if_then_else(_, _, _, _)
+ ),
Goal = Goal0,
( goal_info_has_feature(GoalInfo, feature_from_head) ->
FoundDeconstruct = before_deconstruct
;
FoundDeconstruct = given_up_search
)
+ ;
+ GoalExpr0 = shorthand(_),
+ unexpected(this_file, "find_bind_var_2: shorthand")
).
:- pred conj_find_bind_var(prog_var::in,
@@ -666,10 +680,14 @@
!Subst, !Result, !Info, FoundDeconstruct) :-
find_bind_var_2(Var, ProcessUnify, Goal0, Goal, !Subst,
!Result, !Info, FoundDeconstruct1),
- ( FoundDeconstruct1 = before_deconstruct ->
+ (
+ FoundDeconstruct1 = before_deconstruct,
conj_find_bind_var(Var, ProcessUnify, Goals0, Goals,
!Subst, !Result, !Info, FoundDeconstruct)
;
+ ( FoundDeconstruct1 = found_deconstruct
+ ; FoundDeconstruct1 = given_up_search
+ ),
FoundDeconstruct = FoundDeconstruct1,
Goals = Goals0
).
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.38
diff -u -r1.38 switch_util.m
--- compiler/switch_util.m 11 Sep 2007 03:12:33 -0000 1.38
+++ compiler/switch_util.m 21 Nov 2007 06:09:46 -0000
@@ -312,10 +312,16 @@
module_info_get_type_table(ModuleInfo, TypeTable),
map.lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- ( ConsTable = TypeBody ^ du_type_cons_tag_values ->
+ (
+ TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _),
map.count(ConsTable, TypeRange),
MaxEnum = TypeRange - 1
;
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
unexpected(this_file, "type_range: enum type is not d.u. type?")
).
@@ -332,11 +338,17 @@
),
module_info_get_type_table(ModuleInfo, TypeTable),
map.lookup(TypeTable, TypeCtor, TypeDefn),
- hlds_data.get_type_defn_body(TypeDefn, Body),
- ( ConsTable = Body ^ du_type_cons_tag_values ->
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
+ (
+ TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _),
map.to_assoc_list(ConsTable, ConsList),
assoc_list.values(ConsList, TagList)
;
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
unexpected(this_file, "non-du type in get_ptag_counts")
),
map.init(PtagCountMap0),
@@ -362,9 +374,12 @@
int.max(Primary, !MaxPrimary),
( map.search(!.PtagCountMap, Primary, Target) ->
Target = TagType - MaxSoFar,
- ( TagType = sectag_remote ->
- true
+ (
+ TagType = sectag_remote
;
+ ( TagType = sectag_local
+ ; TagType = sectag_none
+ ),
unexpected(this_file, "remote tag is shared with non-remote")
),
int.max(Secondary, MaxSoFar, Max),
@@ -377,9 +392,12 @@
int.max(Primary, !MaxPrimary),
( map.search(!.PtagCountMap, Primary, Target) ->
Target = TagType - MaxSoFar,
- ( TagType = sectag_local ->
- true
+ (
+ TagType = sectag_local
;
+ ( TagType = sectag_remote
+ ; TagType = sectag_none
+ ),
unexpected(this_file, "local tag is shared with non-local")
),
int.max(Secondary, MaxSoFar, Max),
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.140
diff -u -r1.140 table_gen.m
--- compiler/table_gen.m 16 Nov 2007 03:44:52 -0000 1.140
+++ compiler/table_gen.m 22 Nov 2007 03:16:40 -0000
@@ -417,13 +417,16 @@
CallStrictness = specified(ArgMethods, HiddenArgMethod),
MaybeSpecMethod = specified(ArgMethods, HiddenArgMethod)
),
- ( EvalMethod = eval_minimal(_) ->
+ (
+ EvalMethod = eval_loop_check
+ ;
+ EvalMethod = eval_memo
+ ;
+ EvalMethod = eval_minimal(_),
expect(unify(MaybeSizeLimit, no), this_file,
"eval_minimal with size limit"),
expect(unify(MaybeSpecMethod, all_same(arg_value)), this_file,
"eval_minimal without all_strict")
- ;
- true
)
),
get_input_output_vars(HeadVars, ArgModes, !.ModuleInfo, MaybeSpecMethod, _,
@@ -456,7 +459,8 @@
MaybeProcTableStructInfo = yes(ProcTableStructInfo)
;
EvalMethod = eval_memo,
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
create_new_memo_non_goal(Detism, OrigGoal, Statistics,
MaybeSizeLimit, PredId, ProcId,
HeadVars, NumberedInputVars, NumberedOutputVars,
@@ -464,6 +468,9 @@
CallTableTip, Goal, InputSteps, OutputSteps),
MaybeOutputSteps = yes(OutputSteps)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
create_new_memo_goal(Detism, OrigGoal, Statistics, MaybeSizeLimit,
PredId, ProcId,
HeadVars, NumberedInputVars, NumberedOutputVars,
@@ -3058,9 +3065,13 @@
table_generate_call(PredName, Detism, Args, Purity, InstMapSrc, ModuleInfo,
Context, Goal) :-
BuiltinModule = mercury_table_builtin_module,
- ( Purity = purity_pure ->
+ (
+ Purity = purity_pure,
Features0 = []
;
+ ( Purity = purity_semipure
+ ; Purity = purity_impure
+ ),
Features0 = [feature_not_impure_for_determinism]
),
( Detism = detism_failure ->
@@ -3080,9 +3091,13 @@
table_generate_foreign_proc(PredName, Detism, Attributes, Args, ExtraArgs,
Code, Purity, InstMapSrc, ModuleInfo, Context, Goal) :-
- ( Purity = purity_pure ->
+ (
+ Purity = purity_pure,
Features0 = []
;
+ ( Purity = purity_semipure
+ ; Purity = purity_impure
+ ),
Features0 = [feature_not_impure_for_determinism]
),
( Detism = detism_failure ->
Index: compiler/tabling_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/tabling_analysis.m,v
retrieving revision 1.9
diff -u -r1.9 tabling_analysis.m
--- compiler/tabling_analysis.m 19 Jan 2007 07:04:32 -0000 1.9
+++ compiler/tabling_analysis.m 22 Nov 2007 03:16:11 -0000
@@ -5,15 +5,15 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: tabling_analysis.m.
% Author: juliensf.
-%
+%
% This module contains an analysis that identifies those goals that cannot
% call minimal model tabled procedures. We can optimize the code generated
% for such goals by omitting any pneg context wrappers (see ite_gen.m).
% The analysis has two passes.
-%
+%
% The first pass marks each procedure in the module as one of:
%
% * mm_tabled_will_not_call
@@ -21,7 +21,7 @@
% * mm_tabled_conditional
%
% Procedures marked `mm_tabled_will_not_call' are guaranteed not to call
-% procedures that are minimal model tabled (or use minimal model tabling
+% procedures that are minimal model tabled (or use minimal model tabling
% themselves), while procedures marked `mm_tabled_may_call' may call procedures
% that are minimal model tabled (or use it themselves).
%
@@ -37,11 +37,11 @@
% For procedures defined using the foreign language interface we rely upon
% the foreign_proc attributes `will_not_call_mm_tabled' and
% `may_call_mm_tabled'.
-%
+%
% The second pass of the analysis marks individual goals with a feature
% that indicates that they do not call minimal model tabled procedures.
% This pass is only run when we are generating code.
-%
+%
% TODO
% - improve handle higher-order constructs / type class method calls
% - handle user-defined equality and comparison correctly
@@ -59,8 +59,8 @@
:- import_module io.
%----------------------------------------------------------------------------%
-
- % Analyse minimal model tabling in a module.
+
+ % Analyse minimal model tabling in a module.
%
:- pred analyse_mm_tabling_in_module(module_info::in, module_info::out,
io::di, io::uo) is det.
@@ -69,7 +69,7 @@
%
:- pred write_pragma_mm_tabling_info(module_info::in, mm_tabling_info::in,
pred_id::in, io::di, io::uo) is det.
-
+
%----------------------------------------------------------------------------%
%
% Types and instances for the intermodule analysis framework
@@ -140,7 +140,7 @@
make_opt_int(!.ModuleInfo, !IO)
;
MakeOptInt = no
- )
+ )
;
UseMinimalModel = no
).
@@ -226,7 +226,7 @@
combine_individual_proc_results([], _, _) :-
unexpected(this_file, "Empty SCC during mm tabling analysis.").
combine_individual_proc_results(ProcResults @ [_ | _], SCC_Result,
- MaybeAnalysisStatus) :-
+ MaybeAnalysisStatus) :-
(
% If none of the procedures calls tabled procedures or is conditional
% then the SCC cannot call tabled procedures.
@@ -253,7 +253,7 @@
:- pred combine_proc_result_maybe_analysis_statuses(proc_results::in,
maybe(analysis_status)::out) is det.
-combine_proc_result_maybe_analysis_statuses(ProcResults,
+combine_proc_result_maybe_analysis_statuses(ProcResults,
MaybeAnalysisStatus) :-
list.map(maybe_analysis_status, ProcResults, MaybeAnalysisStatuses),
list.foldl(combine_maybe_analysis_status, MaybeAnalysisStatuses,
@@ -276,10 +276,16 @@
check_proc_for_mm_tabling(SCC, PPId, !Results, !ModuleInfo, !IO) :-
module_info_pred_proc_info(!.ModuleInfo, PPId, _, ProcInfo),
proc_info_get_eval_method(ProcInfo, EvalMethod),
- ( EvalMethod = eval_minimal(_) ->
+ (
+ EvalMethod = eval_minimal(_),
Result = mm_tabled_may_call,
MaybeAnalysisStatus = yes(optimal)
;
+ ( EvalMethod = eval_normal
+ ; EvalMethod = eval_loop_check
+ ; EvalMethod = eval_memo
+ ; EvalMethod = eval_table_io(_, _)
+ ),
proc_info_get_goal(ProcInfo, Body),
proc_info_get_vartypes(ProcInfo, VarTypes),
check_goal_for_mm_tabling(SCC, VarTypes, Body, Result,
@@ -294,7 +300,7 @@
:- pred check_goal_for_mm_tabling(scc::in, vartypes::in, hlds_goal::in,
mm_tabling_status::out, maybe(analysis_status)::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out, io::di, io::uo) is det.
check_goal_for_mm_tabling(SCC, VarTypes, hlds_goal(GoalExpr, GoalInfo),
Result, MaybeStatus, !ModuleInfo, !IO) :-
@@ -308,10 +314,15 @@
check_goal_for_mm_tabling_2(_, _, Goal, _, mm_tabled_will_not_call,
yes(optimal), !ModuleInfo, !IO) :-
Goal = unify(_, _, _, Kind, _),
- ( Kind = complicated_unify(_, _, _) ->
+ (
+ Kind = complicated_unify(_, _, _),
unexpected(this_file, "complicated unify during mm tabling analysis.")
;
- true
+ ( Kind = construct(_, _, _, _, _, _, _)
+ ; Kind = deconstruct(_, _, _, _, _, _)
+ ; Kind = assign(_, _)
+ ; Kind = simple_test(_, _)
+ )
).
check_goal_for_mm_tabling_2(SCC, VarTypes, Goal, _, Result,
MaybeAnalysisStatus, !ModuleInfo, !IO) :-
@@ -373,7 +384,7 @@
%----------------------------------------------------------------------------%
%
% Code for checking calls
-%
+%
:- pred check_call_for_mm_tabling(pred_proc_id::in, prog_vars::in,
scc::in, vartypes::in, mm_tabling_status::out, maybe(analysis_status)::out,
@@ -391,11 +402,11 @@
Result = mm_tabled_will_not_call,
MaybeAnalysisStatus = yes(optimal)
;
- pred_info_is_builtin(CalleePredInfo)
+ pred_info_is_builtin(CalleePredInfo)
->
Result = mm_tabled_will_not_call,
MaybeAnalysisStatus = yes(optimal)
- ;
+ ;
% Handle builtin unify and compare.
%
% NOTE: the type specific unify and compare predicates are just
@@ -417,7 +428,7 @@
Result = mm_tabled_may_call,
MaybeAnalysisStatus = yes(optimal)
;
- % Handle normal calls.
+ % Handle normal calls.
globals.io_lookup_bool_option(intermodule_analysis, Intermod, !IO),
(
Intermod = yes,
@@ -425,13 +436,17 @@
->
% Use the intermodule analysis framework if this is an imported
% procedure and `--intermodule-analysis' is enabled.
- %
+ %
search_analysis_status(CalleePPId, Result0, AnalysisStatus, SCC,
!ModuleInfo, !IO),
- ( Result0 = mm_tabled_conditional ->
+ (
+ Result0 = mm_tabled_conditional,
% XXX user-defined uc
Result = mm_tabled_will_not_call
;
+ ( Result0 = mm_tabled_may_call
+ ; Result0 = mm_tabled_will_not_call
+ ),
Result = Result0
),
MaybeAnalysisStatus = yes(AnalysisStatus)
@@ -499,8 +514,8 @@
:- func get_mm_tabling_status_from_attributes(pragma_foreign_proc_attributes)
= mm_tabling_status.
-get_mm_tabling_status_from_attributes(Attributes) =
- (
+get_mm_tabling_status_from_attributes(Attributes) =
+ (
(
get_may_call_mm_tabled(Attributes) = will_not_call_mm_tabled
;
@@ -508,9 +523,9 @@
get_may_call_mercury(Attributes) = proc_will_not_call_mercury
)
->
- mm_tabled_will_not_call
+ mm_tabled_will_not_call
;
- mm_tabled_may_call
+ mm_tabled_may_call
).
%----------------------------------------------------------------------------%
@@ -563,7 +578,7 @@
%
% Code for attaching tabling analysis information to goals
%
-
+
% Traverse the body of the procedure and attach the
% `will_not_call_mm_tabled' feature to the goal_infos of those goals that
% do not make calls to minimal model tabled procedures.
@@ -576,7 +591,7 @@
module_info_pred_proc_info(!.ModuleInfo, PPId, PredInfo, !:ProcInfo),
proc_info_get_goal(!.ProcInfo, !:Body),
proc_info_get_vartypes(!.ProcInfo, VarTypes),
- annotate_goal(VarTypes, !Body, _Status, !ModuleInfo, !IO),
+ annotate_goal(VarTypes, !Body, _Status, !ModuleInfo, !IO),
proc_info_set_goal(!.Body, !ProcInfo),
module_info_set_pred_proc_info(PPId, PredInfo, !.ProcInfo, !ModuleInfo)
).
@@ -588,14 +603,18 @@
annotate_goal(VarTypes, !Goal, Status, !ModuleInfo, !IO) :-
!.Goal = hlds_goal(GoalExpr0, GoalInfo0),
annotate_goal_2(VarTypes, GoalExpr0, GoalExpr, Status, !ModuleInfo, !IO),
- ( Status = mm_tabled_will_not_call ->
+ (
+ Status = mm_tabled_will_not_call,
goal_info_add_feature(feature_will_not_call_mm_tabled,
GoalInfo0, GoalInfo)
;
+ ( Status = mm_tabled_may_call
+ ; Status = mm_tabled_conditional
+ ),
GoalInfo = GoalInfo0
),
!:Goal = hlds_goal(GoalExpr, GoalInfo).
-
+
:- pred annotate_goal_2(vartypes::in, hlds_goal_expr::in, hlds_goal_expr::out,
mm_tabling_status::out, module_info::in, module_info::out, io::di, io::uo)
is det.
@@ -604,7 +623,7 @@
!.Goal = conj(ConjType, Conjuncts0),
annotate_goal_list(VarTypes, Conjuncts0, Conjuncts, Status, !ModuleInfo,
!IO),
- !:Goal = conj(ConjType, Conjuncts).
+ !:Goal = conj(ConjType, Conjuncts).
annotate_goal_2(VarTypes, !Goal, Status, !ModuleInfo, !IO) :-
!.Goal = plain_call(CalleePredId, CalleeProcId, CallArgs, _, _, _),
CalleePPId = proc(CalleePredId, CalleeProcId),
@@ -618,10 +637,15 @@
!:Goal = switch(Var, CanFail, Cases).
annotate_goal_2(_VarTypes, !Goal, Status, !ModuleInfo, !IO) :-
!.Goal = unify(_, _, _, Kind, _),
- ( Kind = complicated_unify(_, _, _) ->
+ (
+ Kind = complicated_unify(_, _, _),
unexpected(this_file, "complicated unify during tabling analysis.")
;
- true
+ ( Kind = construct(_, _, _, _, _, _, _)
+ ; Kind = deconstruct(_, _, _, _, _, _)
+ ; Kind = assign(_, _)
+ ; Kind = simple_test(_, _)
+ )
),
Status = mm_tabled_will_not_call.
annotate_goal_2(VarTypes, !Goal, Status, !ModuleInfo, !IO) :-
@@ -650,24 +674,24 @@
Status = mm_tabled_will_not_call
;
Status = mm_tabled_may_call
- ),
+ ),
!:Goal = if_then_else(Vars, If, Then, Else).
annotate_goal_2(_, !Goal, Status, !ModuleInfo, !IO) :-
!.Goal = call_foreign_proc(Attributes, _, _, _, _, _, _),
Status = get_mm_tabling_status_from_attributes(Attributes).
annotate_goal_2(_, shorthand(_), _, _, _, _, _, _) :-
unexpected(this_file, "shorthand goal").
-
+
:- pred annotate_goal_list(vartypes::in, hlds_goals::in, hlds_goals::out,
mm_tabling_status::out, module_info::in, module_info::out, io::di, io::uo)
is det.
annotate_goal_list(VarTypes, !Goals, Status, !ModuleInfo, !IO) :-
list.map2_foldl2(annotate_goal(VarTypes), !Goals, Statuses, !ModuleInfo,
- !IO),
+ !IO),
list.foldl(combine_mm_tabling_status, Statuses, mm_tabled_will_not_call,
Status).
-
+
:- pred annotate_cases(vartypes::in, list(case)::in, list(case)::out,
mm_tabling_status::out, module_info::in, module_info::out,
io::di, io::uo) is det.
@@ -719,23 +743,31 @@
(
IntermodAnalysis = yes,
pred_info_is_imported(CalleePredInfo)
- ->
+ ->
% NOTE: we set the value of SCC to a dummy value here.
% This is okay because it only needs a meaningful value when
% building the analysis files; it won't be used when compiling to
% target code.
- SCC = [],
+ SCC = [],
search_analysis_status(CalleePPId, Result, AnalysisStatus, SCC,
!ModuleInfo, !IO),
-
- ( AnalysisStatus = invalid ->
+
+ (
+ AnalysisStatus = invalid,
unexpected(this_file,
"invalid analysis result while annotating goals")
;
+ ( AnalysisStatus = optimal
+ ; AnalysisStatus = suboptimal
+ ),
% XXX user-defined uc
- ( Result = mm_tabled_conditional ->
+ (
+ Result = mm_tabled_conditional,
Status = mm_tabled_will_not_call
;
+ ( Result = mm_tabled_may_call
+ ; Result = mm_tabled_will_not_call
+ ),
Status = Result
)
)
@@ -763,10 +795,10 @@
;
GenericCall = class_method(_, _, _, _),
Status = mm_tabled_may_call
- ;
+ ;
GenericCall = event_call(_),
Status = mm_tabled_will_not_call
- ;
+ ;
GenericCall = cast(_),
Status = mm_tabled_will_not_call
).
@@ -774,7 +806,7 @@
%----------------------------------------------------------------------------%
%
% Stuff for intermodule optimization
-%
+%
:- pred make_opt_int(module_info::in, io::di, io::uo) is det.
@@ -791,8 +823,8 @@
(
OptFileRes = ok(OptFile),
io.set_output_stream(OptFile, OldStream, !IO),
- module_info_get_mm_tabling_info(ModuleInfo, TablingInfo),
- module_info_predids(PredIds, ModuleInfo, _ModuleInfo),
+ module_info_get_mm_tabling_info(ModuleInfo, TablingInfo),
+ module_info_predids(PredIds, ModuleInfo, _ModuleInfo),
list.foldl(write_pragma_mm_tabling_info(ModuleInfo, TablingInfo),
PredIds, !IO),
io.set_output_stream(OldStream, _, !IO),
@@ -805,12 +837,12 @@
io.write_strings(["Error opening file `",
OptFileName, "' for output: ", IOErrorMessage], !IO),
io.set_exit_status(1, !IO)
- ).
+ ).
write_pragma_mm_tabling_info(ModuleInfo, TablingInfo, PredId, !IO) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
should_write_mm_tabling_info(ModuleInfo, PredId, PredInfo, ShouldWrite),
- (
+ (
ShouldWrite = yes,
ModuleName = pred_info_module(PredInfo),
Name = pred_info_name(PredInfo),
@@ -819,11 +851,11 @@
ProcIds = pred_info_procids(PredInfo),
OutputPragma = (pred(ProcId::in, !.IO::di, !:IO::uo) is det :-
proc_id_to_int(ProcId, ModeNum),
- (
+ (
map.search(TablingInfo, proc(PredId, ProcId), ProcTablingInfo),
ProcTablingInfo = proc_mm_tabling_info(Status, _)
->
- mercury_output_pragma_mm_tabling_info(PredOrFunc,
+ mercury_output_pragma_mm_tabling_info(PredOrFunc,
qualified(ModuleName, Name), Arity, ModeNum, Status, !IO)
;
true
@@ -832,16 +864,16 @@
list.foldl(OutputPragma, ProcIds, !IO)
;
ShouldWrite = no
- ).
+ ).
-:- pred should_write_mm_tabling_info(module_info::in, pred_id::in,
+:- pred should_write_mm_tabling_info(module_info::in, pred_id::in,
pred_info::in, bool::out) is det.
should_write_mm_tabling_info(ModuleInfo, PredId, PredInfo, ShouldWrite) :-
pred_info_get_import_status(PredInfo, ImportStatus),
- (
- ( ImportStatus = status_exported
- ; ImportStatus = status_opt_exported
+ (
+ ( ImportStatus = status_exported
+ ; ImportStatus = status_opt_exported
),
not is_unify_or_compare_pred(PredInfo),
module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo),
@@ -859,7 +891,7 @@
ShouldWrite = yes
;
ShouldWrite = no
- ).
+ ).
%-----------------------------------------------------------------------------%
%
@@ -1009,7 +1041,7 @@
),
list.foldl(RecordDependency, CallerSCC, !AnalysisInfo).
-:- pred record_mm_tabling_analysis_results(mm_tabling_status::in,
+:- pred record_mm_tabling_analysis_results(mm_tabling_status::in,
analysis_status::in, scc::in, module_info::in, module_info::out) is det.
record_mm_tabling_analysis_results(Status, ResultStatus, SCC, !ModuleInfo) :-
@@ -1027,7 +1059,7 @@
PPId @ proc(PredId, _ProcId), !AnalysisInfo) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
should_write_mm_tabling_info(ModuleInfo, PredId, PredInfo, ShouldWrite),
- (
+ (
ShouldWrite = yes,
mmc_analysis.module_id_func_id(ModuleInfo, PPId, ModuleId, FuncId),
Answer = mm_tabling_analysis_answer(Status),
@@ -1041,7 +1073,7 @@
%
% Code for printing out debugging traces
%
-
+
:- pred dump_mm_tabling_analysis_debug_info(module_info::in, scc::in,
mm_tabling_status::in, io::di, io::uo) is det.
@@ -1061,7 +1093,7 @@
is det.
output_proc_name(Moduleinfo, PPId, !IO) :-
- Pieces = describe_one_proc_name(Moduleinfo, should_module_qualify, PPId),
+ Pieces = describe_one_proc_name(Moduleinfo, should_module_qualify, PPId),
Str = error_pieces_to_string(Pieces),
io.format("\t%s\n", [s(Str)], !IO).
Index: compiler/tag_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/tag_switch.m,v
retrieving revision 1.79
diff -u -r1.79 tag_switch.m
--- compiler/tag_switch.m 27 Sep 2007 10:42:06 -0000 1.79
+++ compiler/tag_switch.m 21 Nov 2007 13:52:34 -0000
@@ -610,30 +610,37 @@
label::in, label::in, branch_end::in, branch_end::out, code_tree::out,
code_info::in, code_info::out) is det.
-generate_primary_tag_code(GoalMap, Primary, MaxSecondary, StagLoc, Rval,
+generate_primary_tag_code(StagGoalMap, Primary, MaxSecondary, StagLoc, Rval,
CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, Code,
!CI) :-
- map.to_assoc_list(GoalMap, GoalList),
+ map.to_assoc_list(StagGoalMap, StagGoalList),
(
StagLoc = sectag_none,
- % There is no secondary tag, so there is no switch on it
- ( GoalList = [-1 - stag_goal(ConsId, Goal)] ->
- Comment = "case " ++ cons_id_to_string(ConsId),
- CommentCode = node([llds_instr(comment(Comment), "")]),
- maybe_generate_internal_event_code(Goal, SwitchGoalInfo, TraceCode,
- !CI),
- code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI),
- goal_info_get_store_map(SwitchGoalInfo, StoreMap),
- generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI),
- GotoCode = node([
- llds_instr(goto(code_label(EndLabel)),
- "skip to end of primary tag switch")
- ]),
- Code = tree_list([CommentCode, TraceCode, GoalCode, SaveCode,
- GotoCode])
- ; GoalList = [] ->
+ % There is no secondary tag, so there is no switch on it.
+ (
+ StagGoalList = [],
unexpected(this_file, "no goal for non-shared tag")
;
+ StagGoalList = [StagGoal],
+ ( StagGoal = -1 - stag_goal(ConsId, Goal) ->
+ Comment = "case " ++ cons_id_to_string(ConsId),
+ CommentCode = node([llds_instr(comment(Comment), "")]),
+ maybe_generate_internal_event_code(Goal, SwitchGoalInfo,
+ TraceCode, !CI),
+ code_gen.generate_goal(CodeModel, Goal, GoalCode, !CI),
+ goal_info_get_store_map(SwitchGoalInfo, StoreMap),
+ generate_branch_end(StoreMap, !MaybeEnd, SaveCode, !CI),
+ GotoCode = node([
+ llds_instr(goto(code_label(EndLabel)),
+ "skip to end of primary tag switch")
+ ]),
+ Code = tree_list([CommentCode, TraceCode, GoalCode, SaveCode,
+ GotoCode])
+ ;
+ unexpected(this_file, "badly formed goal for non-shared tag")
+ )
+ ;
+ StagGoalList = [_, _ | _],
unexpected(this_file, "more than one goal for non-shared tag")
)
;
@@ -694,9 +701,9 @@
StagRval = OrigStagRval
),
(
- list.length(GoalList, GoalCount),
+ list.length(StagGoalList, StagGoalCount),
FullGoalCount = MaxSecondary + 1,
- FullGoalCount = GoalCount
+ FullGoalCount = StagGoalCount
->
CanFail = cannot_fail
;
@@ -705,9 +712,9 @@
(
SecondaryMethod = jump_table,
- generate_secondary_jump_table(GoalList, 0, MaxSecondary, CodeModel,
- SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd, Labels,
- CasesCode, !CI),
+ generate_secondary_jump_table(StagGoalList, 0, MaxSecondary,
+ CodeModel, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd,
+ Labels, CasesCode, !CI),
SwitchCode = node([
llds_instr(computed_goto(StagRval, Labels),
"switch on secondary tag")
@@ -715,20 +722,20 @@
Code = tree(SwitchCode, CasesCode)
;
SecondaryMethod = binary_search,
- generate_secondary_binary_search(GoalList, 0, MaxSecondary,
+ generate_secondary_binary_search(StagGoalList, 0, MaxSecondary,
StagRval, CodeModel, CanFail, SwitchGoalInfo,
EndLabel, FailLabel, !MaybeEnd, Code, !CI)
;
SecondaryMethod = try_chain,
- generate_secondary_try_chain(GoalList, StagRval, CodeModel,
+ generate_secondary_try_chain(StagGoalList, StagRval, CodeModel,
CanFail, SwitchGoalInfo, EndLabel, FailLabel, empty, empty,
!MaybeEnd, Codes, !CI),
Code = tree(StagCode, Codes)
;
SecondaryMethod = try_me_else_chain,
- generate_secondary_try_me_else_chain(GoalList, StagRval, CodeModel,
- CanFail, SwitchGoalInfo, EndLabel, FailLabel, !MaybeEnd,
- Codes, !CI),
+ generate_secondary_try_me_else_chain(StagGoalList, StagRval,
+ CodeModel, CanFail, SwitchGoalInfo, EndLabel, FailLabel,
+ !MaybeEnd, Codes, !CI),
Code = tree(StagCode, Codes)
)
).
Index: compiler/term_constr_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_data.m,v
retrieving revision 1.8
diff -u -r1.8 term_constr_data.m
--- compiler/term_constr_data.m 23 May 2007 10:09:22 -0000 1.8
+++ compiler/term_constr_data.m 22 Nov 2007 05:09:03 -0000
@@ -455,23 +455,21 @@
simplify_abstract_rep(term_disj(!.Disjuncts, _Size0, Locals, NonLocals),
Goal) :-
- %
% Begin by simplifying each disjunct.
- %
+
list.map(simplify_abstract_rep, !Disjuncts),
(
- !.Disjuncts = [Disjunct]
- ->
+ !.Disjuncts = [] ,
+ Goal = term_primitive(polyhedron.universe, [], [])
+ ;
+ !.Disjuncts = [Disjunct] ,
% We need to merge the set of locals with the locals from the
% disjunct otherwise we will end up throwing away the locals
% from the enclosing goal.
%
Goal = update_local_and_nonlocal_vars(Disjunct, Locals, NonLocals)
;
- !.Disjuncts = []
- ->
- Goal = term_primitive(polyhedron.universe, [], [])
- ;
+ !.Disjuncts = [_, _ | _] ,
Size = list.length(!.Disjuncts),
Goal = term_disj(!.Disjuncts, Size, Locals, NonLocals)
).
@@ -482,12 +480,10 @@
flatten_conjuncts(!Conjuncts),
list.filter(isnt(is_empty_conj), !Conjuncts),
( !.Conjuncts = [Conjunct] ->
- %
% The local/non-local var sets need to be updated for similar
% reasons as we do with disjunctions.
- %
- Goal = update_local_and_nonlocal_vars(Conjunct, Locals,
- NonLocals)
+
+ Goal = update_local_and_nonlocal_vars(Conjunct, Locals, NonLocals)
;
Goal = term_conj(!.Conjuncts, Locals, NonLocals)
).
@@ -530,10 +526,12 @@
flatten_conjuncts_2([Goal0 | Goals0], !Goals) :-
( Goal0 = term_primitive(_, _, _) ->
list.takewhile(is_primitive, Goals0, Primitives, NextNonPrimitive),
- ( Primitives = [_|_] ->
- NewPrimitive = list.foldl(combine_primitives, Primitives, Goal0)
- ;
+ (
+ Primitives = [],
NewPrimitive = Goal0
+ ;
+ Primitives = [_ | _],
+ NewPrimitive = list.foldl(combine_primitives, Primitives, Goal0)
),
list.cons(NewPrimitive, !Goals)
;
@@ -753,28 +751,28 @@
simplify_conjuncts(Goals0, Goals) :-
(
- Goals0 = []
- ->
+ Goals0 = [],
Goals = []
;
- Goals0 = [Goal]
- ->
+ Goals0 = [Goal],
Goals = [Goal]
;
% If the list of conjuncts starts with two primitives
% join them together into a single primitive.
Goals0 = [GoalA, GoalB | OtherGoals],
- GoalA = term_primitive(PolyA, LocalsA, NonLocalsA),
- GoalB = term_primitive(PolyB, LocalsB, NonLocalsB)
- ->
- Poly = polyhedron.intersection(PolyA, PolyB),
- Locals = LocalsA ++ LocalsB,
- NonLocals = NonLocalsA ++ NonLocalsB,
- Goal = term_primitive(Poly, Locals, NonLocals),
- Goals1 = [Goal | OtherGoals],
- simplify_conjuncts(Goals1, Goals)
- ;
- Goals = Goals0
+ (
+ GoalA = term_primitive(PolyA, LocalsA, NonLocalsA),
+ GoalB = term_primitive(PolyB, LocalsB, NonLocalsB)
+ ->
+ Poly = polyhedron.intersection(PolyA, PolyB),
+ Locals = LocalsA ++ LocalsB,
+ NonLocals = NonLocalsA ++ NonLocalsB,
+ Goal = term_primitive(Poly, Locals, NonLocals),
+ Goals1 = [Goal | OtherGoals],
+ simplify_conjuncts(Goals1, Goals)
+ ;
+ Goals = Goals0
+ )
).
%-----------------------------------------------------------------------------%
Index: compiler/term_constr_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_errors.m,v
retrieving revision 1.7
diff -u -r1.7 term_constr_errors.m
--- compiler/term_constr_errors.m 20 Aug 2006 08:21:31 -0000 1.7
+++ compiler/term_constr_errors.m 22 Nov 2007 05:10:07 -0000
@@ -110,26 +110,31 @@
),
NonImportedPPIds = list.filter(IsNonImported, SCC),
list.is_not_empty(NonImportedPPIds),
- ( VerboseErrors = yes ->
+ (
+ VerboseErrors = yes,
PrintErrors = Errors
- ; NormalErrors = yes ->
- IsNonSimple = (pred(ContextError::in) is semidet :-
- ContextError = _ - Error,
- not indirect_error(Error)
- ),
- PrintErrors0 = list.filter(IsNonSimple, Errors),
- %
- % If there are no direct errors report the indirect ones instead.
- %
+ ;
+ VerboseErrors = no,
(
- PrintErrors0 = [],
- PrintErrors = Errors
+ NormalErrors = yes,
+ IsNonSimple = (pred(ContextError::in) is semidet :-
+ ContextError = _ - Error,
+ not indirect_error(Error)
+ ),
+ PrintErrors0 = list.filter(IsNonSimple, Errors),
+ % If there are no direct errors, report the indirect ones
+ % instead.
+ (
+ PrintErrors0 = [],
+ PrintErrors = Errors
+ ;
+ PrintErrors0 = [_ | _],
+ PrintErrors = PrintErrors0
+ )
;
- PrintErrors0 = [_ | _],
- PrintErrors = PrintErrors0
+ NormalErrors = no,
+ fail
)
- ;
- fail
)
->
term_constr_errors.report_term_errors(SCC, PrintErrors, !.ModuleInfo,
@@ -191,11 +196,13 @@
output_error(Context - Error, Single, ErrorNum, Indent, Module, !IO) :-
description(Error, Single, Module, Pieces0, _),
- ( ErrorNum = yes(N) ->
+ (
+ ErrorNum = yes(N),
string.int_to_string(N, Nstr),
string.append_list(["Reason ", Nstr, ":"], Preamble),
Pieces = [fixed(Preamble) | Pieces0]
;
+ ErrorNum = no,
Pieces = Pieces0
),
write_error_pieces(Context, Indent, Pieces, !IO).
Index: compiler/term_constr_fixpoint.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_fixpoint.m,v
retrieving revision 1.6
diff -u -r1.6 term_constr_fixpoint.m
--- compiler/term_constr_fixpoint.m 1 Dec 2006 15:04:23 -0000 1.6
+++ compiler/term_constr_fixpoint.m 22 Nov 2007 05:10:25 -0000
@@ -113,12 +113,12 @@
AbstractSCC, [], IterationInfos, !IO),
ChangeFlag = or_flags(IterationInfos),
(
- ChangeFlag = yes
- ->
+ ChangeFlag = yes,
list.foldl(update_size_info, IterationInfos, !ModuleInfo),
do_fixpoint_calculation(Options, SCC, Iteration + 1,
_, !ModuleInfo, !IO)
;
+ ChangeFlag = no,
% If one of the polyhedra in the SCC has `false' as its
% argument size constraint then the analysis failed. In that
% case set the argument size constraints for every procedure
Index: compiler/term_constr_initial.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_initial.m,v
retrieving revision 1.22
diff -u -r1.22 term_constr_initial.m
--- compiler/term_constr_initial.m 27 Aug 2007 06:22:15 -0000 1.22
+++ compiler/term_constr_initial.m 22 Nov 2007 05:12:24 -0000
@@ -394,12 +394,11 @@
set_generated_terminates([], _, _, !ProcTable).
set_generated_terminates([ProcId | ProcIds], SpecialPredId, ModuleInfo,
!ProcTable) :-
- %
- % We don't need to do anything special for solver type initialisation
- % predicates. Leaving it up to the analyser may result in better
- % argument size information anyway.
- %
- ( SpecialPredId \= spec_pred_init ->
+ (
+ ( SpecialPredId = spec_pred_unify
+ ; SpecialPredId = spec_pred_compare
+ ; SpecialPredId = spec_pred_index
+ ),
ProcInfo0 = !.ProcTable ^ det_elem(ProcId),
proc_info_get_headvars(ProcInfo0, HeadVars),
proc_info_get_vartypes(ProcInfo0, VarTypes),
@@ -417,7 +416,10 @@
),
svmap.det_update(ProcId, ProcInfo, !ProcTable)
;
- true
+ SpecialPredId = spec_pred_init
+ % We don't need to do anything special for solver type initialisation
+ % predicates. Leaving it up to the analyser may result in better
+ % argument size information anyway.
),
set_generated_terminates(ProcIds, SpecialPredId, ModuleInfo, !ProcTable).
@@ -440,18 +442,23 @@
Zeros = find_zero_size_vars(ModuleInfo, SizeVarMap, VarTypes),
NonZeroHeadSizeVars = list.filter(isnt(is_zero_size_var(Zeros)),
HeadSizeVars),
- %
- % unify may have more than two input arguments if one of them is a
- % type-info related arg, or some such thing. Since all these have
+
+ % Unify may have more than two input arguments if one of them is a
+ % type-info related arg, or some such thing. Since all these have
% zero size type, after removing them there are two possibilities.
% The list of non-zero size type head_vars is empty (if the
% arguments are zero sized) or it contains two elements.
- %
- ( NonZeroHeadSizeVars = [] ->
+
+ (
+ NonZeroHeadSizeVars = [],
Constrs = []
- ; NonZeroHeadSizeVars = [VarA, VarB] ->
+ ;
+ NonZeroHeadSizeVars = [VarA, VarB],
Constrs = [make_vars_eq_constraint(VarA, VarB)]
;
+ ( NonZeroHeadSizeVars = [_]
+ ; NonZeroHeadSizeVars = [_, _, _ | _]
+ ),
unexpected(this_file, "special_pred_id_to_termination/7: " ++
"wrong number of args for unify.")
),
Index: compiler/term_constr_main.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_main.m,v
retrieving revision 1.14
diff -u -r1.14 term_constr_main.m
--- compiler/term_constr_main.m 17 May 2007 03:52:52 -0000 1.14
+++ compiler/term_constr_main.m 22 Nov 2007 05:32:02 -0000
@@ -5,18 +5,18 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%----------------------------------------------------------------------------%
-%
-% File: term_constr_main.m.
+%
+% File: term_constr_main.m.
% Main author: juliensf.
-%
+%
% This module contains the top level of a termination analyser for Mercury.
% It is responsible for setting up the relevant data structures and invoking
% all the other passes.
-%
+%
% --------
% Overview
% --------
-%
+%
% The main data structures used by this analysis are defined in
% term_constr_data.m.
%
@@ -44,33 +44,33 @@
% procedures in a SCC terminate. There is an example of such a proof
% finder in term_constr_pass2.m, although we will probably end up with
% several such modules, each of which tries a different approach.
-%
+%
% In addition there are some utility procedures in term_constr_util.m
% and some predicates for handling error messages in term_constr_error.m.
%
% The machinery for handling convex constraints (polyhedra) is in:
-%
+%
% * polyhedron.m
% * lp_rational.m
% * rat.m
-%
+%
% TODO:
-% * add support for higher-order code and intermodule
+% * add support for higher-order code and intermodule
% mutual recursion.
%
% * add support for user-defined IR constraints for foreign
% code, :- pragma arg_size_relation(...) or something.
-%
+%
% * experiment with different types of widening.
%
% * experiment with different representation for the polyhedra.
%
%----------------------------------------------------------------------------%
-:- module transform_hlds.term_constr_main.
+:- module transform_hlds.term_constr_main.
:- interface.
-:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module parse_tree.prog_data.
:- import_module libs.polyhedron.
@@ -83,13 +83,13 @@
:- import_module maybe.
%----------------------------------------------------------------------------%
-%
+%
% Types that define termination information about procedures
%
% This type is the interargument size relationships between
% the arguments of a predicate.
- %
+ %
:- type constr_arg_size_info == polyhedron.
% Whether or not a procedure is terminating and some idea of why
@@ -101,17 +101,17 @@
% Why does the termination analyser think that a procedure is
% terminating? This is useful for debugging purposes.
%
-:- type term_reason
- ---> builtin % procedure was a builtin.
-
- ; pragma_supplied % procedure has pragma terminates decl.
+:- type term_reason
+ ---> builtin % procedure was a builtin.
+
+ ; pragma_supplied % procedure has pragma terminates decl.
; foreign_supplied % procedure has foreign code attribute.
-
- ; import_supplied % This procedure was imported and its
+
+ ; import_supplied % This procedure was imported and its
% termination status was read in from a .opt
% or .trans_opt file.
-
+
; analysis. % Termination info. was derived via analysis.
% Whether a procedure may be involved in mutual recursion
@@ -119,7 +119,7 @@
%
% XXX Termination analysis of mutual recursion across module boundaries
% NYI.
- %
+ %
:- type intermod_status
---> not_mutually_recursive
; may_be_mutually_recursive.
@@ -140,7 +140,7 @@
:- func termination2_info ^ size_var_map = size_var_map.
:- func termination2_info ^ import_success =
maybe(pragma_constr_arg_size_info).
-:- func termination2_info ^ import_failure =
+:- func termination2_info ^ import_failure =
maybe(pragma_constr_arg_size_info).
:- func termination2_info ^ success_constrs = maybe(constr_arg_size_info).
:- func termination2_info ^ failure_constrs = maybe(constr_arg_size_info).
@@ -150,9 +150,9 @@
:- func termination2_info ^ head_vars = list(size_var).
:- func termination2_info ^ size_var_map := size_var_map = termination2_info.
-:- func termination2_info ^ import_success :=
+:- func termination2_info ^ import_success :=
maybe(pragma_constr_arg_size_info) = termination2_info.
-:- func termination2_info ^ import_failure :=
+:- func termination2_info ^ import_failure :=
maybe(pragma_constr_arg_size_info) = termination2_info.
:- func termination2_info ^ success_constrs := maybe(constr_arg_size_info)
= termination2_info.
@@ -162,7 +162,7 @@
= termination2_info.
:- func termination2_info ^ intermod_status := maybe(intermod_status)
= termination2_info.
-:- func termination2_info ^ abstract_rep := maybe(abstract_proc)
+:- func termination2_info ^ abstract_rep := maybe(abstract_proc)
= termination2_info.
:- func termination2_info ^ head_vars := list(size_var)
= termination2_info.
@@ -190,7 +190,7 @@
:- pred term_constr_main.output_pragma_termination2_info(pred_or_func::in,
sym_name::in, list(mer_mode)::in, prog_context::in,
maybe(constr_arg_size_info)::in, maybe(constr_arg_size_info)::in,
- maybe(constr_termination_info)::in, size_vars::in, io::di,
+ maybe(constr_termination_info)::in, size_vars::in, io::di,
io::uo) is det.
%------------------------------------------------------------------------------%
@@ -224,51 +224,51 @@
:- import_module std_util.
:- import_module string.
:- import_module term.
-:- import_module varset.
+:- import_module varset.
%------------------------------------------------------------------------------%
%
% The 'termination2_info' structure
%
-:- type termination2_info
+:- type termination2_info
---> term2_info(
- size_var_map :: size_var_map,
- % Map between prog_vars and size_vars for this procedure.
+ size_var_map :: size_var_map,
+ % Map between prog_vars and size_vars for this procedure.
head_vars :: size_vars,
% These are the size variables that occur in argument
% size constraints. For procedures that are imported
% via a `.opt' or `.trans_opt' file we set these during
% the initial pass, for procedures in the module we are
- % analysing, pass 1 sets it.
-
+ % analysing, pass 1 sets it.
+
import_success :: maybe(pragma_constr_arg_size_info),
import_failure :: maybe(pragma_constr_arg_size_info),
% Arg size info. imported from another module via a
% `.opt' or `.trans_opt' file. Pass 0 needs to convert
% these to the proper form. These particular fields are
% of no use after that.
-
+
success_constrs :: maybe(constr_arg_size_info),
% The interargument size relationships
% (expressed as convex constraints)
- % obtained during pass 1.
-
+ % obtained during pass 1.
+
failure_constrs :: maybe(constr_arg_size_info),
% Failure constraints for predicates that
% can fail (set by pass 1).
term_status :: maybe(constr_termination_info),
% The termination status of the procedure as determined
- % by pass 2.
-
+ % by pass 2.
+
intermod_status :: maybe(intermod_status),
% Is this procedure (possibly) involved in mutual
% recursion across module boundaries? Set by pass 1.
-
+
abstract_rep :: maybe(abstract_proc)
- % The abstract representation of this
+ % The abstract representation of this
% proc. Set by term_constr_build.m.
).
@@ -279,13 +279,13 @@
% Main pass
%
-term_constr_main.pass(!ModuleInfo, !IO) :-
- %
+term_constr_main.pass(!ModuleInfo, !IO) :-
+ %
% Get options required by the build pass.
% These are:
% - which norm we are using.
% - whether we are propagating failure constraints.
- %
+ %
globals.io_get_termination2_norm(Norm, !IO),
FunctorInfo = set_functor_info(Norm, !.ModuleInfo),
globals.io_lookup_bool_option(propagate_failure_constrs, Fail, !IO),
@@ -296,8 +296,8 @@
% Get options required by the fixpoint pass.
% These are:
% - what cutoff value we are using
- % - the maximum allowable matrix size
- % (this is also used in pass 2).
+ % - the maximum allowable matrix size
+ % (this is also used in pass 2).
%
globals.io_lookup_int_option(term2_maximum_matrix_size, MaxSize, !IO),
globals.io_lookup_int_option(widening_limit, CutOff, !IO),
@@ -311,7 +311,7 @@
% Currently this is just the maximum matrix size.
%
Pass2Options = pass2_options_init(MaxSize),
- %
+ %
% Setup termination information for builtins and compiler generated
% predicates. Setup information from termination pragmas and
% foreign proc attributes.
@@ -340,17 +340,17 @@
%
% The normal procedure for analysing a SCC is:
%
- % (1) Build the abstract representation (AR) of the procedures in
+ % (1) Build the abstract representation (AR) of the procedures in
% the SCC. (term_constr_build.m).
%
- % (2) Use a fixpoint iteration to derive interargument size
+ % (2) Use a fixpoint iteration to derive interargument size
% relationships for the procedures in the SCC.
% (term_constr_fixpoint.m).
%
% (3) Use this information to try and find a proof that the procedures
% in the SCC terminate. (term_constr_pass2.m).
%
- % Exactly which of the above steps gets carried out depends upon
+ % Exactly which of the above steps gets carried out depends upon
% what (if any) additional information the user has supplied.
%
% For Mercury procedures:
@@ -360,95 +360,88 @@
% and (3). If both have been supplied we do not carry out any
% steps.
%
- % The usual caveats regarding the termination pragmas and mutual
+ % The usual caveats regarding the termination pragmas and mutual
% recursion apply (see the reference manual).
%
% XXX What do we do about pragma arg_size_info and mutual recursion?
% (Nothing yet, because it isn't implemented :-( )
- %
+ %
% For procedures implemented as foreign code:
- % The usual defaults (see reference manual) apply.
+ % The usual defaults (see reference manual) apply.
% If no argument size constraint is supplied then non-zero arguments
- % are assumed to have unbounded size.
- %
+ % are assumed to have unbounded size.
+ %
:- pred analyse_scc(dependency_ordering::in, build_options::in,
fixpoint_options::in, pass2_options::in,
list(pred_proc_id)::in, module_info::in, module_info::out, io::di,
io::uo) is det.
analyse_scc(DepOrder, BuildOpts, FixpointOpts, Pass2Opts, SCC, !ModuleInfo,
- !IO) :-
- %
- % Since all of the passes are potentially optional we need to
- % initialise the size_var_maps separately. If they are left
- % uninitialised intermodule optimization will not work.
- %
+ !IO) :-
+ % Since all of the passes are potentially optional we need to initialise
+ % the size_var_maps separately. If they are left uninitialised intermodule
+ % optimization will not work.
NeedsAR = list.filter(proc_needs_ar_built(!.ModuleInfo), SCC),
- %
- % Build the abstract representation for those procedures that
- % require it. The procedures that require it are those that
- % do not already have both argument size information and termination
- % information.
- %
+
+ % Build the abstract representation for those procedures that require it.
+ % The procedures that require it are those that do not already have
+ % both argument size information and termination information.
term_constr_build.build_abstract_scc(DepOrder, NeedsAR, BuildOpts,
- BuildErrors, !ModuleInfo, !IO),
- %
- % We only perform the fixpoint computation for those procedures
- % where we can gain meaningful information from it. We do not
- % do it when:
+ BuildErrors, !ModuleInfo, !IO),
+
+ % We only perform the fixpoint computation for those procedures where
+ % we can gain meaningful information from it. We do not do it when:
% - the information is already known, or
% - the argument size relationships depend upon higher-order calls.
- %
- NeedsArgSize = list.filter(isnt(has_arg_size_info(!.ModuleInfo)),
- NeedsAR),
+ NeedsArgSize = list.filter(isnt(has_arg_size_info(!.ModuleInfo)), NeedsAR),
term_constr_fixpoint.do_fixpoint_calculation(FixpointOpts,
NeedsArgSize, 1, FixpointErrors, !ModuleInfo, !IO),
- %
- % Errors detected during pass 1 always result in the rest of the
- % analysis being aborted for the SCC under consideration.
- %
+
+ % Errors detected during pass 1 always result in the rest of the analysis
+ % being aborted for the SCC under consideration.
Pass1Errors = BuildErrors ++ FixpointErrors,
- Pass1Result = ( if Pass1Errors = [] then ok else error(Pass1Errors) ),
- globals.io_lookup_bool_option(arg_size_analysis_only, ArgSizeOnly,
- !IO),
- (
- ArgSizeOnly = no
- ->
- NeedsTerm = list.filter(isnt(has_term_info(!.ModuleInfo)),
- NeedsAR),
- %
- % Some procedures may not have arg_size_info, but
- % may have termination info, i.e. those that have
- % a pragma terminates or does_not_terminate declaration.
- %
- ( Pass1Result = error(Pass1Errors) ->
- Pass2Result = can_loop(Pass1Errors)
- ;
+ (
+ Pass1Errors = [],
+ MaybeEarlyPass2Result = no
+ ;
+ Pass1Errors = [_ | _],
+ MaybeEarlyPass2Result = yes(can_loop(Pass1Errors))
+ ),
+ globals.io_lookup_bool_option(arg_size_analysis_only, ArgSizeOnly, !IO),
+ (
+ ArgSizeOnly = no,
+ NeedsTerm = list.filter(isnt(has_term_info(!.ModuleInfo)), NeedsAR),
+
+ % Some procedures may not have arg_size_info, but may have termination
+ % info, i.e. those that have a pragma terminates or does_not_terminate
+ % declaration.
+ (
+ MaybeEarlyPass2Result = yes(Pass2Result)
+ ;
+ MaybeEarlyPass2Result = no,
term_constr_pass2.prove_termination_in_scc(Pass2Opts,
NeedsTerm, !.ModuleInfo, Pass2Result, !IO)
),
- %
- % Set the termination property for this procedure and
+
+ % Set the termination property for this procedure and
% report any errors that we found during pass 2.
- %
- set_termination_info_for_procs(NeedsTerm, Pass2Result,
- !ModuleInfo),
- ( Pass2Result = can_loop(Errors) ->
- report_termination2_errors(NeedsTerm, Errors,
- !ModuleInfo, !IO)
+ set_termination_info_for_procs(NeedsTerm, Pass2Result, !ModuleInfo),
+ (
+ Pass2Result = can_loop(Errors),
+ report_termination2_errors(NeedsTerm, Errors, !ModuleInfo, !IO)
;
- true
+ Pass2Result = cannot_loop(_)
)
;
- true
+ ArgSizeOnly = yes
).
%------------------------------------------------------------------------------%
-%
+%
% Procedures for storing 'termination2_info' in the HLDS
%
-:- pred set_termination_info_for_procs(list(pred_proc_id)::in,
+:- pred set_termination_info_for_procs(list(pred_proc_id)::in,
constr_termination_info::in, module_info::in, module_info::out) is det.
set_termination_info_for_procs(PPIds, TerminationInfo, !ModuleInfo) :-
@@ -470,11 +463,11 @@
% Predicates for writing optimization interfaces
%
-:- pred maybe_make_optimization_interface(module_info::in, io::di, io::uo)
+:- pred maybe_make_optimization_interface(module_info::in, io::di, io::uo)
is det.
maybe_make_optimization_interface(ModuleInfo, !IO) :-
- globals.io_lookup_bool_option(make_optimization_interface, MakeOptInt,
+ globals.io_lookup_bool_option(make_optimization_interface, MakeOptInt,
!IO),
(
MakeOptInt = yes,
@@ -490,13 +483,13 @@
module_info_get_name(ModuleInfo, ModuleName),
module_name_to_file_name(ModuleName, ".opt.tmp", no, OptFileName, !IO),
globals.io_lookup_bool_option(verbose, Verbose, !IO),
- maybe_write_string(Verbose,
+ maybe_write_string(Verbose,
"% Appending termination2_info pragmas to `", !IO),
maybe_write_string(Verbose, OptFileName, !IO),
maybe_write_string(Verbose, "'...", !IO),
maybe_flush_output(Verbose, !IO),
io.open_append(OptFileName, OptFileRes, !IO),
- (
+ (
OptFileRes = ok(OptFile),
io.set_output_stream(OptFile, OldStream, !IO),
list.foldl(output_pred_termination2_info(ModuleInfo), PredIds,
@@ -504,7 +497,7 @@
io.set_output_stream(OldStream, _, !IO),
io.close_output(OptFile, !IO),
maybe_write_string(Verbose, " done.\n", !IO)
- ;
+ ;
OptFileRes = error(IOError),
% failed to open the .opt file for processing
maybe_write_string(Verbose, " failed!\n", !IO),
@@ -515,19 +508,18 @@
).
output_pred_termination2_info(ModuleInfo, PredId, !IO) :-
- %
- % Don't try to output termination2_info pragmas unless
- % the analysis was actually run. Doing otherwise won't
- % work because the necessary information will not have been set
- % up.
- %
+ % Don't try to output termination2_info pragmas unless the analysis
+ % was actually run. Doing otherwise won't work because the necessary
+ % information will not have been set up.
+
globals.io_lookup_bool_option(termination2, RunningTerm2, !IO),
- ( RunningTerm2 = yes ->
+ (
+ RunningTerm2 = yes,
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_get_import_status(PredInfo, ImportStatus),
module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo),
TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _),
- (
+ (
( ImportStatus = status_exported
; ImportStatus = status_opt_exported
),
@@ -537,37 +529,37 @@
PredName = pred_info_name(PredInfo),
pred_info_get_procedures(PredInfo, ProcTable),
pred_info_get_context(PredInfo, Context),
- PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo),
ModuleName = pred_info_module(PredInfo),
- ProcIds = pred_info_procids(PredInfo),
+ ProcIds = pred_info_procids(PredInfo),
SymName = qualified(ModuleName, PredName),
- make_opt_int_procs(PredId, ProcIds, ProcTable, PredOrFunc,
+ make_opt_int_procs(PredId, ProcIds, ProcTable, PredOrFunc,
SymName, Context, !IO)
;
- true
+ true
)
;
- true
+ RunningTerm2 = no
).
-:- pred make_opt_int_procs(pred_id::in, list(proc_id)::in,
- proc_table::in, pred_or_func::in, sym_name::in, prog_context::in,
+:- pred make_opt_int_procs(pred_id::in, list(proc_id)::in,
+ proc_table::in, pred_or_func::in, sym_name::in, prog_context::in,
io::di, io::uo) is det.
make_opt_int_procs(_PredId, [], _, _, _, _, !IO).
-make_opt_int_procs(PredId, [ ProcId | ProcIds ], ProcTable,
- PredOrFunc, SymName, Context, !IO) :-
+make_opt_int_procs(PredId, [ ProcId | ProcIds ], ProcTable,
+ PredOrFunc, SymName, Context, !IO) :-
ProcInfo = ProcTable ^ det_elem(ProcId),
proc_info_get_termination2_info(ProcInfo, TermInfo),
proc_info_declared_argmodes(ProcInfo, ModeList),
- proc_info_get_headvars(ProcInfo, HeadVars),
+ proc_info_get_headvars(ProcInfo, HeadVars),
SizeVarMap = TermInfo ^ size_var_map,
HeadSizeVars = prog_vars_to_size_vars(SizeVarMap, HeadVars),
- output_pragma_termination2_info(PredOrFunc, SymName,
- ModeList, Context, TermInfo ^ success_constrs,
+ output_pragma_termination2_info(PredOrFunc, SymName,
+ ModeList, Context, TermInfo ^ success_constrs,
TermInfo ^ failure_constrs, TermInfo ^ term_status,
HeadSizeVars, !IO),
- make_opt_int_procs(PredId, ProcIds, ProcTable,
+ make_opt_int_procs(PredId, ProcIds, ProcTable,
PredOrFunc, SymName, Context, !IO).
%----------------------------------------------------------------------------%
@@ -575,50 +567,50 @@
% Predicates for writing 'termination2_info' pragmas
%
-% NOTE: if these predicates are changed then prog_io_pragma.m must
+% NOTE: if these predicates are changed then prog_io_pragma.m must
% also be changed so that it can parse the resulting pragma
% termination2_info declarations.
output_pragma_termination2_info(PredOrFunc, SymName, ModeList,
Context, MaybeSuccess, MaybeFailure, MaybeTermination,
- HeadVars, !IO) :-
+ HeadVars, !IO) :-
io.write_string(":- pragma termination2_info(", !IO),
- (
+ (
PredOrFunc = pf_predicate,
- mercury_output_pred_mode_subdecl(varset.init, SymName,
+ mercury_output_pred_mode_subdecl(varset.init, SymName,
ModeList, no, Context, !IO)
;
PredOrFunc = pf_function,
pred_args_to_func_args(ModeList, FuncModeList, RetMode),
- mercury_output_func_mode_subdecl(varset.init, SymName,
+ mercury_output_func_mode_subdecl(varset.init, SymName,
FuncModeList, RetMode, no, Context, !IO)
),
-
+
list.length(HeadVars, NumHeadVars),
HeadVarIds = 0 .. NumHeadVars - 1,
map.det_insert_from_corresponding_lists(map.init, HeadVars,
- HeadVarIds, VarToVarIdMap),
-
+ HeadVarIds, VarToVarIdMap),
+
io.write_string(", ", !IO),
output_maybe_constr_arg_size_info(VarToVarIdMap, MaybeSuccess,
!IO),
io.write_string(", ", !IO),
output_maybe_constr_arg_size_info(VarToVarIdMap, MaybeFailure,
!IO),
- io.write_string(", ", !IO),
+ io.write_string(", ", !IO),
output_maybe_termination2_info(MaybeTermination, !IO),
io.write_string(").\n", !IO).
:- pred output_maybe_constr_arg_size_info(map(size_var, int)::in,
- maybe(constr_arg_size_info)::in, io::di, io::uo) is det.
+ maybe(constr_arg_size_info)::in, io::di, io::uo) is det.
output_maybe_constr_arg_size_info(VarToVarIdMap,
- MaybeArgSizeConstrs, !IO) :-
- (
+ MaybeArgSizeConstrs, !IO) :-
+ (
MaybeArgSizeConstrs = no,
- io.write_string("not_set", !IO)
+ io.write_string("not_set", !IO)
;
- MaybeArgSizeConstrs = yes(Polyhedron),
+ MaybeArgSizeConstrs = yes(Polyhedron),
io.write_string("constraints(", !IO),
Constraints0 = polyhedron.non_false_constraints(Polyhedron),
Constraints1 = list.filter(isnt(nonneg_constr), Constraints0),
@@ -631,10 +623,10 @@
:- pred output_maybe_termination2_info(maybe(constr_termination_info)::in,
io::di, io::uo) is det.
-output_maybe_termination2_info(MaybeConstrTermInfo, !IO) :-
- (
+output_maybe_termination2_info(MaybeConstrTermInfo, !IO) :-
+ (
MaybeConstrTermInfo = no,
- io.write_string("not_set", !IO)
+ io.write_string("not_set", !IO)
;
MaybeConstrTermInfo = yes(cannot_loop(_)),
io.write_string("cannot_loop", !IO)
@@ -670,17 +662,17 @@
module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
proc_info_get_termination2_info(ProcInfo, TermInfo),
TermInfo ^ term_status = yes(_).
-
+
:- pred proc_needs_ar_built(module_info::in, pred_proc_id::in) is semidet.
proc_needs_ar_built(ModuleInfo, PPId) :-
module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
proc_info_get_termination2_info(ProcInfo, TermInfo),
- (
+ (
TermInfo ^ success_constrs = no
;
- TermInfo ^ term_status = no
- ).
+ TermInfo ^ term_status = no
+ ).
%------------------------------------------------------------------------------%
Index: compiler/term_constr_pass2.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_pass2.m,v
retrieving revision 1.9
diff -u -r1.9 term_constr_pass2.m
--- compiler/term_constr_pass2.m 1 Dec 2006 15:04:24 -0000 1.9
+++ compiler/term_constr_pass2.m 22 Nov 2007 05:22:05 -0000
@@ -5,17 +5,17 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: term_constr_pass2.m.
% Main author: juliensf.
-%
+%
% This module analyses a SCC of the call-graph and tries to prove that
% it terminates.
%
% XXX This version is just a place-holder. It attempts a very simple
-% proof method which is essentially what the existing termination analyser
+% proof method which is essentially what the existing termination analyser
% does.
-%
+%
%-----------------------------------------------------------------------------%
:- module transform_hlds.term_constr_pass2.
@@ -37,11 +37,11 @@
% pass2_options_init(MaxMatrixSize).
% Initialise the pass2_options structure. `MaxMatrixSize' specifies
% the maximum number of constraints we allow a matrix to grow to
- % before we abort and try other approximations.
- %
+ % before we abort and try other approximations.
+ %
:- func pass2_options_init(int) = pass2_options.
-:- pred prove_termination_in_scc(pass2_options::in, list(pred_proc_id)::in,
+:- pred prove_termination_in_scc(pass2_options::in, list(pred_proc_id)::in,
module_info::in, constr_termination_info::out, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
@@ -90,45 +90,45 @@
% Each edge in the call-graph represents a single call site.
%
-:- type edge
+:- type edge
---> edge(
head :: abstract_ppid,
- % The procedure that is making the call.
-
+ % The procedure that is making the call.
+
zeros :: set(size_var),
% Variables in the procedure known to have
% zero size.
-
+
head_args :: size_vars,
- % The size_vars that correspond to the
+ % The size_vars that correspond to the
% variables in the head of the procedure.
-
+
label :: polyhedron,
% The constraints that occur between the
% head of the procedure and the call.
-
- callee :: abstract_ppid,
+
+ callee :: abstract_ppid,
% The callee procedure.
-
- call_args :: size_vars
+
+ call_args :: size_vars
% The size_vars that correspond to the
% variables in the procedure call.
).
:- type edges == list(edge).
-:- type cycle
+:- type cycle
---> cycle(
nodes :: list(abstract_ppid),
- % A list of every procedure involved in
+ % A list of every procedure involved in
% this cycle.
-
+
edges :: list(edge)
% A list of edges involved in this cycle.
% Note: It is not ordered. This allows
% us to decide (later) on where we want
% the cycle to start.
- ).
+ ).
:- type cycles == list(cycle).
@@ -136,7 +136,7 @@
% call-graph where we have picked a starting vertex and travelled
% around the cycle conjoining all the labels (constraints) as we go.
%
-:- type cycle_set
+:- type cycle_set
---> c_set(
start :: abstract_ppid,
c_cycles :: list(edge)
@@ -144,7 +144,7 @@
%-----------------------------------------------------------------------------%
-prove_termination_in_scc(_, [], _, cannot_loop(analysis), !IO).
+prove_termination_in_scc(_, [], _, cannot_loop(analysis), !IO).
prove_termination_in_scc(Options, SCC0 @ [_|_], ModuleInfo, Result, !IO) :-
AbstractSCC = get_abstract_scc(ModuleInfo, SCC0),
% XXX Pass 1 should really set this up.
@@ -181,13 +181,13 @@
ProcEdges, yes, _),
list.append(ProcEdges, !Edges)
),
- list.foldl(FindEdges, Procs, [], Edges).
+ list.foldl(FindEdges, Procs, [], Edges).
% The four accumulators here are for:
% (1) the number of calls seen so far
% (2) the constraints so far
% (3) the edges found
- % (4) whether to abort or continue looking
+ % (4) whether to abort or continue looking
%
:- pred find_edges_in_goal(abstract_proc::in, abstract_scc::in,
module_info::in, int::in, abstract_goal::in, int::in, int::out,
@@ -195,16 +195,16 @@
bool::out) is det.
find_edges_in_goal(Proc, AbstractSCC, ModuleInfo, MaxMatrixSize,
- AbstractGoal, !Calls, !Polyhedron, !Edges, !Continue) :-
+ AbstractGoal, !Calls, !Polyhedron, !Edges, !Continue) :-
AbstractGoal = term_disj(Goals, _, Locals, _),
- (
+ (
!.Continue = yes,
%
% XXX We may be able to prove termination in more cases
% if we pass in !.Polyhedron instead of
% of polyhedron.universe ... although I don't think
% it is a major concern at the moment.
- %
+ %
find_edges_in_disj(Proc, AbstractSCC, ModuleInfo,
MaxMatrixSize, polyhedron.universe, Goals, !Calls,
[], DisjConstrs0, [], Edges1, !Continue),
@@ -216,8 +216,8 @@
DisjConstrs = polyhedron.project_all(Varset, Locals,
DisjConstrs0),
Constrs2 = list.foldl(
- polyhedron.convex_union(Varset,
- yes(MaxMatrixSize)), DisjConstrs,
+ polyhedron.convex_union(Varset,
+ yes(MaxMatrixSize)), DisjConstrs,
polyhedron.empty),
polyhedron.intersection(Constrs2, !Polyhedron)
;
@@ -228,13 +228,13 @@
).
find_edges_in_goal(Proc, AbstractSCC, ModuleInfo, MaxMatrixSize,
- AbstractGoal, !Calls, !Polyhedron, !Edges, !Continue) :-
+ AbstractGoal, !Calls, !Polyhedron, !Edges, !Continue) :-
AbstractGoal = term_conj(Goals, Locals, _),
- (
- !.Continue = yes,
+ (
+ !.Continue = yes,
list.foldl4(find_edges_in_goal(Proc, AbstractSCC, ModuleInfo,
MaxMatrixSize),
- Goals, !Calls, !Polyhedron, !Edges, !Continue),
+ Goals, !Calls, !Polyhedron, !Edges, !Continue),
(
!.Continue = yes,
polyhedron.project(Locals, Proc ^ varset, !Polyhedron)
@@ -245,17 +245,17 @@
!.Continue = no
).
-find_edges_in_goal(Proc, _AbstractSCC, ModuleInfo, _,
+find_edges_in_goal(Proc, _AbstractSCC, ModuleInfo, _,
term_call(CallPPId0, _, CallVars, ZeroVars, _, _, _),
- !Calls, !Polyhedron, !Edges, !Continue) :-
+ !Calls, !Polyhedron, !Edges, !Continue) :-
%
% Having found a call we now need to construct a label for that
% edge and then continue looking for more edges.
- %
- Edge = edge(Proc ^ ppid, Proc ^ zeros, Proc ^ head_vars, !.Polyhedron,
+ %
+ Edge = edge(Proc ^ ppid, Proc ^ zeros, Proc ^ head_vars, !.Polyhedron,
CallPPId0, CallVars),
list.cons(Edge, !Edges),
- %
+ %
% Update the call count and maybe stop processing if that was
% the last call.
%
@@ -274,23 +274,26 @@
CallProcInfo),
proc_info_get_termination2_info(CallProcInfo, CallTermInfo),
MaybeArgSizeInfo = CallTermInfo ^ success_constrs,
- (
+ (
MaybeArgSizeInfo = no,
unexpected(this_file, "Proc with no arg size info in pass 2.")
;
MaybeArgSizeInfo = yes(ArgSizePolyhedron0),
%
% If the polyhedron is universe then
- % there's no point running the substitution.
+ % there's no point running the substitution.
%
( polyhedron.is_universe(ArgSizePolyhedron0) ->
- true
+ true
;
- MaybeCallProc = CallTermInfo ^ abstract_rep,
- ( if MaybeCallProc = yes(CallProc0)
- then CallProc = CallProc0
- else unexpected(this_file,
- "No abstract representation for proc.")
+ MaybeCallProc = CallTermInfo ^ abstract_rep,
+ (
+ MaybeCallProc = yes(CallProc0),
+ CallProc = CallProc0
+ ;
+ MaybeCallProc = no,
+ unexpected(this_file,
+ "No abstract representation for proc.")
),
HeadVars = CallProc ^ head_vars,
Subst = map.from_corresponding_lists(HeadVars, CallVars),
@@ -316,11 +319,11 @@
:- pred find_edges_in_disj(abstract_proc::in, abstract_scc::in, module_info::in,
int::in, polyhedron::in, abstract_goals::in, int::in, int::out,
polyhedra::in, polyhedra::out, edges::in, edges::out, bool::in,
- bool::out) is det.
+ bool::out) is det.
find_edges_in_disj(_, _, _, _, _, [], !Calls, !DisjConstrs, !Edges, !Continue).
find_edges_in_disj(Proc, AbstractSCC, ModuleInfo, MaxMatrixSize, TopPoly,
- [Disj | Disjs], !Calls, !DisjConstrs, !Edges, !Continue) :-
+ [Disj | Disjs], !Calls, !DisjConstrs, !Edges, !Continue) :-
find_edges_in_goal(Proc, AbstractSCC, ModuleInfo, MaxMatrixSize, Disj,
!Calls, TopPoly, Constrs, !Edges, !Continue),
list.cons(Constrs, !DisjConstrs),
@@ -334,7 +337,7 @@
find_edges_in_disj(Proc, AbstractSCC, ModuleInfo,
MaxMatrixSize, TopPoly, Disjs, !Calls, !DisjConstrs,
!Edges, !Continue)
- ;
+ ;
!.Continue = no
).
@@ -355,9 +358,9 @@
:- func find_elementary_cycles_in_scc(list(abstract_ppid), edges) = cycles.
-find_elementary_cycles_in_scc(SCC, Edges0) = Cycles :-
- %
- % Get any self-loops for each procedure.
+find_elementary_cycles_in_scc(SCC, Edges0) = Cycles :-
+ %
+ % Get any self-loops for each procedure.
%
list.filter_map(direct_call, Edges0, Cycles0, Edges),
%
@@ -367,7 +370,7 @@
Cycles = Cycles0 ++ Cycles1.
% Succeeds iff Edge is an edge that represents
- % a directly recursive call (a self-loop in
+ % a directly recursive call (a self-loop in
% the pseudograph)
%
:- pred direct_call(edge::in, cycle::out) is semidet.
@@ -378,9 +381,9 @@
:- func find_cycles(list(abstract_ppid), edges) = cycles.
-find_cycles(SCC, Edges) = Cycles :-
+find_cycles(SCC, Edges) = Cycles :-
EdgeMap = partition_edges(SCC, Edges),
- Cycles = search_for_cycles(SCC, EdgeMap).
+ Cycles = search_for_cycles(SCC, EdgeMap).
% Builds a map from `pred_proc_id' to a list of the edges that begin
% with the `pred_proc_id.
@@ -388,13 +391,13 @@
:- func partition_edges(list(abstract_ppid), edges) = map(abstract_ppid, edges).
partition_edges([], _) = map.init.
-partition_edges([ProcId | SCC], Edges0) = Map :-
- Map0 = partition_edges(SCC, Edges0),
+partition_edges([ProcId | SCC], Edges0) = Map :-
+ Map0 = partition_edges(SCC, Edges0),
Edges = list.filter((pred(Edge::in) is semidet :- ProcId = Edge ^ head),
- Edges0),
- Map = map.det_insert(Map0, ProcId, Edges).
+ Edges0),
+ Map = map.det_insert(Map0, ProcId, Edges).
-:- func search_for_cycles(list(abstract_ppid), map(abstract_ppid, edges))
+:- func search_for_cycles(list(abstract_ppid), map(abstract_ppid, edges))
= cycles.
search_for_cycles([], _) = [].
@@ -408,11 +411,11 @@
search_for_cycles_2(StartPPId, Map) = Cycles :-
InitialEdges = Map ^ det_elem(StartPPId),
- list.foldl(search_for_cycles_3(StartPPId, [], Map, []), InitialEdges,
+ list.foldl(search_for_cycles_3(StartPPId, [], Map, []), InitialEdges,
[], Cycles).
-:- pred search_for_cycles_3(abstract_ppid::in, edges::in,
- map(abstract_ppid, edges)::in, list(abstract_ppid)::in, edge::in,
+:- pred search_for_cycles_3(abstract_ppid::in, edges::in,
+ map(abstract_ppid, edges)::in, list(abstract_ppid)::in, edge::in,
cycles::in, cycles::out) is det.
search_for_cycles_3(Start, SoFar, Map, Visited, Edge, !Cycles) :-
@@ -445,10 +448,13 @@
partition_cycles([Proc | Procs], Cycles0) = CycleSets :-
list.filter(cycle_contains_proc(Proc), Cycles0, PCycles, Cycles1),
CycleSets0 = partition_cycles(Procs, Cycles1),
- PEdges = list.map(collapse_cycle(Proc), PCycles),
- ( if PEdges = []
- then CycleSets = CycleSets0
- else CycleSets = [c_set(Proc, PEdges) | CycleSets0]
+ PEdges = list.map(collapse_cycle(Proc), PCycles),
+ (
+ PEdges = [],
+ CycleSets = CycleSets0
+ ;
+ PEdges = [_ | _],
+ CycleSets = [c_set(Proc, PEdges) | CycleSets0]
).
:- func get_proc_from_abstract_scc(list(abstract_proc), abstract_ppid)
@@ -456,7 +462,7 @@
get_proc_from_abstract_scc([], _) = _ :-
unexpected(this_file, "Cannot find proc.").
-get_proc_from_abstract_scc([ Proc | Procs ], PPId) =
+get_proc_from_abstract_scc([ Proc | Procs ], PPId) =
( Proc ^ ppid = PPId ->
Proc
;
@@ -464,12 +470,12 @@
).
%-----------------------------------------------------------------------------%
-%
+%
% Termination checking.
%
% This approach is very crude. It just checks that the sum of all
-% the non-zero arguments is decreasing around all the elementary cycles.
+% the non-zero arguments is decreasing around all the elementary cycles.
:- pred prove_termination(list(cycle_set)::in, abstract_scc::in,
size_varset::in, constr_termination_info::out) is det.
@@ -477,14 +483,14 @@
prove_termination(Cycles, AbstractSCC, Varset, Result) :-
( total_sum_decrease(AbstractSCC, Varset, Cycles) ->
Result = cannot_loop(analysis)
- ;
+ ;
% NOTE: the context here will never be used, in any
% case it's not clear what it should be.
Error = term.context_init - cond_not_satisfied,
Result = can_loop([Error])
).
-:- pred total_sum_decrease(abstract_scc::in, size_varset::in,
+:- pred total_sum_decrease(abstract_scc::in, size_varset::in,
list(cycle_set)::in) is semidet.
total_sum_decrease(_, _, []).
@@ -499,7 +505,7 @@
total_sum_decrease_2(AbstractSCC, Varset, PPId, Loops @ [_|_]) :-
all [Loop] (
list.member(Loop, Loops)
- =>
+ =>
strict_decrease_around_loop(AbstractSCC, Varset, PPId, Loop)
).
@@ -514,7 +520,7 @@
then unexpected(this_file, "Badly formed loop.")
else true
),
- IsActive = (func(Var::in, Input::in) = (Var::out) is semidet :-
+ IsActive = (func(Var::in, Input::in) = (Var::out) is semidet :-
Input = yes
),
Proc = get_proc_from_abstract_scc(AbstractSCC, PPId),
@@ -535,12 +541,13 @@
entailed(Varset, Label, Condition).
:- pred cycle_contains_proc(abstract_ppid::in, cycle::in) is semidet.
-
+
cycle_contains_proc(PPId, cycle(Nodes, _)) :- list.member(PPId, Nodes).
-
+
% XXX Fix this name.
+ %
:- func make_coeffs(size_vars, rat) = lp_terms.
-
+
make_coeffs(Vars, Coeff) = list.map((func(Var) = Var - Coeff), Vars).
%-----------------------------------------------------------------------------%
@@ -552,36 +559,40 @@
collapse_cycles(Start, Cycles) = list.map(collapse_cycle(Start), Cycles).
-:- func collapse_cycle(abstract_ppid, cycle) = edge.
+:- func collapse_cycle(abstract_ppid, cycle) = edge.
collapse_cycle(_, cycle(_, [])) = _ :-
unexpected(this_file, "Trying to collapse a cycle with no edges.").
-collapse_cycle(_, cycle(_, [Edge])) = Edge.
+collapse_cycle(_, cycle(_, [Edge])) = Edge.
collapse_cycle(StartPPId, cycle(_, Edges0 @ [_,_|_])) = CollapsedCycle :-
order_nodes(StartPPId, Edges0, Edges),
- ( if Edges = [StartEdge0 | Rest0]
- then StartEdge = StartEdge0, Rest = Rest0
- else unexpected(this_file, "Error while collapsing cycles.")
+ (
+ Edges = [StartEdge0 | Rest0],
+ StartEdge = StartEdge0,
+ Rest = Rest0
+ ;
+ Edges = [],
+ unexpected(this_file, "Error while collapsing cycles.")
),
StartEdge = edge(_, Zeros0, HeadVars, Polyhedron0, _, CallVars0),
- collapse_cycle_2(Rest, Zeros0, Zeros, CallVars0, CallVars, Polyhedron0,
+ collapse_cycle_2(Rest, Zeros0, Zeros, CallVars0, CallVars, Polyhedron0,
Polyhedron),
- CollapsedCycle = edge(StartPPId, Zeros, HeadVars, Polyhedron,
+ CollapsedCycle = edge(StartPPId, Zeros, HeadVars, Polyhedron,
StartPPId, CallVars).
-:- pred collapse_cycle_2(edges::in, zero_vars::in, zero_vars::out,
+:- pred collapse_cycle_2(edges::in, zero_vars::in, zero_vars::out,
size_vars::in, size_vars::out, polyhedron::in, polyhedron::out) is det.
-collapse_cycle_2([], !Zeros, !CallVars, !Polyhedron).
+collapse_cycle_2([], !Zeros, !CallVars, !Polyhedron).
collapse_cycle_2([Edge | Edges], !Zeros, !CallVars, !Polyhedron) :-
set.union(Edge ^ zeros, !Zeros),
HeadVars = Edge ^ head_args,
Subst0 = assoc_list.from_corresponding_lists(HeadVars, !.CallVars),
bimap.set_from_assoc_list(Subst0, bimap.init, Subst),
%
- % We now need to substitute variables from the call to *this*
- % predicate for head variables in both the constraints from the
- % body of the predicate and also into the variables in the
+ % We now need to substitute variables from the call to *this*
+ % predicate for head variables in both the constraints from the
+ % body of the predicate and also into the variables in the
% calls to the next predicate.
%
% While it might be easier to put equality constraints
@@ -599,7 +610,7 @@
Constraints2 = list.map(subst_size_var_eqn(Subst), Constraints1),
Constraints3 = Constraints0 ++ Constraints2,
!:Polyhedron = polyhedron.from_constraints(Constraints3),
- collapse_cycle_2(Edges, !Zeros, !CallVars, !Polyhedron).
+ collapse_cycle_2(Edges, !Zeros, !CallVars, !Polyhedron).
:- pred order_nodes(abstract_ppid::in, edges::in, edges::out) is det.
@@ -608,13 +619,13 @@
Edge = EdgeMap ^ det_elem(StartPPId),
order_nodes_2(StartPPId, Edge ^ callee, EdgeMap, Edges).
-:- pred order_nodes_2(abstract_ppid::in, abstract_ppid::in,
+:- pred order_nodes_2(abstract_ppid::in, abstract_ppid::in,
map(abstract_ppid, edge)::in, edges::out) is det.
order_nodes_2(StartPPId, CurrPPId, Map, Edges) :-
( if StartPPId = CurrPPId
then Edges = []
- else
+ else
Edge = Map ^ det_elem(CurrPPId),
order_nodes_2(StartPPId, Edge ^ callee, Map, Edges0),
Edges = [Edge | Edges0]
@@ -623,7 +634,7 @@
:- func build_edge_map(edges) = map(abstract_ppid, edge).
build_edge_map([]) = map.init.
-build_edge_map([Edge | Edges]) =
+build_edge_map([Edge | Edges]) =
map.det_insert(build_edge_map(Edges), Edge ^ head, Edge).
:- func subst_size_var_eqn(bimap(size_var, size_var), constraint)
@@ -634,36 +645,36 @@
Coeffs = list.map(subst_size_var_coeff(Map), Coeffs0),
Eqn = constraint(Coeffs, Operator, Constant).
-:- func subst_size_var_coeff(bimap(size_var, size_var), lp_term) = lp_term.
+:- func subst_size_var_coeff(bimap(size_var, size_var), lp_term) = lp_term.
subst_size_var_coeff(Map, Var0 - Coeff) = Var - Coeff :-
Var = subst_size_var(Map, Var0).
:- func subst_size_var(bimap(size_var, size_var), size_var) = size_var.
-subst_size_var(Map, Old) = (if bimap.search(Map, Old, New) then New else Old).
+subst_size_var(Map, Old) = (if bimap.search(Map, Old, New) then New else Old).
%-----------------------------------------------------------------------------%
%
% Predicates for printing out debugging traces.
%
-:- pred write_cycles(cycles::in, module_info::in, size_varset::in,
+:- pred write_cycles(cycles::in, module_info::in, size_varset::in,
io::di, io::uo) is det.
write_cycles([], _, _, !IO).
-write_cycles([Cycle | Cycles], ModuleInfo, Varset, !IO) :-
+write_cycles([Cycle | Cycles], ModuleInfo, Varset, !IO) :-
io.write_string("Cycle in SCC:\n", !IO),
- write_cycle(Cycle ^ nodes, ModuleInfo, !IO),
+ write_cycle(Cycle ^ nodes, ModuleInfo, !IO),
io.write_list(Cycle ^ edges, "\n", write_edge(ModuleInfo, Varset), !IO),
io.nl(!IO),
write_cycles(Cycles, ModuleInfo, Varset, !IO).
-:- pred write_cycle(list(abstract_ppid)::in, module_info::in, io::di, io::uo)
+:- pred write_cycle(list(abstract_ppid)::in, module_info::in, io::di, io::uo)
is det.
write_cycle([], _, !IO).
-write_cycle([ Proc | Procs ], ModuleInfo, !IO) :-
+write_cycle([ Proc | Procs ], ModuleInfo, !IO) :-
io.write_string("\t- ", !IO),
Proc = real(PredProcId),
hlds_out.write_pred_proc_id(ModuleInfo, PredProcId, !IO),
@@ -673,7 +684,7 @@
:- pred write_edge(module_info::in, size_varset::in, edge::in,
io::di, io::uo) is det.
-write_edge(ModuleInfo, Varset, Edge, !IO) :-
+write_edge(ModuleInfo, Varset, Edge, !IO) :-
io.write_string("Edge is:\n\tHead: ", !IO),
Edge ^ head = real(PredProcId),
hlds_out.write_pred_proc_id(ModuleInfo, PredProcId, !IO),
Index: compiler/term_constr_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_util.m,v
retrieving revision 1.11
diff -u -r1.11 term_constr_util.m
--- compiler/term_constr_util.m 1 Dec 2006 15:04:24 -0000 1.11
+++ compiler/term_constr_util.m 22 Nov 2007 05:15:45 -0000
@@ -362,7 +362,12 @@
(
Trace = yes,
TracePred(!IO),
- ( if NewLine = yes then io.nl(!IO) else true ),
+ (
+ NewLine = yes,
+ io.nl(!IO)
+ ;
+ NewLine = no
+ ),
io.flush_output(!IO)
;
Trace = no
Index: compiler/term_pass2.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_pass2.m,v
retrieving revision 1.31
diff -u -r1.31 term_pass2.m
--- compiler/term_pass2.m 27 Aug 2007 06:22:15 -0000 1.31
+++ compiler/term_pass2.m 22 Nov 2007 05:23:47 -0000
@@ -312,20 +312,23 @@
Result = ok(CallInfo, _),
CallInfo = call_weight_info(InfCalls, CallWeights),
(
- InfCalls \= []
- ->
+ InfCalls = [_ | _],
PassInfo = pass_info(_, MaxErrors, _),
list.take_upto(MaxErrors, InfCalls, ReportedInfCalls),
Termination = can_loop(ReportedInfCalls)
;
- zero_or_positive_weight_cycles(CallWeights, !.ModuleInfo, Cycles),
- Cycles \= []
- ->
- PassInfo = pass_info(_, MaxErrors, _),
- list.take_upto(MaxErrors, Cycles, ReportedCycles),
- Termination = can_loop(ReportedCycles)
- ;
- Termination = cannot_loop(unit)
+ InfCalls = [],
+ (
+ zero_or_positive_weight_cycles(CallWeights, !.ModuleInfo,
+ Cycles),
+ Cycles = [_ | _]
+ ->
+ PassInfo = pass_info(_, MaxErrors, _),
+ list.take_upto(MaxErrors, Cycles, ReportedCycles),
+ Termination = can_loop(ReportedCycles)
+ ;
+ Termination = cannot_loop(unit)
+ )
)
;
Result = error(Errors),
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.56
diff -u -r1.56 term_traversal.m
--- compiler/term_traversal.m 27 Aug 2007 06:22:15 -0000 1.56
+++ compiler/term_traversal.m 22 Nov 2007 05:24:16 -0000
@@ -484,9 +484,11 @@
compute_rec_start_vars([Var | Vars], [RecInputSupplier | RecInputSuppliers],
Out) :-
compute_rec_start_vars(Vars, RecInputSuppliers, Out1),
- ( RecInputSupplier = yes ->
+ (
+ RecInputSupplier = yes,
bag.insert(Out1, Var, Out)
;
+ RecInputSupplier = no,
Out = Out1
).
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.57
diff -u -r1.57 term_util.m
--- compiler/term_util.m 27 Aug 2007 06:22:16 -0000 1.57
+++ compiler/term_util.m 22 Nov 2007 05:24:47 -0000
@@ -230,14 +230,14 @@
(
Modes = []
;
- Modes = [_|_],
+ Modes = [_ | _],
unexpected(this_file, "split_unification_vars/5: unmatched variables.")
).
split_unification_vars([Arg | Args], Modes, ModuleInfo,
InVars, OutVars):-
- ( Modes = [UniMode | UniModes] ->
- split_unification_vars(Args, UniModes, ModuleInfo,
- InVars0, OutVars0),
+ (
+ Modes = [UniMode | UniModes],
+ split_unification_vars(Args, UniModes, ModuleInfo, InVars0, OutVars0),
UniMode = ((_VarInit - ArgInit) -> (_VarFinal - ArgFinal)),
(
inst_is_bound(ModuleInfo, ArgInit)
@@ -257,6 +257,7 @@
OutVars = OutVars0
)
;
+ Modes = [],
unexpected(this_file, "split_unification_vars/5: unmatched variables.")
).
Index: compiler/termination.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/termination.m,v
retrieving revision 1.77
diff -u -r1.77 termination.m
--- compiler/termination.m 27 Aug 2007 06:22:16 -0000 1.77
+++ compiler/termination.m 22 Nov 2007 05:30:08 -0000
@@ -531,20 +531,32 @@
% then output both sorts of error.
% (See term_errors.m for details of direct and indirect errors.)
- ( VerboseErrors = yes ->
+ (
+ VerboseErrors = yes,
PrintErrors = Errors
- ; NormalErrors = yes ->
- IsNonSimple = (pred(ContextError::in) is semidet :-
- ContextError = termination_error_context(Error, _Context),
- is_indirect_error(Error) = no
- ),
- list.filter(IsNonSimple, Errors, PrintErrors0),
- % If there were no direct errors then use the indirect errors.
- % This prevents warnings that report termination could not be
- % proved for unknown reasons.
- PrintErrors = ( PrintErrors0 = [] -> Errors ; PrintErrors0 )
;
- fail
+ VerboseErrors = no,
+ (
+ NormalErrors = yes,
+ IsNonSimple = (pred(ContextError::in) is semidet :-
+ ContextError = termination_error_context(Error, _Context),
+ is_indirect_error(Error) = no
+ ),
+ list.filter(IsNonSimple, Errors, PrintErrors0),
+ % If there were no direct errors then use the indirect errors.
+ % This prevents warnings that report termination could not be
+ % proven for unknown reasons.
+ (
+ PrintErrors0 = [],
+ PrintErrors = Errors
+ ;
+ PrintErrors0 = [_ | _],
+ PrintErrors = PrintErrors0
+ )
+ ;
+ NormalErrors = no,
+ fail
+ )
)
->
report_term_errors(SCC, PrintErrors, !.ModuleInfo, !IO)
@@ -707,23 +719,24 @@
set_generated_terminates([], _, !ProcTable).
set_generated_terminates([ProcId | ProcIds], SpecialPredId, !ProcTable) :-
- %
- % We don't need to do anything special for solver type initialisation
- % predicates. Leaving it up to the analyser may result in better
- % argument size information anyway.
- %
- ( SpecialPredId \= spec_pred_init ->
+ (
+ ( SpecialPredId = spec_pred_unify
+ ; SpecialPredId = spec_pred_compare
+ ; SpecialPredId = spec_pred_index
+ ),
map.lookup(!.ProcTable, ProcId, ProcInfo0),
proc_info_get_headvars(ProcInfo0, HeadVars),
special_pred_id_to_termination(SpecialPredId, HeadVars,
ArgSize, Termination),
- proc_info_set_maybe_arg_size_info(yes(ArgSize), ProcInfo0,
- ProcInfo1),
+ proc_info_set_maybe_arg_size_info(yes(ArgSize), ProcInfo0, ProcInfo1),
proc_info_set_maybe_termination_info(yes(Termination),
ProcInfo1, ProcInfo),
svmap.det_update(ProcId, ProcInfo, !ProcTable)
;
- true
+ SpecialPredId = spec_pred_init
+ % We don't need to do anything special for solver type initialisation
+ % predicates. Leaving it up to the analyser may result in better
+ % argument size information anyway.
),
set_generated_terminates(ProcIds, SpecialPredId, !ProcTable).
Index: compiler/trace_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trace_gen.m,v
retrieving revision 1.20
diff -u -r1.20 trace_gen.m
--- compiler/trace_gen.m 12 Nov 2007 03:52:45 -0000 1.20
+++ compiler/trace_gen.m 21 Nov 2007 13:45:22 -0000
@@ -1091,30 +1091,46 @@
:- pred redo_layout_slot(code_model::in, lval::out) is det.
event_num_slot(CodeModel, EventNumSlot) :-
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
EventNumSlot = framevar(1)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
EventNumSlot = stackvar(1)
).
call_num_slot(CodeModel, CallNumSlot) :-
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
CallNumSlot = framevar(2)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
CallNumSlot = stackvar(2)
).
call_depth_slot(CodeModel, CallDepthSlot) :-
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
CallDepthSlot = framevar(3)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
CallDepthSlot = stackvar(3)
).
redo_layout_slot(CodeModel, RedoLayoutSlot) :-
- ( CodeModel = model_non ->
+ (
+ CodeModel = model_non,
RedoLayoutSlot = framevar(4)
;
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
unexpected(this_file,
"attempt to access redo layout slot for det or semi procedure")
).
Index: compiler/trace_params.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trace_params.m,v
retrieving revision 1.41
diff -u -r1.41 trace_params.m
--- compiler/trace_params.m 2 May 2007 02:15:59 -0000 1.41
+++ compiler/trace_params.m 21 Nov 2007 09:47:39 -0000
@@ -162,10 +162,10 @@
; decl_rep.
:- type trace_suppress_item
- ---> port(trace_port)
- ; return_info
- ; all_var_names
- ; proc_body_reps.
+ ---> suppress_port(trace_port)
+ ; suppress_return_info
+ ; suppress_all_var_names
+ ; suppress_proc_body_reps.
:- type trace_suppress_items == set(trace_suppress_item).
@@ -367,7 +367,7 @@
trace_needs_return_info(TraceLevel, TraceSuppressItems) = Need :-
(
trace_level_has_return_info(TraceLevel) = yes,
- \+ set.member(return_info, TraceSuppressItems)
+ \+ set.member(suppress_return_info, TraceSuppressItems)
->
Need = yes
;
@@ -377,7 +377,7 @@
trace_needs_all_var_names(TraceLevel, TraceSuppressItems) = Need :-
(
trace_level_has_all_var_names(TraceLevel) = yes,
- \+ set.member(all_var_names, TraceSuppressItems)
+ \+ set.member(suppress_all_var_names, TraceSuppressItems)
->
Need = yes
;
@@ -387,7 +387,7 @@
trace_needs_proc_body_reps(TraceLevel, TraceSuppressItems) = Need :-
(
trace_level_has_proc_body_reps(TraceLevel) = yes,
- \+ set.member(proc_body_reps, TraceSuppressItems)
+ \+ set.member(suppress_proc_body_reps, TraceSuppressItems)
->
Need = yes
;
@@ -481,19 +481,19 @@
:- func convert_other_name(string) = trace_suppress_item is semidet.
-convert_other_name("return") = return_info.
-convert_other_name("return_info") = return_info.
-convert_other_name("names") = all_var_names.
-convert_other_name("all_var_names") = all_var_names.
-convert_other_name("bodies") = proc_body_reps.
-convert_other_name("proc_body_reps") = proc_body_reps.
+convert_other_name("return") = suppress_return_info.
+convert_other_name("return_info") = suppress_return_info.
+convert_other_name("names") = suppress_all_var_names.
+convert_other_name("all_var_names") = suppress_all_var_names.
+convert_other_name("bodies") = suppress_proc_body_reps.
+convert_other_name("proc_body_reps") = suppress_proc_body_reps.
:- pred convert_item_name(string::in, list(trace_suppress_item)::out)
is semidet.
convert_item_name(String, Names) :-
( convert_port_name(String) = PortName ->
- Names = [port(PortName)]
+ Names = [suppress_port(PortName)]
; convert_port_class_name(String) = PortNames ->
list.map(wrap_port, PortNames, Names)
; convert_other_name(String) = OtherName ->
@@ -504,7 +504,7 @@
:- pred wrap_port(trace_port::in, trace_suppress_item::out) is det.
-wrap_port(Port, port(Port)).
+wrap_port(Port, suppress_port(Port)).
% If this is modified, then the corresponding code in
% runtime/mercury_stack_layout.h needs to be updated.
@@ -580,7 +580,7 @@
list.member(Category, trace_level_port_categories(TraceLevel)),
\+ (
trace_level_allows_port_suppression(TraceLevel) = yes,
- set.member(port(Port), TraceSuppressItems)
+ set.member(suppress_port(Port), TraceSuppressItems)
)
->
NeedsPort = yes
@@ -597,9 +597,14 @@
maybe_add_suppressed_event(SuppressItem, SuppressedEventsInt0,
SuppressedEventsInt) :-
- ( SuppressItem = port(Port) ->
+ (
+ SuppressItem = suppress_port(Port),
SuppressedEventsInt = SuppressedEventsInt0 \/ (1 << port_number(Port))
;
+ ( SuppressItem = suppress_return_info
+ ; SuppressItem = suppress_all_var_names
+ ; SuppressItem = suppress_proc_body_reps
+ ),
SuppressedEventsInt = SuppressedEventsInt0
).
Index: compiler/trailing_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trailing_analysis.m,v
retrieving revision 1.27
diff -u -r1.27 trailing_analysis.m
--- compiler/trailing_analysis.m 20 Aug 2007 03:36:06 -0000 1.27
+++ compiler/trailing_analysis.m 21 Nov 2007 15:35:21 -0000
@@ -316,13 +316,18 @@
trailing_status::out, maybe(analysis_status)::out,
module_info::in, module_info::out, io::di, io::uo) is det.
-check_goal_for_trail_mods_2(_, _, GoalExpr, _, trail_will_not_modify, yes(optimal),
- !ModuleInfo, !IO) :-
+check_goal_for_trail_mods_2(_, _, GoalExpr, _, trail_will_not_modify,
+ yes(optimal), !ModuleInfo, !IO) :-
GoalExpr = unify(_, _, _, Kind, _),
- ( Kind = complicated_unify(_, _, _) ->
- unexpected(this_file, "complicated unify during trail usage analysis.")
+ (
+ ( Kind = construct(_, _, _, _, _, _, _)
+ ; Kind = deconstruct(_, _, _, _, _, _)
+ ; Kind = assign(_, _)
+ ; Kind = simple_test(_, _)
+ )
;
- true
+ Kind = complicated_unify(_, _, _),
+ unexpected(this_file, "complicated unify during trail usage analysis.")
).
check_goal_for_trail_mods_2(SCC, VarTypes, GoalExpr, _,
Result, MaybeAnalysisStatus, !ModuleInfo, !IO) :-
@@ -378,9 +383,13 @@
% analysis framework.
search_analysis_status(CallPPId, Result0, AnalysisStatus, SCC,
!ModuleInfo, !IO),
- ( Result0 = trail_conditional ->
+ (
+ Result0 = trail_conditional,
Result = check_vars(!.ModuleInfo, VarTypes, CallArgs)
;
+ ( Result0 = trail_may_modify
+ ; Result0 = trail_will_not_modify
+ ),
Result = Result0
),
MaybeAnalysisStatus = yes(AnalysisStatus)
@@ -833,10 +842,14 @@
!.Goal = hlds_goal(GoalExpr0, GoalInfo0),
annotate_goal_2(VarTypes, GoalInfo0, GoalExpr0, GoalExpr, Status,
!ModuleInfo, !IO),
- ( Status = trail_will_not_modify ->
+ (
+ Status = trail_will_not_modify,
goal_info_add_feature(feature_will_not_modify_trail,
GoalInfo0, GoalInfo)
;
+ ( Status = trail_may_modify
+ ; Status = trail_conditional
+ ),
GoalInfo = GoalInfo0
),
!:Goal = hlds_goal(GoalExpr, GoalInfo).
@@ -892,12 +905,20 @@
% XXX We shouldn't be getting invalid analysis results at this
% stage so maybe we should just call unexpected/2 here?
- ( AnalysisStatus = invalid ->
+ (
+ AnalysisStatus = invalid,
Status = trail_may_modify
;
- ( Result = trail_conditional ->
+ ( AnalysisStatus = suboptimal
+ ; AnalysisStatus = optimal
+ ),
+ (
+ Result = trail_conditional,
Status = check_vars(!.ModuleInfo, VarTypes, CallArgs)
;
+ ( Result = trail_may_modify
+ ; Result = trail_will_not_modify
+ ),
Status = Result
)
)
@@ -928,10 +949,15 @@
!:Goal = switch(Var, CanFail, Cases).
annotate_goal_2(_VarTypes, _, !Goal, Status, !ModuleInfo, !IO) :-
!.Goal = unify(_, _, _, Kind, _),
- ( Kind = complicated_unify(_, _, _) ->
- unexpected(this_file, "complicated unify during trail usage analysis.")
+ (
+ ( Kind = construct(_, _, _, _, _, _, _)
+ ; Kind = deconstruct(_, _, _, _, _, _)
+ ; Kind = assign(_, _)
+ ; Kind = simple_test(_, _)
+ )
;
- true
+ Kind = complicated_unify(_, _, _),
+ unexpected(this_file, "complicated unify during trail usage analysis.")
),
Status = trail_will_not_modify.
annotate_goal_2(VarTypes, _, !Goal, Status, !ModuleInfo, !IO) :-
Index: compiler/tupling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/tupling.m,v
retrieving revision 1.41
diff -u -r1.41 tupling.m
--- compiler/tupling.m 12 Nov 2007 03:52:45 -0000 1.41
+++ compiler/tupling.m 21 Nov 2007 15:38:11 -0000
@@ -1030,11 +1030,11 @@
arg_info.compute_in_and_out_vars(ModuleInfo, ArgVars,
ArgModes, ArgTypes, InputArgs, OutputArgs),
- % Casts are generated inline.
- ( GenericCall = cast(_) ->
- cls_require_in_regs(CountInfo, InputArgs, !CountState),
- cls_put_in_regs(OutputArgs, !CountState)
- ;
+ (
+ ( GenericCall = higher_order(_, _, _, _)
+ ; GenericCall = class_method(_, _, _, _)
+ ; GenericCall = event_call(_)
+ ),
module_info_get_globals(ModuleInfo, Globals),
call_gen.generic_call_info(Globals, GenericCall,
length(InputArgs), _, GenericVarsArgInfos, _, _),
@@ -1043,6 +1043,11 @@
set.list_to_set(OutputArgs, Outputs),
count_load_stores_for_call(CountInfo, Inputs, Outputs,
MaybeNeedAcrossCall, GoalInfo, !CountState)
+ ;
+ GenericCall = cast(_),
+ % Casts are generated inline.
+ cls_require_in_regs(CountInfo, InputArgs, !CountState),
+ cls_put_in_regs(OutputArgs, !CountState)
).
count_load_stores_in_goal_expr(GoalExpr, GoalInfo, CountInfo, !CountState) :-
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.93
diff -u -r1.93 type_ctor_info.m
--- compiler/type_ctor_info.m 2 Oct 2007 07:41:47 -0000 1.93
+++ compiler/type_ctor_info.m 21 Nov 2007 06:59:19 -0000
@@ -399,7 +399,8 @@
),
some [!Flags] (
!:Flags = set.init,
- ( TypeBody = hlds_du_type(_, _, _, _, BodyReservedTag, _, _) ->
+ (
+ TypeBody = hlds_du_type(_, _, _, _, BodyReservedTag, _, _),
svset.insert(kind_of_du_flag, !Flags),
(
BodyReservedTag = uses_reserved_tag,
@@ -408,7 +409,11 @@
BodyReservedTag = does_not_use_reserved_tag
)
;
- true
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
+ )
),
TypeCtorData = type_ctor_data(Version, ModuleName, TypeName, TypeArity,
UnifyUniv, CompareUniv, !.Flags, Details)
@@ -684,11 +689,29 @@
"functor in foreign enum has nonzero arity"),
ConsId = make_cons_id_from_qualified_sym_name(SymName, FunctorArgs),
map.lookup(ConsTagMap, ConsId, ConsTag),
- ( ConsTag = foreign_tag(ForeignTagLang, ForeignTagValue0) ->
+ (
+ ConsTag = foreign_tag(ForeignTagLang, ForeignTagValue0),
expect(unify(Lang, ForeignTagLang), this_file,
"language mismatch between foreign tag and foreign enum."),
ForeignTagValue = ForeignTagValue0
;
+ ( ConsTag = string_tag(_)
+ ; ConsTag = float_tag(_)
+ ; ConsTag = int_tag(_)
+ ; ConsTag = pred_closure_tag(_, _, _)
+ ; ConsTag = type_ctor_info_tag(_, _, _)
+ ; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = tabling_info_tag(_, _)
+ ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ; ConsTag = table_io_decl_tag(_, _)
+ ; ConsTag = single_functor_tag
+ ; ConsTag = unshared_tag(_)
+ ; ConsTag = shared_remote_tag(_, _)
+ ; ConsTag = shared_local_tag(_, _)
+ ; ConsTag = no_tag
+ ; ConsTag = reserved_address_tag(_)
+ ; ConsTag = shared_with_reserved_addresses_tag(_, _)
+ ),
unexpected(this_file, "non foreign tag for foreign enum functor")
),
FunctorName = unqualify_name(SymName),
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.185
diff -u -r1.185 type_util.m
--- compiler/type_util.m 31 Oct 2007 03:58:30 -0000 1.185
+++ compiler/type_util.m 21 Nov 2007 08:10:37 -0000
@@ -426,12 +426,18 @@
true
else
svset.insert(Type, !SeenTypes),
- ( Type = builtin_type(_) ->
- true
- ; Type = tuple_type(Args, _Kind) ->
+ (
+ Type = builtin_type(_)
+ ;
+ Type = tuple_type(Args, _Kind),
types_definitely_have_no_user_defined_eq_pred(ModuleInfo,
Args, !SeenTypes)
;
+ ( Type = defined_type(_, _, _)
+ ; Type = higher_order_type(_, _, _, _)
+ ; Type = apply_n_type(_, _, _)
+ ; Type = kinded_type(_, _)
+ ),
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo,
Type, TypeBody, !SeenTypes),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.426
diff -u -r1.426 typecheck.m
--- compiler/typecheck.m 27 Sep 2007 03:40:18 -0000 1.426
+++ compiler/typecheck.m 21 Nov 2007 08:13:23 -0000
@@ -1591,9 +1591,10 @@
skip_arg([ArgTypeAssign0 | ArgTypeAssigns0],
[ArgTypeAssign | ArgTypeAssigns]) :-
ArgTypeAssign0 = args(TypeAssign, Args0, Constraints),
- ( Args0 = [_ | Args1] ->
- Args = Args1
+ (
+ Args0 = [_ | Args]
;
+ Args0 = [],
% this should never happen
unexpected(this_file, "skip_arg")
),
@@ -2478,9 +2479,16 @@
FieldDefn, FunctorConsTypeInfo, OrigExistTVars, ConsTypeInfo) :-
FunctorConsTypeInfo = cons_type_info(TVarSet0, ExistQVars,
FunctorType, ConsArgTypes, Constraints0, Source0),
- ( Source0 = source_type(SourceTypePrime) ->
+ (
+ Source0 = source_type(SourceTypePrime),
SourceType = SourceTypePrime
;
+ ( Source0 = source_builtin_type(_)
+ ; Source0 = source_get_field_access(_)
+ ; Source0 = source_set_field_access(_)
+ ; Source0 = source_apply(_)
+ ; Source0 = source_pred(_)
+ ),
unexpected(this_file, "convert_field_access_cons_type_info: not type")
),
FieldDefn = hlds_ctor_field_defn(_, _, _, _, FieldNumber),
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.39
diff -u -r1.39 typecheck_errors.m
--- compiler/typecheck_errors.m 17 May 2007 03:52:55 -0000 1.39
+++ compiler/typecheck_errors.m 21 Nov 2007 08:13:53 -0000
@@ -263,10 +263,12 @@
Components = [always(Pieces)]
;
MainPieces = [words("error: undefined"), simple_call(SimpleCallId)],
- ( PredName = qualified(ModuleQualifier, _) ->
+ (
+ PredName = qualified(ModuleQualifier, _),
Pieces = MainPieces ++
maybe_report_missing_import_addendum(Info, ModuleQualifier)
;
+ PredName = unqualified(_),
Pieces = MainPieces ++ [suffix("."), nl]
),
Components = [always(Pieces)]
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.183
diff -u -r1.183 unify_gen.m
--- compiler/unify_gen.m 11 Sep 2007 03:12:34 -0000 1.183
+++ compiler/unify_gen.m 21 Nov 2007 13:46:02 -0000
@@ -87,10 +87,13 @@
%---------------------------------------------------------------------------%
generate_unification(CodeModel, Uni, GoalInfo, Code, !CI) :-
- ( CodeModel = model_non ->
- unexpected(this_file, "nondet unification in generate_unification")
+ (
+ CodeModel = model_det
;
- true
+ CodeModel = model_semi
+ ;
+ CodeModel = model_non,
+ unexpected(this_file, "nondet unification in generate_unification")
),
(
Uni = assign(Left, Right),
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.195
diff -u -r1.195 unify_proc.m
--- compiler/unify_proc.m 31 Oct 2007 13:27:23 -0000 1.195
+++ compiler/unify_proc.m 21 Nov 2007 08:17:26 -0000
@@ -361,7 +361,7 @@
proc_info_get_goal(!.ProcInfo, !:Goal),
set_goal_contexts(Context, !Goal),
-
+
% The X == Y pretest on unifications makes sense only for in-in
% unifications, and if the initial insts are incompatible, then
% casts in the pretest prevents mode analysis from discovering this
@@ -716,8 +716,7 @@
% If this is an equivalence type then we just generate a call
% to the initialisation pred of the type on the RHS of the equivalence
% and cast the result back to the type on the LHS of the equivalence.
- TypeBody = hlds_eqv_type(EqvType)
- ->
+ TypeBody = hlds_eqv_type(EqvType),
goal_info_init(Context, GoalInfo),
make_fresh_named_var_from_type(EqvType, "PreCast_HeadVar", 1, X0,
!Info),
@@ -737,15 +736,14 @@
CastGoal),
Goal = hlds_goal(conj(plain_conj, [InitGoal, CastGoal]), GoalInfo),
quantify_clause_body([X], Goal, Context, Clause, !Info)
- ;
- type_body_has_solver_type_details(ModuleInfo, TypeBody,
- SolverTypeDetails)
- ->
+ ;
+ TypeBody = hlds_solver_type(SolverTypeDetails, _),
+
% Just generate a call to the specified predicate, which is
% the user-defined equality pred for this type.
% (The pred_id and proc_id will be figured out by type checking
% and mode analysis.)
- %
+
HowToInit = SolverTypeDetails ^ init_pred,
(
HowToInit = solver_init_automatic(InitPred)
@@ -761,6 +759,10 @@
Goal = hlds_goal(Call, GoalInfo),
quantify_clause_body([X], Goal, Context, Clause, !Info)
;
+ ( TypeBody = hlds_du_type(_, _, _, _, _, _, _)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_abstract_type(_)
+ ),
unexpected(this_file, "generate_initialise_proc_body: " ++
"trying to create initialisation proc for type " ++
"that has no solver_type_details")
@@ -912,7 +914,8 @@
generate_user_defined_unify_proc_body(UserEqCompare, X, Y, Context, Clause,
!Info) :-
UserEqCompare = unify_compare(MaybeUnify, MaybeCompare),
- ( MaybeUnify = yes(UnifyPredName) ->
+ (
+ MaybeUnify = yes(UnifyPredName),
% Just generate a call to the specified predicate, which is the
% user-defined equality pred for this type. (The pred_id and proc_id
% will be figured out by type checking and mode analysis.)
@@ -923,25 +926,30 @@
UnifyPredName),
goal_info_init(Context, GoalInfo),
Goal0 = hlds_goal(Call, GoalInfo)
- ; MaybeCompare = yes(ComparePredName) ->
- % Just generate a call to the specified predicate, which is the
- % user-defined comparison pred for this type, and unify the result
- % with `='. (The pred_id and proc_id will be figured out by type
- % checking and mode analysis.)
-
- info_new_var(comparison_result_type, ResultVar, !Info),
- PredId = invalid_pred_id,
- ModeId = invalid_proc_id,
- Call = plain_call(PredId, ModeId, [ResultVar, X, Y], not_builtin, no,
- ComparePredName),
- goal_info_init(Context, GoalInfo),
- CallGoal = hlds_goal(Call, GoalInfo),
-
- create_pure_atomic_complicated_unification(ResultVar, equal_functor,
- Context, umc_explicit, [], UnifyGoal),
- Goal0 = hlds_goal(conj(plain_conj, [CallGoal, UnifyGoal]), GoalInfo)
;
- unexpected(this_file, "generate_user_defined_unify_proc_body")
+ MaybeUnify = no,
+ (
+ MaybeCompare = yes(ComparePredName),
+ % Just generate a call to the specified predicate, which is the
+ % user-defined comparison pred for this type, and unify the result
+ % with `='. (The pred_id and proc_id will be figured out by type
+ % checking and mode analysis.)
+
+ info_new_var(comparison_result_type, ResultVar, !Info),
+ PredId = invalid_pred_id,
+ ModeId = invalid_proc_id,
+ Call = plain_call(PredId, ModeId, [ResultVar, X, Y], not_builtin,
+ no, ComparePredName),
+ goal_info_init(Context, GoalInfo),
+ CallGoal = hlds_goal(Call, GoalInfo),
+
+ create_pure_atomic_complicated_unification(ResultVar, equal_functor,
+ Context, umc_explicit, [], UnifyGoal),
+ Goal0 = hlds_goal(conj(plain_conj, [CallGoal, UnifyGoal]), GoalInfo)
+ ;
+ MaybeCompare = no,
+ unexpected(this_file, "generate_user_defined_unify_proc_body")
+ )
),
maybe_wrap_with_pretest_equality(Context, X, Y, no, Goal0, Goal, !Info),
quantify_clause_body([X, Y], Goal, Context, Clause, !Info).
@@ -958,10 +966,8 @@
% its unification procedure directly; if it is a concrete type,
% we should generate the body of its unification procedure
% inline here.
- make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 1, CastX,
- !Info),
- make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 2, CastY,
- !Info),
+ make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 1, CastX, !Info),
+ make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 2, CastY, !Info),
generate_cast(equiv_type_cast, X, CastX, Context, CastXGoal),
generate_cast(equiv_type_cast, Y, CastY, Context, CastYGoal),
create_pure_atomic_complicated_unification(CastX, rhs_var(CastY),
@@ -2100,7 +2106,7 @@
).
% We can start unify and compare predicates that may call other predicates
- % with an equality test, since it often succeeds, and when it does, it is
+ % with an equality test, since it often succeeds, and when it does, it is
% faster than executing the rest of the predicate body.
%
:- func should_pretest_equality(unify_proc_info) = bool.
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.123
diff -u -r1.123 unique_modes.m
--- compiler/unique_modes.m 14 Aug 2007 01:52:30 -0000 1.123
+++ compiler/unique_modes.m 21 Nov 2007 08:19:31 -0000
@@ -559,42 +559,47 @@
mode_info_get_errors(!.ModeInfo, Errors),
mode_info_set_errors(OldErrors, !ModeInfo),
mode_info_get_may_change_called_proc(!.ModeInfo, MayChangeCalledProc),
- ( Errors = [] ->
+ (
+ Errors = [],
ProcId = ProcId0
- ; MayChangeCalledProc = may_not_change_called_proc ->
- % We're not allowed to try a different procedure here, so just return
- % all the errors.
- ProcId = ProcId0,
- list.append(OldErrors, Errors, AllErrors),
- mode_info_set_errors(AllErrors, !ModeInfo)
;
- % If it didn't work, restore the original instmap, and then call
- % modecheck_call_pred. That will try all the modes, and will infer
- % new ones if necessary.
- %
- % We set the declared determinism for newly inferred modes to be the
- % same as the determinism inferred for the existing mode selected by
- % ordinary (non-unique) mode analysis. This means that determinism
- % analysis will report an error if the determinism changes as a result
- % of unique mode analysis. That is OK, because uniqueness should not
- % affect determinism.
- mode_info_set_instmap(InstMap0, !ModeInfo),
- proc_info_get_inferred_determinism(ProcInfo, Determinism),
- modecheck_call_pred(PredId, yes(Determinism), ProcId0, ProcId,
- ArgVars, NewArgVars, GoalInfo, ExtraGoals, !ModeInfo),
-
+ Errors = [_ | _],
(
- NewArgVars = ArgVars,
- ExtraGoals = no_extra_goals
- ->
- true
+ MayChangeCalledProc = may_not_change_called_proc,
+ % We're not allowed to try a different procedure here, so just
+ % return all the errors.
+ ProcId = ProcId0,
+ list.append(OldErrors, Errors, AllErrors),
+ mode_info_set_errors(AllErrors, !ModeInfo)
;
- % This shouldn't happen, since modes.m should do all the handling
- % of implied modes
- % XXX it might happen, though, if the user
- % XXX writes strange code; we should report
- % XXX a proper error here
- unexpected(this_file, "call to implied mode?")
+ MayChangeCalledProc = may_change_called_proc,
+ % If it didn't work, restore the original instmap, and then call
+ % modecheck_call_pred. That will try all the modes, and will infer
+ % new ones if necessary.
+ %
+ % We set the declared determinism for newly inferred modes to be
+ % the same as the determinism inferred for the existing mode
+ % selected by ordinary (non-unique) mode analysis. This means that
+ % determinism analysis will report an error if the determinism
+ % changes as a result of unique mode analysis. That is OK, because
+ % uniqueness should not affect determinism.
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ proc_info_get_inferred_determinism(ProcInfo, Determinism),
+ modecheck_call_pred(PredId, yes(Determinism), ProcId0, ProcId,
+ ArgVars, NewArgVars, GoalInfo, ExtraGoals, !ModeInfo),
+
+ (
+ NewArgVars = ArgVars,
+ ExtraGoals = no_extra_goals
+ ->
+ true
+ ;
+ % This shouldn't happen, since modes.m should do all the
+ % handling of implied modes.
+ % XXX It might happen, though, if the user writes strange code;
+ % we should report a proper error here.
+ unexpected(this_file, "call to implied mode?")
+ )
)
).
Index: compiler/unneeded_code.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unneeded_code.m,v
retrieving revision 1.44
diff -u -r1.44 unneeded_code.m
--- compiler/unneeded_code.m 12 Nov 2007 03:52:45 -0000 1.44
+++ compiler/unneeded_code.m 21 Nov 2007 15:31:57 -0000
@@ -1152,22 +1152,33 @@
get_parent_branch_point(GoalPath, ParentPath, ParentStep,
BranchAlt, BranchNum) :-
cord.split_last(GoalPath, InitialPath, LastStep),
- ( LastStep = step_switch(Arm, MaybeNumAlts) ->
+ (
+ LastStep = step_switch(Arm, MaybeNumAlts),
ParentPath = InitialPath,
ParentStep = LastStep,
BranchAlt = alt_switch(MaybeNumAlts),
BranchNum = Arm
- ; LastStep = step_ite_then ->
+ ;
+ LastStep = step_ite_then,
ParentPath = InitialPath,
ParentStep = LastStep,
BranchAlt = alt_ite,
BranchNum = 1
- ; LastStep = step_ite_else ->
+ ;
+ LastStep = step_ite_else,
ParentPath = InitialPath,
ParentStep = LastStep,
BranchAlt = alt_ite,
BranchNum = 2
;
+ ( LastStep = step_ite_cond
+ ; LastStep = step_neg
+ ; LastStep = step_scope(_)
+ ; LastStep = step_conj(_)
+ ; LastStep = step_disj(_)
+ ; LastStep = step_first
+ ; LastStep = step_later
+ ),
get_parent_branch_point(InitialPath, ParentPath, ParentStep,
BranchAlt, BranchNum)
).
Index: compiler/use_local_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/use_local_vars.m,v
retrieving revision 1.36
diff -u -r1.36 use_local_vars.m
--- compiler/use_local_vars.m 11 Oct 2007 11:45:20 -0000 1.36
+++ compiler/use_local_vars.m 21 Nov 2007 14:22:14 -0000
@@ -414,15 +414,19 @@
Instrs2 = [TempAssign | Instrs1],
opt_access(Instrs2, Instrs, !TempCounter, NumRealRRegs,
AlreadyTried1, AccessThreshold)
- ; ChooseableRvals = [_ | _] ->
- !:TempCounter = OrigTempCounter,
- opt_access([Instr0 | TailInstrs0], Instrs, !TempCounter,
- NumRealRRegs, AlreadyTried1, AccessThreshold)
;
- !:TempCounter = OrigTempCounter,
- opt_access(TailInstrs0, TailInstrs, !TempCounter, NumRealRRegs,
- set.init, AccessThreshold),
- Instrs = [Instr0 | TailInstrs]
+ (
+ ChooseableRvals = [_ | _],
+ !:TempCounter = OrigTempCounter,
+ opt_access([Instr0 | TailInstrs0], Instrs, !TempCounter,
+ NumRealRRegs, AlreadyTried1, AccessThreshold)
+ ;
+ ChooseableRvals = [],
+ !:TempCounter = OrigTempCounter,
+ opt_access(TailInstrs0, TailInstrs, !TempCounter, NumRealRRegs,
+ set.init, AccessThreshold),
+ Instrs = [Instr0 | TailInstrs]
+ )
)
;
opt_access(TailInstrs0, TailInstrs, !TempCounter, NumRealRRegs,
@@ -505,11 +509,18 @@
substitute_lval_in_defn_components(_OldLval, _NewLval, [], [], !NumSubsts).
substitute_lval_in_defn_components(OldLval, NewLval,
[Comp0 | Comps0], [Comp | Comps], !NumSubsts) :-
- ( Comp0 = foreign_proc_outputs(Outputs0) ->
+ (
+ Comp0 = foreign_proc_outputs(Outputs0),
substitute_lval_in_defn_outputs(OldLval, NewLval,
Outputs0, Outputs, !NumSubsts),
Comp = foreign_proc_outputs(Outputs)
;
+ ( Comp0 = foreign_proc_inputs(_)
+ ; Comp0 = foreign_proc_user_code(_, _, _)
+ ; Comp0 = foreign_proc_raw_code(_, _, _, _)
+ ; Comp0 = foreign_proc_fail_to(_)
+ ; Comp0 = foreign_proc_noop
+ ),
Comp = Comp0
),
substitute_lval_in_defn_components(OldLval, NewLval, Comps0, Comps,
Index: compiler/var_locn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/var_locn.m,v
retrieving revision 1.51
diff -u -r1.51 var_locn.m
--- compiler/var_locn.m 9 Jul 2007 13:28:29 -0000 1.51
+++ compiler/var_locn.m 21 Nov 2007 13:51:09 -0000
@@ -931,7 +931,8 @@
(
MaybeRval0 = yes(Rval0),
Target = field(Ptag, Base, const(llconst_int(Offset))),
- ( Rval0 = var(Var) ->
+ (
+ Rval0 = var(Var),
find_var_availability(!.VLI, Var, no, Avail),
(
Avail = available(Rval),
@@ -951,11 +952,18 @@
Comment = "assigning from " ++ VarName,
AssignCode = node([llds_instr(assign(Target, Rval), Comment)])
)
- ; Rval0 = const(_) ->
+ ;
+ Rval0 = const(_),
EvalCode = empty,
Comment = "assigning field from const",
AssignCode = node([llds_instr(assign(Target, Rval0), Comment)])
;
+ ( Rval0 = mkword(_, _)
+ ; Rval0 = binop(_, _, _)
+ ; Rval0 = unop(_, _)
+ ; Rval0 = lval(_)
+ ; Rval0 = mem_addr(_)
+ ),
unexpected(this_file, "assign_cell_args: unknown rval")
),
ThisCode = tree(EvalCode, AssignCode)
Index: compiler/wrap_blocks.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/wrap_blocks.m,v
retrieving revision 1.16
diff -u -r1.16 wrap_blocks.m
--- compiler/wrap_blocks.m 6 Jan 2007 09:23:59 -0000 1.16
+++ compiler/wrap_blocks.m 21 Nov 2007 13:51:40 -0000
@@ -57,12 +57,16 @@
list(instruction)::in, list(instruction)::out) is det.
wrap_instrs([], R, F, RevSofar, []) :-
- ( RevSofar = [_ | _] ->
+ (
+ RevSofar = [_ | _],
unexpected(this_file, "procedure ends with fallthrough")
- ; ( R > 0 ; F > 0 ) ->
- unexpected(this_file, "procedure ends without closing block")
;
- true
+ RevSofar = [],
+ ( ( R > 0 ; F > 0 ) ->
+ unexpected(this_file, "procedure ends without closing block")
+ ;
+ true
+ )
).
wrap_instrs([Instr0 | Instrs0], R0, F0, RevSofar, Instrs) :-
Instr0 = llds_instr(Uinstr0, _Comment0),
Index: compiler/x86_64_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/x86_64_out.m,v
retrieving revision 1.4
diff -u -r1.4 x86_64_out.m
--- compiler/x86_64_out.m 27 Feb 2007 20:36:29 -0000 1.4
+++ compiler/x86_64_out.m 21 Nov 2007 14:29:41 -0000
@@ -555,14 +555,12 @@
check_operand_register(Dest, DestRes),
(
DestRes = yes,
- ( Cond = f ->
+ (
+ Cond = f,
Instr = "bsf"
;
- Cond = r ->
+ Cond = r,
Instr = "bsr"
- ;
- unexpected(this_file, "output_x86_64_inst: bs: unexpected:"
- ++ " invalid condition third operand")
),
put(Stream, "\t" ++ Instr ++ "\t", !IO),
operand_to_string(Dest, DestType),
@@ -797,9 +795,11 @@
).
output_x86_64_inst(Stream, ret(Op), !IO) :-
(
+ Op = no,
+ put(Stream, "\tret\t\t", !IO)
+ ;
Op = yes(OpRes),
- OpRes = uint16(NumBytes)
- ->
+ OpRes = uint16(NumBytes),
check_unsigned_int_size(16, NumBytes, Result),
(
Result = yes,
@@ -811,13 +811,6 @@
unexpected(this_file, "output_x86_64_instr: ret: unexpected:"
++ "check_unsigned_int_size failed")
)
- ;
- Op = no
- ->
- put(Stream, "\tret\t\t", !IO)
- ;
- unexpected(this_file, "output_x86_64_instr: ret: unexpected"
- ++ " invalid operand")
).
output_x86_64_inst(Stream, ro(Amnt, Dest, Dir), !IO) :-
check_operand_not_mem_ref(Amnt, Result1),
@@ -1361,7 +1354,8 @@
:- pred check_rc_first_operand(operand::in, bool::out) is det.
check_rc_first_operand(Op, Result) :-
- ( Op = operand_imm(_) ->
+ (
+ Op = operand_imm(_),
operand_to_string(Op, OpType),
( string.to_int(OpType, OpInt) ->
check_unsigned_int_size(8, OpInt, Result1),
@@ -1373,11 +1367,11 @@
Result = no
)
;
- unexpected(this_file, "check_rc_first_operand: unexpected:"
- ++ " string.to_int")
+ unexpected(this_file,
+ "check_rc_first_operand: unexpected: string.to_int")
)
;
- Op = operand_reg(_) ->
+ Op = operand_reg(_),
check_operand_register(Op, Result2),
(
Result2 = yes,
@@ -1387,8 +1381,12 @@
Result = no
)
;
- unexpected(this_file, "check_rc_first_operand: unexpected:"
- ++ " invalid operand")
+ ( Op = operand_mem_ref(_)
+ ; Op = operand_rel_offset(_)
+ ; Op = operand_label(_)
+ ),
+ unexpected(this_file,
+ "check_rc_first_operand: unexpected: invalid operand")
).
:- pred check_not_both_memory_ops(operand::in, operand::in, bool::out) is det.
Index: compiler/x86_64_regs.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/x86_64_regs.m,v
retrieving revision 1.1
diff -u -r1.1 x86_64_regs.m
--- compiler/x86_64_regs.m 27 Feb 2007 20:36:29 -0000 1.1
+++ compiler/x86_64_regs.m 21 Nov 2007 14:02:09 -0000
@@ -179,16 +179,26 @@
; Lval = prevfr_slot(_)
; Lval = mem_ref(_)
; Lval = global_var_ref(_)
- )
- ->
+ ),
unexpected(this_file, "reg_map_lookup_reg_locn: unexpected: "
++ "lval is not a virtual machine register")
;
- Lval = lvar(_)
- ->
+ Lval = lvar(_),
unexpected(this_file, "reg_map_lookup_reg_locn: unexpected: "
++ "lvar/1 during x86_64 code generation")
;
+ ( Lval = reg(_, _)
+ ; Lval = temp(_, _)
+ ; Lval = succip
+ ; Lval = maxfr
+ ; Lval = curfr
+ ; Lval = hp
+ ; Lval = sp
+ ; Lval = parent_sp
+ ; Lval = stackvar(_)
+ ; Lval = framevar(_)
+ ; Lval = field(_, _, _)
+ ),
map.lookup(RegMap, Lval, RegLocn)
).
Index: compiler/xml_documentation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/xml_documentation.m,v
retrieving revision 1.17
diff -u -r1.17 xml_documentation.m
--- compiler/xml_documentation.m 25 Sep 2007 04:56:44 -0000 1.17
+++ compiler/xml_documentation.m 21 Nov 2007 08:20:37 -0000
@@ -149,18 +149,24 @@
line_type(Line) = LineType :-
list.takewhile(char.is_whitespace, Line, _WhiteSpace, Rest),
list.takewhile(is_not_comment_char, Rest, Decl, Comment),
- ( Rest = [] ->
+ (
+ Rest = [],
LineType = blank
- ; Comment = [_ | _] ->
+ ;
+ Rest = [_ | _],
(
- Decl = [],
- LineType = comment(string.from_char_list(Comment))
+ Comment = [],
+ LineType = code
;
- Decl = [_ | _],
- LineType = code_and_comment(string.from_char_list(Comment))
+ Comment = [_ | _],
+ (
+ Decl = [],
+ LineType = comment(string.from_char_list(Comment))
+ ;
+ Decl = [_ | _],
+ LineType = code_and_comment(string.from_char_list(Comment))
+ )
)
- ;
- LineType = code
).
:- pred is_not_comment_char(char::in) is semidet.
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
Index: deep_profiler/canonical.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/canonical.m,v
retrieving revision 1.14
diff -u -r1.14 canonical.m
--- deep_profiler/canonical.m 1 Dec 2006 15:03:45 -0000 1.14
+++ deep_profiler/canonical.m 21 Nov 2007 23:54:44 -0000
@@ -90,23 +90,27 @@
redirect::in, redirect::out) is det.
merge_clique(CliquePDs0, MergeInfo, !InitDeep, !Redirect) :-
- ( CliquePDs0 = [_, _ | _] ->
+ (
+ CliquePDs0 = []
+ ;
+ CliquePDs0 = [_]
+ ;
+ CliquePDs0 = [_, _ | _],
map.init(ProcMap0),
list.foldl(cluster_pds_by_ps(!.InitDeep), CliquePDs0,
ProcMap0, ProcMap1),
map.values(ProcMap1, PDsList1),
list.filter(two_or_more, PDsList1, ToMergePDsList1),
- ( ToMergePDsList1 = [_ | _] ->
+ (
+ ToMergePDsList1 = [_ | _],
complete_clique(!.InitDeep, !.Redirect, ProcMap1, ProcMap, Clique),
map.values(ProcMap, PDsList),
list.filter(two_or_more, PDsList, ToMergePDsList),
list.foldl2(merge_proc_dynamics_ignore_chosen(MergeInfo, Clique),
ToMergePDsList, !InitDeep, !Redirect)
;
- true
+ ToMergePDsList1 = []
)
- ;
- true
).
:- pred insert_pds(list(T)::in, set(T)::in, set(T)::out) is det.
@@ -235,7 +239,8 @@
list.filter(valid_proc_dynamic_ptr_raw(ProcDynamics0),
CandidatePDPtrs, ValidPDPtrs, InvalidPDPtrs),
require(unify(InvalidPDPtrs, []), "merge_proc_dynamics: invalid pdptrs"),
- ( ValidPDPtrs = [PrimePDPtr | RestPDPtrs] ->
+ (
+ ValidPDPtrs = [PrimePDPtr | RestPDPtrs],
record_pd_redirect(RestPDPtrs, PrimePDPtr, !Redirect),
lookup_proc_dynamics(ProcDynamics0, PrimePDPtr, PrimePD0),
list.map(lookup_proc_dynamics(ProcDynamics0), RestPDPtrs, RestPDs),
@@ -252,6 +257,7 @@
!:InitDeep = !.InitDeep ^ init_proc_dynamics := ProcDynamics,
ChosenPDPtr = PrimePDPtr
;
+ ValidPDPtrs = [],
% This could happen when merging the callees of CSDs representing
% special calls, but only before we added callcode to the
% unify/compare routines of builtin types.
@@ -775,7 +781,8 @@
is det.
merge_profiles(InitDeeps, MaybeMergedInitDeep) :-
- ( InitDeeps = [FirstInitDeep | LaterInitDeeps] ->
+ (
+ InitDeeps = [FirstInitDeep | LaterInitDeeps],
( all_compatible(FirstInitDeep, LaterInitDeeps) ->
do_merge_profiles(FirstInitDeep, LaterInitDeeps, MergedInitDeep),
MaybeMergedInitDeep = ok(MergedInitDeep)
@@ -784,6 +791,7 @@
error("profiles are not from the same executable")
)
;
+ InitDeeps = [],
MaybeMergedInitDeep = error("merge_profiles: empty list of profiles")
).
Index: deep_profiler/conf.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/conf.m,v
retrieving revision 1.11
diff -u -r1.11 conf.m
--- deep_profiler/conf.m 2 Apr 2007 02:34:36 -0000 1.11
+++ deep_profiler/conf.m 21 Nov 2007 23:53:44 -0000
@@ -87,27 +87,38 @@
ServerRedirectCmd =
string.format("%s > %s", [s(HostnameCmd), s(TmpFile)]),
io.call_system(ServerRedirectCmd, Res1, !IO),
- ( Res1 = ok(0) ->
- io.open_input(TmpFile, TmpRes, !IO),
- ( TmpRes = ok(TmpStream) ->
- io.read_file_as_string(TmpStream, TmpReadRes, !IO),
+ (
+ Res1 = ok(ResCode),
+ ( ResCode = 0 ->
+ io.open_input(TmpFile, TmpRes, !IO),
(
- TmpReadRes = ok(ServerNameNl),
- ( string.remove_suffix(ServerNameNl, "\n", ServerNamePrime) ->
- ServerName = ServerNamePrime
+ TmpRes = ok(TmpStream),
+ io.read_file_as_string(TmpStream, TmpReadRes, !IO),
+ (
+ TmpReadRes = ok(ServerNameNl),
+ (
+ string.remove_suffix(ServerNameNl, "\n",
+ ServerNamePrime)
+ ->
+ ServerName = ServerNamePrime
+ ;
+ error("malformed server name")
+ )
;
- error("malformed server name")
- )
+ TmpReadRes = error(_, _),
+ error("cannot read server's name")
+ ),
+ io.close_input(TmpStream, !IO)
;
- TmpReadRes = error(_, _),
- error("cannot read server's name")
+ TmpRes = error(_),
+ error("cannot open file to find the server's name")
),
- io.close_input(TmpStream, !IO)
+ io.remove_file(TmpFile, _, !IO)
;
- error("cannot open file to find the server's name")
- ),
- io.remove_file(TmpFile, _, !IO)
+ error("cannot execute cmd to find the server's name")
+ )
;
+ Res1 = error(_),
error("cannot execute cmd to find the server's name")
).
Index: deep_profiler/dump.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/dump.m,v
retrieving revision 1.11
diff -u -r1.11 dump.m
--- deep_profiler/dump.m 12 Sep 2007 06:21:10 -0000 1.11
+++ deep_profiler/dump.m 21 Nov 2007 23:54:10 -0000
@@ -400,7 +400,13 @@
;
InInterface = no
),
- IsZeroStr = (IsZeroed = zeroed -> "zeroed" ; "not_zeroed" ),
+ (
+ IsZeroed = zeroed,
+ IsZeroStr = "zeroed"
+ ;
+ IsZeroed = not_zeroed,
+ IsZeroStr = "not_zeroed"
+ ),
io.format("\t%s\n", [s(IsZeroStr)], !IO),
array_foldl_from_0(dump_proc_static_call_sites, Sites, !IO),
io.nl(!IO)
Index: deep_profiler/interface.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/interface.m,v
retrieving revision 1.18
diff -u -r1.18 interface.m
--- deep_profiler/interface.m 27 Sep 2007 07:28:35 -0000 1.18
+++ deep_profiler/interface.m 21 Nov 2007 23:58:07 -0000
@@ -466,21 +466,25 @@
send_term(ToPipeName, Debug, Data, !IO) :-
io.open_output(ToPipeName, Res, !IO),
- ( Res = ok(ToStream) ->
+ (
+ Res = ok(ToStream),
io.write(ToStream, Data, !IO),
io.write_string(ToStream, ".\n", !IO),
io.close_output(ToStream, !IO)
;
+ Res = error(_),
error("send_term: couldn't open pipe")
),
(
Debug = yes,
io.open_output("/tmp/.send_term", Res2, !IO),
- ( Res2 = ok(DebugStream) ->
+ (
+ Res2 = ok(DebugStream),
io.write(DebugStream, Data, !IO),
io.write_string(DebugStream, ".\n", !IO),
io.close_output(DebugStream, !IO)
;
+ Res2 = error(_),
error("send_term: couldn't debug")
)
;
@@ -489,19 +493,23 @@
send_string(ToPipeName, Debug, Data, !IO) :-
io.open_output(ToPipeName, Res, !IO),
- ( Res = ok(ToStream) ->
+ (
+ Res = ok(ToStream),
io.write_string(ToStream, Data, !IO),
io.close_output(ToStream, !IO)
;
+ Res = error(_),
error("send_string: couldn't open pipe")
),
(
Debug = yes,
io.open_output("/tmp/.send_string", Res2, !IO),
- ( Res2 = ok(DebugStream) ->
+ (
+ Res2 = ok(DebugStream),
io.write_string(DebugStream, Data, !IO),
io.close_output(DebugStream, !IO)
;
+ Res2 = error(_),
error("send_string: couldn't debug")
)
;
@@ -510,55 +518,70 @@
recv_term(FromPipeName, Debug, Resp, !IO) :-
io.open_input(FromPipeName, Res0, !IO),
- ( Res0 = ok(FromStream) ->
+ (
+ Res0 = ok(FromStream),
io.read(FromStream, Res1, !IO),
- ( Res1 = ok(Resp0) ->
+ (
+ Res1 = ok(Resp0),
Resp = Resp0
;
+ Res1 = eof,
+ error("recv_term: read failed")
+ ;
+ Res1 = error(_, _),
error("recv_term: read failed")
),
io.close_input(FromStream, !IO),
(
Debug = yes,
io.open_output("/tmp/.recv_term", Res2, !IO),
- ( Res2 = ok(DebugStream) ->
+ (
+ Res2 = ok(DebugStream),
io.write(DebugStream, Res1, !IO),
io.write_string(DebugStream, ".\n", !IO),
io.close_output(DebugStream, !IO)
;
+ Res2 = error(_),
error("recv_term: couldn't debug")
)
;
Debug = no
)
;
+ Res0 = error(_),
error("recv_term: couldn't open pipe")
).
recv_string(FromPipeName, Debug, Resp, !IO) :-
io.open_input(FromPipeName, Res0, !IO),
- ( Res0 = ok(FromStream) ->
+ (
+ Res0 = ok(FromStream),
io.read_file_as_string(FromStream, Res1, !IO),
- ( Res1 = ok(Resp0) ->
+ (
+ Res1 = ok(Resp0),
Resp = Resp0
;
+ Res1 = error(_, _),
error("recv_string: read failed")
),
io.close_input(FromStream, !IO),
(
Debug = yes,
io.open_output("/tmp/.recv_string", Res2, !IO),
- ( Res2 = ok(DebugStream) ->
+ (
+ Res2 = ok(DebugStream),
io.write(DebugStream, Res1, !IO),
io.write_string(DebugStream, ".\n", !IO),
io.close_output(DebugStream, !IO)
;
+ Res2 = error(_),
error("recv_string: couldn't debug")
)
;
Debug = no
)
;
+ Res0 = error(_),
error("recv_term: couldn't open pipe")
).
Index: deep_profiler/mdprof_cgi.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/mdprof_cgi.m,v
retrieving revision 1.19
diff -u -r1.19 mdprof_cgi.m
--- deep_profiler/mdprof_cgi.m 23 May 2007 10:09:24 -0000 1.19
+++ deep_profiler/mdprof_cgi.m 21 Nov 2007 23:59:18 -0000
@@ -259,13 +259,14 @@
lookup_bool_option(Options, debug, Debug),
trace [compiletime(flag("debug_client_server")), io(!S)] (
io.open_append("/tmp/deep_debug", Res1, !S),
- ( Res1 = ok(DebugStream1) ->
+ (
+ Res1 = ok(DebugStream1),
io.write_string(DebugStream1,
"sending query to existing server.\n", !S),
io.write(DebugStream1, cmd_pref(Cmd, PrefInd), !S),
io.close_output(DebugStream1, !S)
;
- true
+ Res1 = error(_)
)
),
send_term(ToServerPipe, Debug, cmd_pref(Cmd, PrefInd), !IO),
@@ -276,7 +277,8 @@
io.call_system(CatCmd, _, !IO),
trace [compiletime(flag("debug_client_server")), io(!T)] (
io.open_append("/tmp/deep_debug", Res2, !T),
- ( Res2 = ok(DebugStream2) ->
+ (
+ Res2 = ok(DebugStream2),
io.write_string(DebugStream2,
"sending reply from existing server.\n", !T),
io.close_output(DebugStream2, !T),
@@ -284,7 +286,7 @@
[s(ResponseFileName)]),
io.call_system(DebugCatCmd, _, !T)
;
- true
+ Res2 = error(_)
)
),
(
Index: deep_profiler/query.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/query.m,v
retrieving revision 1.17
diff -u -r1.17 query.m
--- deep_profiler/query.m 27 Sep 2007 07:28:35 -0000 1.17
+++ deep_profiler/query.m 22 Nov 2007 00:04:41 -0000
@@ -611,12 +611,19 @@
generate_top_procs_page(Cmd, Limit, CostKind, InclDesc0, Scope0, Pref, Deep)
= HTML :-
- ( CostKind = cost_calls ->
+ (
+ CostKind = cost_calls,
% Counting calls is incompatible both with self_and_desc
% and per_call.
InclDesc = self,
Scope = overall
;
+ ( CostKind = cost_redos
+ ; CostKind = cost_time
+ ; CostKind = cost_callseqs
+ ; CostKind = cost_allocs
+ ; CostKind = cost_words
+ ),
InclDesc = InclDesc0,
Scope = Scope0
),
@@ -718,10 +725,14 @@
PSPtrs),
Criteria = Pref ^ pref_criteria,
SortedProcLines = sort_line_groups(Criteria, ProcLines),
- ( Criteria = by_cost(_, _, _) ->
+ (
+ Criteria = by_cost(_, _, _),
IdHeaders = rank_proc,
RankedProcLines = add_ranks(SortedProcLines)
;
+ ( Criteria = by_name
+ ; Criteria = by_context
+ ),
IdHeaders = source_proc,
RankedProcLines = list.map(add_self_context, SortedProcLines)
),
@@ -845,13 +856,16 @@
procs_in_clique_to_html(Pref, Deep, CliquePtr, Percent, PSPtr - PDPtrs,
HTML, ActionPtrs) :-
- ( PDPtrs = [] ->
+ (
+ PDPtrs = [],
HTML = "",
ActionPtrs = []
- ; PDPtrs = [PDPtr] ->
+ ;
+ PDPtrs = [PDPtr],
proc_in_clique_to_html(Pref, Deep, CliquePtr, Percent, PDPtr,
HTML, ActionPtrs)
;
+ PDPtrs = [_, _ | _],
list.map(deep_lookup_pd_own(Deep), PDPtrs, ProcOwns),
list.map(deep_lookup_pd_desc(Deep), PDPtrs, ProcDescs),
ProcOwn = sum_own_infos(ProcOwns),
@@ -1004,17 +1018,21 @@
deep_lookup_call_site_statics(Deep, CSSPtr, CSS),
Kind = CSS ^ css_kind,
( Kind = normal_call_and_callee(_CalleePSPtr, _) ->
- ( CallSiteArraySlot = slot_normal(CSDPtr0) ->
+ (
+ CallSiteArraySlot = slot_normal(CSDPtr0),
CSDPtr = CSDPtr0
;
+ CallSiteArraySlot = slot_multi(_, _),
error("call_site_clique_to_html: normal_call error")
),
normal_call_site_clique_to_html(Pref, Deep, CallerCliquePtr,
CSDPtr, LineGroups, Percent, ActionPtrs)
;
- ( CallSiteArraySlot = slot_multi(_, CSDPtrs0) ->
+ (
+ CallSiteArraySlot = slot_multi(_, CSDPtrs0),
array.to_list(CSDPtrs0, CSDPtrs)
;
+ CallSiteArraySlot = slot_normal(_),
error("call_site_clique_to_html: non-normal_call error")
),
call_site_context(Deep, CSSPtr, FileName, LineNumber),
@@ -1135,7 +1153,8 @@
CallerPSPtr, CalleePSPtr, CallSiteCallList) = LineGroup :-
deep_lookup_proc_statics(Deep, CalleePSPtr, CalleePS),
ProcName = CalleePS ^ ps_refined_id,
- ( CallSiteCallList = [] ->
+ (
+ CallSiteCallList = [],
Own = zero_own_prof_info,
Desc = zero_inherit_prof_info,
SummaryHTML =
@@ -1144,7 +1163,8 @@
LineGroup = line_group(FileName, LineNumber,
ProcName, Own, Desc, SummaryHTML,
sub_lines(two_id, []))
- ; CallSiteCallList = [CallSiteCall] ->
+ ;
+ CallSiteCallList = [CallSiteCall],
CallSiteCall = CalleePSPtrFromCall - _,
require(unify(CalleePSPtr, CalleePSPtrFromCall),
"call_site_summary_to_html: callee mismatch"),
@@ -1152,6 +1172,7 @@
FileName, LineNumber, ProcName, CallerPSPtr, CallSiteCall),
LineGroup = line_to_two_id_subline_group(LineGroup0)
;
+ CallSiteCallList = [_, _ | _],
error("normal_call_site_summary_to_html: too many procedures")
).
@@ -1204,12 +1225,19 @@
:- func multi_call_site_add_suffix(preferences, string, list(T)) = string.
multi_call_site_add_suffix(Pref, RawCallSiteName, CallList) = CallSiteName :-
- ( CallList = [] ->
+ (
+ CallList = [],
CallSiteName = RawCallSiteName ++ " (no calls made)"
- ; Pref ^ pref_summarize = summarize ->
- CallSiteName = RawCallSiteName ++ " (summary)"
;
- CallSiteName = RawCallSiteName
+ CallList = [_ | _],
+ Summarize = Pref ^ pref_summarize,
+ (
+ Summarize = summarize,
+ CallSiteName = RawCallSiteName ++ " (summary)"
+ ;
+ Summarize = dont_summarize,
+ CallSiteName = RawCallSiteName
+ )
).
%-----------------------------------------------------------------------------%
@@ -1356,9 +1384,11 @@
call_to_html(Pref, Deep, CallSiteDisplay, CallContext,
CallerPDPtr, CalleePDPtr,
MaybeCallerCliquePtr, CalleeCliquePtr) = HTML :-
- ( MaybeCallerCliquePtr = yes(CallerCliquePtr0) ->
+ (
+ MaybeCallerCliquePtr = yes(CallerCliquePtr0),
CallerCliquePtr = CallerCliquePtr0
;
+ MaybeCallerCliquePtr = no,
CallerCliquePtr = dummy_clique_ptr
),
(
@@ -1858,9 +1888,11 @@
two_id_line_group_to_html(Pref, Deep, totals_meaningful),
SortedCallSiteGroups),
string.append_list(BodyHTMLs, BodyHTML0),
- ( SortedCallSiteGroups = [] ->
+ (
+ SortedCallSiteGroups = [],
BodyHTML = BodyHTML0
;
+ SortedCallSiteGroups = [_ | _],
BodyHTML =
BodyHTML0 ++
separator_row(Pref, source_proc, totals_meaningful)
Index: deep_profiler/read_profile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/read_profile.m,v
retrieving revision 1.21
diff -u -r1.21 read_profile.m
--- deep_profiler/read_profile.m 31 Oct 2007 13:15:56 -0000 1.21
+++ deep_profiler/read_profile.m 22 Nov 2007 00:14:52 -0000
@@ -414,7 +414,7 @@
_DefModule, Name, Arity, Mode)) =
string.append_list([DeclModule, ".", Name,
"/", string.int_to_string(Arity),
- ( PredOrFunc = pf_function -> "+1" ; "" ),
+ add_plus_one_for_function(PredOrFunc),
"-", string.int_to_string(Mode)]).
:- func refined_proc_id_to_string(string_proc_label) = string.
@@ -461,7 +461,7 @@
RefinedProcName = string.from_char_list(ProcNameChars),
Name = string.append_list([DeclModule, ".", RefinedProcName,
"/", string.int_to_string(Arity),
- ( PredOrFunc = pf_function -> "+1" ; "" ),
+ add_plus_one_for_function(PredOrFunc),
"-", string.int_to_string(Mode),
" [", SpecInfo, "]"])
;
@@ -483,14 +483,19 @@
Name = string.append_list([DeclModule, ".", ContainingName,
" lambda line ", LineNumber,
"/", string.int_to_string(Arity),
- ( PredOrFunc = pf_function -> "+1" ; "" )])
+ add_plus_one_for_function(PredOrFunc)])
;
Name = string.append_list([DeclModule, ".", ProcName,
"/", string.int_to_string(Arity),
- ( PredOrFunc = pf_function -> "+1" ; "" ),
+ add_plus_one_for_function(PredOrFunc),
"-", string.int_to_string(Mode)])
).
+:- func add_plus_one_for_function(pred_or_func) = string.
+
+add_plus_one_for_function(pf_function) = "+1".
+add_plus_one_for_function(pf_predicate) = "".
+
:- pred fix_type_spec_suffix(list(char)::in, list(char)::out, string::out)
is semidet.
@@ -538,9 +543,11 @@
LineNumber = LineNumberPrime
; Segments = [Segment | TailSegments] ->
glue_lambda_name(TailSegments, PredName1, LineNumber),
- ( PredName1 = [] ->
+ (
+ PredName1 = [],
PredName = Segment
;
+ PredName1 = [_ | _],
list.append(Segment, ['_', '_' | PredName1], PredName)
)
;
@@ -705,7 +712,8 @@
read_call_site_kind(Res1, !IO),
(
Res1 = ok(Kind),
- ( Kind = normal_call ->
+ (
+ Kind = normal_call,
read_ptr(csd, Res2, !IO),
(
Res2 = ok(CSDI),
@@ -722,12 +730,16 @@
)
;
(
- ( Kind = higher_order_call
- ; Kind = method_call
- )
- ->
+ Kind = higher_order_call,
Zeroed = zeroed
;
+ Kind = method_call,
+ Zeroed = zeroed
+ ;
+ Kind = special_call,
+ Zeroed = not_zeroed
+ ;
+ Kind = callback,
Zeroed = not_zeroed
),
read_multi_call_site_csdis(Res2, !IO),
Index: deep_profiler/startup.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/startup.m,v
retrieving revision 1.16
diff -u -r1.16 startup.m
--- deep_profiler/startup.m 2 Apr 2007 02:42:33 -0000 1.16
+++ deep_profiler/startup.m 22 Nov 2007 00:09:55 -0000
@@ -876,9 +876,11 @@
CSDI > 0
), PtrList0, PtrList1),
CSDPtrs1 = [PtrList1 | CSDPtrs0],
- ( IsZeroed1 = zeroed ->
+ (
+ IsZeroed1 = zeroed,
IsZeroed = zeroed
;
+ IsZeroed1 = not_zeroed,
IsZeroed = IsZeroed0
)
).
Index: deep_profiler/top_procs.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/top_procs.m,v
retrieving revision 1.11
diff -u -r1.11 top_procs.m
--- deep_profiler/top_procs.m 27 Sep 2007 07:28:35 -0000 1.11
+++ deep_profiler/top_procs.m 22 Nov 2007 00:12:48 -0000
@@ -134,15 +134,23 @@
compare_procs_fallback(MainFunc, Deep, PSI1, PSI2) = Result :-
Result0 = MainFunc(Deep, PSI1, PSI2),
- ( Result0 \= (=) ->
- Result = Result0
- ;
+ (
+ Result0 = (=),
Result1 = compare_ps_time_both_overall(Deep, PSI1, PSI2),
- ( Result1 \= (=) ->
- Result = Result1
- ;
+ (
+ Result1 = (=),
Result = compare_ps_words_both_overall(Deep, PSI1, PSI2)
+ ;
+ ( Result1 = (<)
+ ; Result1 = (>)
+ ),
+ Result = Result1
)
+ ;
+ ( Result0 = (<)
+ ; Result0 = (>)
+ ),
+ Result = Result0
).
%-----------------------------------------------------------------------------%
@@ -967,15 +975,23 @@
compare_groups_fallback(MainFunc, Group1, Group2) = Result :-
Result0 = MainFunc(Group1, Group2),
- ( Result0 \= (=) ->
- Result = Result0
- ;
+ (
+ Result0 = (=),
Result1 = compare_line_groups_by_context(Group1, Group2),
- ( Result1 \= (=) ->
- Result = Result1
- ;
+ (
+ Result1 = (=),
Result = compare_line_groups_by_name(Group1, Group2)
+ ;
+ ( Result1 = (<)
+ ; Result1 = (>)
+ ),
+ Result = Result1
)
+ ;
+ ( Result0 = (<)
+ ; Result0 = (>)
+ ),
+ Result = Result0
).
%-----------------------------------------------------------------------------%
@@ -986,10 +1002,13 @@
compare_line_groups_by_context(Group1, Group2) = Result :-
compare(ResultFilenames,
Group1 ^ group_filename, Group2 ^ group_filename),
- ( ResultFilenames = (=) ->
- compare(Result,
- Group1 ^ group_linenumber, Group2 ^ group_linenumber)
+ (
+ ResultFilenames = (=),
+ compare(Result, Group1 ^ group_linenumber, Group2 ^ group_linenumber)
;
+ ( ResultFilenames = (<)
+ ; ResultFilenames = (>)
+ ),
Result = ResultFilenames
).
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.552
diff -u -r1.552 user_guide.texi
--- doc/user_guide.texi 8 Nov 2007 05:00:19 -0000 1.552
+++ doc/user_guide.texi 22 Nov 2007 00:29:38 -0000
@@ -6276,6 +6276,12 @@
Do not warn about calls to predicates or functions that have been
marked as obsolete.
+ at sp 1
+ at item --inform-ite-instead-of-switch
+ at findex ---ite-instead-of-switch
+Generate informational messages for if-then-elses that could be
+replaced by switches.
+
@end table
@node Verbosity options
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
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/fixed
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_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
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/log4m
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/mopenssl
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/net
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/posix/samples
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/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
Index: library/array.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/array.m,v
retrieving revision 1.159
diff -u -r1.159 array.m
--- library/array.m 18 Sep 2007 01:06:40 -0000 1.159
+++ library/array.m 21 Nov 2007 02:45:10 -0000
@@ -480,9 +480,13 @@
array.size(Array1, Size1),
array.size(Array2, Size2),
compare(SizeResult, Size1, Size2),
- ( SizeResult = (=) ->
+ (
+ SizeResult = (=),
array.compare_elements(0, Size1, Array1, Array2, Result)
;
+ ( SizeResult = (<)
+ ; SizeResult = (>)
+ ),
Result = SizeResult
).
@@ -496,10 +500,14 @@
array.lookup(Array1, N, Elem1),
array.lookup(Array2, N, Elem2),
compare(ElemResult, Elem1, Elem2),
- ( ElemResult = (=) ->
+ (
+ ElemResult = (=),
N1 = N + 1,
array.compare_elements(N1, Size, Array1, Array2, Result)
;
+ ( ElemResult = (<)
+ ; ElemResult = (>)
+ ),
Result = ElemResult
)
).
Index: library/bintree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/bintree.m,v
retrieving revision 1.51
diff -u -r1.51 bintree.m
--- library/bintree.m 19 Apr 2006 05:17:50 -0000 1.51
+++ library/bintree.m 21 Nov 2007 03:57:51 -0000
@@ -150,12 +150,15 @@
bintree.insert(empty, Key, Value, tree(Key, Value, empty, empty)).
bintree.insert(tree(Key0, Value0, Left, Right), Key, Value, Tree) :-
compare(Result, Key0, Key),
- ( Result = (=) ->
+ (
+ Result = (=),
fail
- ; Result = (<) ->
+ ;
+ Result = (<),
bintree.insert(Right, Key, Value, NewRight),
Tree = tree(Key0, Value0, Left, NewRight)
;
+ Result = (>),
bintree.insert(Left, Key, Value, NewLeft),
Tree = tree(Key0, Value0, NewLeft, Right)
).
@@ -166,12 +169,15 @@
fail.
bintree.update(tree(Key0, Value0, Left, Right), Key, Value, Tree) :-
compare(Result, Key0, Key),
- ( Result = (=) ->
+ (
+ Result = (=),
Tree = tree(Key0, Value, Left, Right)
- ; Result = (<) ->
+ ;
+ Result = (<),
bintree.update(Right, Key, Value, NewRight),
Tree = tree(Key0, Value0, Left, NewRight)
;
+ Result = (>),
bintree.update(Left, Key, Value, NewLeft),
Tree = tree(Key0, Value0, NewLeft, Right)
).
@@ -181,12 +187,15 @@
bintree.set(empty, Key, Value, tree(Key, Value, empty, empty)).
bintree.set(tree(Key0, Value0, Left, Right), Key, Value, Tree) :-
compare(Result, Key0, Key),
- ( Result = (=) ->
+ (
+ Result = (=),
Tree = tree(Key0, Value, Left, Right)
- ; Result = (<) ->
+ ;
+ Result = (<),
bintree.set(Right, Key, Value, NewRight),
Tree = tree(Key0, Value0, Left, NewRight)
;
+ Result = (>),
bintree.set(Left, Key, Value, NewLeft),
Tree = tree(Key0, Value0, NewLeft, Right)
).
@@ -195,11 +204,14 @@
bintree.search(tree(K0, V0, Left, Right), K, V) :-
compare(Result, K0, K),
- ( Result = (=) ->
+ (
+ Result = (=),
V = V0
- ; Result = (<) ->
+ ;
+ Result = (<),
bintree.search(Right, K, V)
;
+ Result = (>),
bintree.search(Left, K, V)
).
@@ -216,10 +228,12 @@
bintree.lower_bound_search(tree(K0, V0, Left, Right), SearchK, K, V) :-
compare(Result, K0, SearchK),
- ( Result = (=) ->
+ (
+ Result = (=),
K = K0,
V = V0
- ; Result = (<) ->
+ ;
+ Result = (<),
( bintree.lower_bound_search(Right, SearchK, Kp, Vp) ->
K = Kp,
V = Vp
@@ -228,6 +242,7 @@
V = V0
)
;
+ Result = (>),
bintree.lower_bound_search(Left, SearchK, K, V)
).
@@ -244,12 +259,15 @@
bintree.upper_bound_search(tree(K0, V0, Left, Right), SearchK, K, V) :-
compare(Result, K0, SearchK),
- ( Result = (=) ->
+ (
+ Result = (=),
K = K0,
V = V0
- ; Result = (<) ->
+ ;
+ Result = (<),
bintree.upper_bound_search(Right, SearchK, K, V)
;
+ Result = (>),
( bintree.upper_bound_search(Left, SearchK, Kp, Vp) ->
K = Kp,
V = Vp
@@ -273,12 +291,15 @@
bintree.delete(empty, _K, empty).
bintree.delete(tree(K0, V0, Left, Right), K, Tree) :-
compare(Result, K0, K),
- ( Result = (=) ->
+ (
+ Result = (=),
bintree.fixup(Left, Right, Tree)
- ; Result = (<) ->
+ ;
+ Result = (<),
bintree.delete(Right, K, Tree1),
Tree = tree(K0, V0, Left, Tree1)
;
+ Result = (>),
bintree.delete(Left, K, Tree1),
Tree = tree(K0, V0, Tree1, Right)
).
@@ -287,13 +308,16 @@
bintree.remove(tree(K0, V0, Left, Right), K, V, Tree) :-
compare(Result, K0, K),
- ( Result = (=) ->
+ (
+ Result = (=),
V = V0,
bintree.fixup(Left, Right, Tree)
- ; Result = (<) ->
+ ;
+ Result = (<),
bintree.remove(Right, K, V, Tree1),
Tree = tree(K0, V0, Left, Tree1)
;
+ Result = (>),
bintree.remove(Left, K, V, Tree1),
Tree = tree(K0, V0, Tree1, Right)
).
@@ -304,21 +328,27 @@
bintree(K, V)::out) is det.
bintree.fixup(Left, Right, Tree) :-
- ( Left = empty ->
+ (
+ Left = empty,
Tree = Right
- ; Right = empty ->
- Tree = Left
;
- bintree.right_depth(Left, LD),
- bintree.left_depth(Right, RD),
- ( LD > RD ->
- bintree.knock_left(Left, K, V, Left1),
- Right1 = Right
+ Left = tree(_, _, _, _),
+ (
+ Right = empty,
+ Tree = Left
;
- bintree.knock_right(Right, K, V, Right1),
- Left1 = Left
- ),
- Tree = tree(K, V, Left1, Right1)
+ Right = tree(_, _, _, _),
+ bintree.right_depth(Left, LD),
+ bintree.left_depth(Right, RD),
+ ( LD > RD ->
+ bintree.knock_left(Left, K, V, NewLeft),
+ NewRight = Right
+ ;
+ bintree.knock_right(Right, K, V, NewRight),
+ NewLeft = Left
+ ),
+ Tree = tree(K, V, NewLeft, NewRight)
+ )
).
:- pred bintree.right_depth(bintree(_K, _V)::in, int::out) is det.
@@ -341,11 +371,13 @@
bintree.knock_left(empty, _, _, _) :-
error("bintree.knock_left: empty tree").
bintree.knock_left(tree(K0, V0, Left, Right), K, V, Tree) :-
- ( Right = empty ->
+ (
+ Right = empty,
K = K0,
V = V0,
Tree = Left
;
+ Right = tree(_, _, _, _),
bintree.knock_left(Right, K, V, Right1),
Tree = tree(K0, V0, Left, Right1)
).
@@ -356,11 +388,13 @@
bintree.knock_right(empty, _, _, _) :-
error("bintree.knock_right: empty tree").
bintree.knock_right(tree(K0, V0, Left, Right), K, V, Tree) :-
- ( Left = empty ->
+ (
+ Left = empty,
K = K0,
V = V0,
Tree = Right
;
+ Left = tree(_, _, _, _),
bintree.knock_right(Left, K, V, Left1),
Tree = tree(K0, V0, Left1, Right)
).
@@ -495,24 +529,31 @@
bintree.branching_factor(empty, 0, 0).
bintree.branching_factor(tree(_K, _V, L, R), Ones, Twos) :-
- ( L = empty ->
- ( R = empty ->
+ (
+ L = empty,
+ (
+ R = empty,
Ones = 0,
Twos = 0
;
- bintree.branching_factor(R, Ones0, Twos),
- Ones = Ones0 + 1
+ R = tree(_, _, _, _),
+ bintree.branching_factor(R, OnesR, TwosR),
+ Ones = OnesR + 1,
+ Twos = TwosR
)
;
- ( R = empty ->
- bintree.branching_factor(L, Ones0, Twos),
- Ones = Ones0 + 1
+ L = tree(_, _, _, _),
+ (
+ R = empty,
+ bintree.branching_factor(L, OnesL, TwosL),
+ Ones = OnesL + 1,
+ Twos = TwosL
;
- bintree.branching_factor(L, Ones1, Twos1),
- bintree.branching_factor(R, Ones2, Twos2),
- Ones = Ones1 + Ones2,
- Twos0 = Twos1 + Twos2,
- Twos = Twos0 + 1
+ R = tree(_, _, _, _),
+ bintree.branching_factor(L, OnesL, TwosL),
+ bintree.branching_factor(R, OnesR, TwosR),
+ Ones = OnesL + OnesR,
+ Twos = TwosL + TwosR + 1
)
).
Index: library/bitmap.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/bitmap.m,v
retrieving revision 1.26
diff -u -r1.26 bitmap.m
--- library/bitmap.m 22 Aug 2007 11:48:52 -0000 1.26
+++ library/bitmap.m 21 Nov 2007 02:26:58 -0000
@@ -1637,9 +1637,13 @@
bytes_compare(Result, Index, MaxIndex, BM1, BM2) :-
( if Index =< MaxIndex then
compare(Result0, BM1 ^ unsafe_byte(Index), BM2 ^ unsafe_byte(Index)),
- ( if Result0 = (=) then
+ (
+ Result0 = (=),
bytes_compare(Result, Index + 1, MaxIndex, BM1, BM2)
- else
+ ;
+ ( Result0 = (<)
+ ; Result0 = (>)
+ ),
Result = Result0
)
else
Index: library/cord.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/cord.m,v
retrieving revision 1.10
diff -u -r1.10 cord.m
--- library/cord.m 12 Nov 2007 03:52:47 -0000 1.10
+++ library/cord.m 21 Nov 2007 04:01:41 -0000
@@ -171,7 +171,14 @@
%-----------------------------------------------------------------------------%
-from_list(Xs) = ( if Xs = [] then nil else leaves(Xs) ).
+from_list(Xs) = C :-
+ (
+ Xs = [],
+ C = nil
+ ;
+ Xs = [_ | _],
+ C = leaves(Xs)
+ ).
%-----------------------------------------------------------------------------%
@@ -186,11 +193,31 @@
%-----------------------------------------------------------------------------%
-cons(X, C) = ( if C = nil then leaf(X) else branch(leaf(X), C) ).
+cons(X, C) = XC :-
+ (
+ C = nil,
+ XC = leaf(X)
+ ;
+ ( C = leaf(_)
+ ; C = leaves(_)
+ ; C = branch(_, _)
+ ),
+ XC = branch(leaf(X), C)
+ ).
%-----------------------------------------------------------------------------%
-snoc(C, X) = ( if C = nil then leaf(X) else branch(C, leaf(X)) ).
+snoc(C, X) = CX :-
+ (
+ C = nil,
+ CX = leaf(X)
+ ;
+ ( C = leaf(_)
+ ; C = leaves(_)
+ ; C = branch(_, _)
+ ),
+ CX = branch(C, leaf(X))
+ ).
%-----------------------------------------------------------------------------%
@@ -203,7 +230,13 @@
head_tail(leaf(X), X, nil).
head_tail(leaves([X | Xs]), X, C ) :-
- C = ( if Xs = [] then nil else leaves(Xs) ).
+ (
+ Xs = [],
+ C = nil
+ ;
+ Xs = [_ | _],
+ C = leaves(Xs)
+ ).
head_tail(branch(CA0, CB), X, C ) :-
head_tail(CA0, X, CA),
C = CA ++ CB.
Index: library/dir.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/dir.m,v
retrieving revision 1.44
diff -u -r1.44 dir.m
--- library/dir.m 1 Oct 2007 05:40:42 -0000 1.44
+++ library/dir.m 21 Nov 2007 02:29:17 -0000
@@ -1,15 +1,15 @@
%---------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1994-1995,1997,1999-2000,2002-2007 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: dir.m.
% Main authors: fjh, stayl.
% Stability: high.
-%
+%
% Filename and directory handling.
%
% Note that the predicates and functions in this module change directory
@@ -18,7 +18,7 @@
%
% Duplicate directory separators and trailing separators are also removed
% where that doesn't change the meaning of the path name.
-%
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -830,13 +830,13 @@
:- pragma foreign_proc("C",
dir.current_directory(Res::out, IO0::di, IO::uo),
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates],
-"
+"
/*
** Marked thread_safe because ML_make_io_res_1_error_string will acquire
** the global lock.
*/
- size_t size = 256;
+ size_t size = 256;
char *buf;
MR_String str;
@@ -1338,10 +1338,23 @@
io.file_type(yes, PathName, TargetTypeRes, !IO),
(
TargetTypeRes = ok(TargetType),
- ( TargetType = directory ->
+ (
+ TargetType = directory,
dir.foldl2_process_dir(yes, P, PathName, ParentIds,
Recursive, FollowLinks, Continue2, T1, Res1, !IO)
;
+
+ ( TargetType = regular_file
+ ; TargetType = symbolic_link
+ ; TargetType = named_pipe
+ ; TargetType = socket
+ ; TargetType = character_device
+ ; TargetType = block_device
+ ; TargetType = message_queue
+ ; TargetType = semaphore
+ ; TargetType = shared_memory
+ ; TargetType = unknown
+ ),
Continue2 = yes,
Res1 = ok(T1)
)
@@ -1599,7 +1612,8 @@
io.file_type(yes, DirName, FileTypeRes, !IO),
(
FileTypeRes = ok(FileType),
- ( FileType = directory ->
+ (
+ FileType = directory,
io.check_file_accessibility(DirName, [read, execute],
AccessResult, !IO),
(
@@ -1613,10 +1627,20 @@
Result = error(Msg)
)
;
+ ( FileType = regular_file
+ ; FileType = symbolic_link
+ ; FileType = named_pipe
+ ; FileType = socket
+ ; FileType = character_device
+ ; FileType = block_device
+ ; FileType = message_queue
+ ; FileType = semaphore
+ ; FileType = shared_memory
+ ; FileType = unknown
+ ),
IsReadable = 0,
Result = error(make_io_error(
"dir.foldl2: pathname is not a directory"))
-
)
;
FileTypeRes = error(Msg),
Index: library/erlang_rtti_implementation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/erlang_rtti_implementation.m,v
retrieving revision 1.27
diff -u -r1.27 erlang_rtti_implementation.m
--- library/erlang_rtti_implementation.m 21 Sep 2007 04:07:42 -0000 1.27
+++ library/erlang_rtti_implementation.m 21 Nov 2007 02:43:00 -0000
@@ -67,13 +67,12 @@
:- pred functor_number(T::in, functor_number_lex::out, int::out) is semidet.
:- pred functor_number_cc(T::in, functor_number_lex::out,
- int::out) is cc_nondet.
+ int::out) is cc_nondet.
:- pred deconstruct(T, noncanon_handling, string, int, list(univ)).
:- mode deconstruct(in, in(do_not_allow), out, out, out) is det.
:- mode deconstruct(in, in(canonicalize), out, out, out) is det.
-:- mode deconstruct(in, in(include_details_cc), out, out, out)
- is cc_multi.
+:- mode deconstruct(in, in(include_details_cc), out, out, out) is cc_multi.
:- mode deconstruct(in, in, out, out, out) is cc_multi.
:- pred deconstruct_du(T, noncanon_handling, functor_number_lex,
@@ -130,7 +129,6 @@
:- import_module term_io.
:- import_module type_desc.
- %
% A type_info can be represented in one of three ways
% For a type with arity 0
% TypeCtorInfo
@@ -141,21 +139,24 @@
%
% Note that we usually we pass thunks in place of type_ctor_infos
% themselves.
- %
+ %
:- pragma foreign_type("Erlang", type_info, "").
-:- type type_info ---> type_info.
+:- type type_info
+ ---> type_info.
% In the Erlang RTTI implementation, this is actually a thunk returning a
% type_ctor_info.
%
:- pragma foreign_type("Erlang", type_ctor_info, "").
-:- type type_ctor_info ---> type_ctor_info.
+:- type type_ctor_info
+ ---> type_ctor_info.
% The actual type_ctor_info, i.e. after evaluating the thunk. For the
% representation of a type_ctor_info see erl_rtti.type_ctor_data_to_elds.
%
:- pragma foreign_type("Erlang", type_ctor_info_evaled, "").
-:- type type_ctor_info_evaled ---> type_ctor_info_evaled.
+:- type type_ctor_info_evaled
+ ---> type_ctor_info_evaled.
% The type_ctor_rep needs to be kept up to date with the alternatives
% given by the function erl_rtti.erlang_type_ctor_rep/1
@@ -186,9 +187,8 @@
; etcr_base_typeclass_info
; etcr_foreign
- % These types shouldn't be needed they are
- % introduced for library predicates which
- % don't apply on this backend.
+ % These types shouldn't be needed; they are introduced for library
+ % predicates which don't apply on this backend.
; etcr_hp
; etcr_subgoal
; etcr_ticket
@@ -341,7 +341,7 @@
error("compare/3: type arity > 5 not supported")
)
).
-
+
:- pred compare_tuple(type_info::in, comparison_result::out, T::in, T::in)
is det.
@@ -381,35 +381,49 @@
TCB = TB ^ type_ctor_info_evaled,
compare(NameRes, TCA ^ type_ctor_type_name, TCB ^ type_ctor_type_name),
- ( NameRes = (=) ->
+ (
+ NameRes = (=),
compare(ModuleRes,
TCA ^ type_ctor_module_name, TCB ^ type_ctor_module_name),
- ( ModuleRes = (=) ->
- (
- type_ctor_is_variable_arity(TCA)
- ->
+ (
+ ModuleRes = (=),
+ ( type_ctor_is_variable_arity(TCA) ->
ArityA = TA ^ var_arity_type_info_arity,
ArityB = TB ^ var_arity_type_info_arity,
compare(ArityRes, ArityA, ArityB),
- ( ArityRes = (=) ->
+ (
+ ArityRes = (=),
compare_var_arity_typeinfos(1, ArityA, Res, TA, TB)
;
+ ( ArityRes = (<)
+ ; ArityRes = (>)
+ ),
Res = ArityRes
)
;
ArityA = TCA ^ type_ctor_arity,
ArityB = TCA ^ type_ctor_arity,
compare(ArityRes, ArityA, ArityB),
- ( ArityRes = (=) ->
+ (
+ ArityRes = (=),
compare_sub_typeinfos(1, ArityA, Res, TA, TB)
;
+ ( ArityRes = (<)
+ ; ArityRes = (>)
+ ),
Res = ArityRes
)
)
;
+ ( ModuleRes = (<)
+ ; ModuleRes = (>)
+ ),
Res = ModuleRes
)
;
+ ( NameRes = (<)
+ ; NameRes = (>)
+ ),
Res = NameRes
).
@@ -424,10 +438,14 @@
SubTypeInfoB = TypeInfoB ^ type_info_index(Loc),
compare_type_infos(SubResult, SubTypeInfoA, SubTypeInfoB),
- ( SubResult = (=) ->
+ (
+ SubResult = (=),
compare_sub_typeinfos(Loc + 1, Arity, Result,
TypeInfoA, TypeInfoB)
;
+ ( SubResult = (<)
+ ; SubResult = (>)
+ ),
Result = SubResult
)
).
@@ -443,18 +461,18 @@
SubTypeInfoB = TypeInfoB ^ var_arity_type_info_index(Loc),
compare_type_infos(SubResult, SubTypeInfoA, SubTypeInfoB),
- ( SubResult = (=) ->
+ (
+ SubResult = (=),
compare_var_arity_typeinfos(Loc + 1, Arity, Result,
TypeInfoA, TypeInfoB)
;
+ ( SubResult = (<)
+ ; SubResult = (>)
+ ),
Result = SubResult
)
).
-
-
-
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -575,7 +593,7 @@
(fun(TypeCtorInfo, Arity, ArgTypeInfos) ->
case Arity =:= length(ArgTypeInfos) of
true ->
- TypeInfo =
+ TypeInfo =
list_to_tuple([TypeCtorInfo, Arity | ArgTypeDescs]),
{true, TypeInfo};
false ->
@@ -828,8 +846,8 @@
Arity = 0,
Arguments = []
;
- % There is no way to create values of type `void', so this
- % should never happen.
+ % There is no way to create values of type `void', so this
+ % should never happen.
TypeCtorRep = etcr_void,
error(this_file ++ " deconstruct: cannot deconstruct void types")
;
@@ -878,7 +896,7 @@
Arity = 0,
Arguments = []
;
- % XXX this needs to be fixed
+ % XXX this needs to be fixed
NonCanon = include_details_cc,
Functor = Name,
FunctorNumber = 0,
@@ -893,9 +911,8 @@
Arguments = []
;
- % These types shouldn't be needed they are
- % introduced for library predicates which
- % don't apply on this backend.
+ % These types shouldn't be needed; they are introduced for library
+ % predicates which don't apply on this backend.
( TypeCtorRep = etcr_hp
; TypeCtorRep = etcr_subgoal
; TypeCtorRep = etcr_ticket
@@ -904,10 +921,9 @@
string(TypeCtorRep))
).
- %
% matching_du_functor(FunctorReps, Term, FunctorRep)
%
- % finds the erlang_du_functor in the list Functors which describes
+ % Finds the erlang_du_functor in the list Functors which describes
% the given Term.
%
:- pred matching_du_functor(list(erlang_du_functor)::in, T::in,
@@ -922,7 +938,6 @@
matching_du_functor(Fs, T, Functor)
).
- %
% A functor matches a term, if the first argument of the term
% is the same erlang atom as the recorded in the edu_rep field,
% and the size of the term matches the calculated size of term.
@@ -940,8 +955,10 @@
Functor ^ edu_orig_arity + 1 + extra_args(Functor) = Size.
:- pred check_functor(T::in, erlang_atom::in, int::out) is semidet.
-:- pragma foreign_proc("Erlang", check_functor(Term::in, Atom::in, Size::out),
- [will_not_call_mercury, promise_pure, thread_safe], "
+:- pragma foreign_proc("Erlang",
+ check_functor(Term::in, Atom::in, Size::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
case Atom of
% This case must come before the next to handle existential types using
% the '[|]' constructor. In that case the Erlang term will be a tuple
@@ -968,13 +985,13 @@
check_functor(_, _, 0) :-
semidet_unimplemented("check_functor/3").
-
:- some [H, T] pred is_non_empty_list(type_info::in, type_info::in,
L::in, H::out, T::out) is semidet.
:- pragma foreign_proc("Erlang",
- is_non_empty_list(ListTI::in, ElemTI::in, L::in, H::out, T::out),
- [promise_pure, will_not_call_mercury, thread_safe], "
+ is_non_empty_list(ListTI::in, ElemTI::in, L::in, H::out, T::out),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
% TypeInfo_for_L
TypeInfo_for_H = ElemTI,
TypeInfo_for_T = ListTI,
@@ -992,9 +1009,9 @@
is_non_empty_list(_, _, _, "dummy value", "dummy value") :-
semidet_unimplemented("is_non_empty_list/5").
-
+
%
- % Calculate the number of type_info and type_class_infos which
+ % Calculate the number of type_info and type_class_infos which
% have been introduced due to existentially quantified type
% variables on the given functor.
%
@@ -1004,8 +1021,8 @@
MaybeExist = Functor ^ edu_exist_info,
(
MaybeExist = yes(ExistInfo),
- % XXX we should record the number of typeclass_constraints
- % in the exist_info
+ % XXX We should record the number of typeclass_constraints
+ % in the exist_info.
ExtraArgs = ExistInfo ^ exist_num_plain_typeinfos +
list.length(ExistInfo ^ exist_typeclass_constraints)
;
@@ -1013,11 +1030,10 @@
ExtraArgs = 0
).
- %
% get_du_functor_arg(TypeInfo, Functor, Term, N)
%
- % returns a univ which represent the N'th argument of the term, Term,
- % which is described the erlang_du_functor, Functor, and the type_info,
+ % Returns a univ which represents the N'th argument of the term, Term,
+ % which is described by the erlang_du_functor Functor, and the type_info
% TypeInfo.
%
:- func get_du_functor_arg(type_info, erlang_du_functor, T, int) = univ.
@@ -1032,11 +1048,10 @@
SubTerm = get_subterm(ArgTypeInfo, Term, Loc, extra_args(Functor) + 1),
Univ = univ(SubTerm).
- %
% get_tuple_arg(TypeInfo, Tuple, N)
%
- % Get the N'th argument as a univ from the tuple
- % described by the type_info.
+ % Get the N'th argument as a univ from the tuple described by the
+ % type_info.
%
:- func get_tuple_arg(type_info, U, int) = univ.
@@ -1071,7 +1086,7 @@
%-----------------------------------------------------------------------------%
pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtorDesc, Args) :-
- % XXX Still need to handle equivalence types.
+ % XXX Still need to handle equivalence types.
EvalPTI = pseudo_type_desc_to_pseudo_type_info(PseudoTypeDesc),
EvalPTI = pseudo_type_info(PTI),
@@ -1084,17 +1099,14 @@
Arity = TI ^ var_arity_type_info_arity,
TypeCtorDesc = make_pred_type_ctor_desc(Arity),
ArgInfos = get_var_arity_arg_type_infos(TI)
-
; TypeCtorRep = etcr_func ->
Arity = TI ^ var_arity_type_info_arity,
TypeCtorDesc = make_func_type_ctor_desc(Arity),
ArgInfos = get_var_arity_arg_type_infos(TI)
-
; TypeCtorRep = etcr_tuple ->
Arity = TI ^ var_arity_type_info_arity,
TypeCtorDesc = make_tuple_type_ctor_desc(Arity),
ArgInfos = get_var_arity_arg_type_infos(TI)
-
;
% Handle fixed arity types.
TypeCtorDesc = make_fixed_arity_type_ctor_desc(TypeCtorInfo),
@@ -1131,7 +1143,7 @@
type_ctor_info_from_pseudo_type_info(PTI) =
unsafe_cast(PTI) ^ type_ctor_info_evaled.
-
+
:- func pseudo_type_descs_from_type_infos(list(type_info)) =
list(pseudo_type_desc).
@@ -1220,8 +1232,7 @@
FunctorReps = TypeCtorInfo ^ type_ctor_functors,
( matching_du_functor_number(FunctorReps, NumFunctor, FunctorRep) ->
ArgInfos = FunctorRep ^ edu_arg_infos,
-
- list.map2(
+ MapArgInfosToTypesNames =
(pred(ArgInfo::in, ArgTypeInfo::out, ArgName::out) is det :-
MaybePTI = ArgInfo ^ du_arg_type,
Info = yes({TypeInfo, no : pti_info(int)}),
@@ -1235,7 +1246,8 @@
MaybeArgName = no,
ArgName = ""
)
- ), ArgInfos, ArgTypes, ArgNames),
+ ),
+ list.map2(MapArgInfosToTypesNames, ArgInfos, ArgTypes, ArgNames),
Name = string.from_char_list(FunctorRep ^ edu_name),
Arity = FunctorRep ^ edu_orig_arity,
@@ -1265,10 +1277,8 @@
ArgTypes = [],
ArgNames = [],
Result = yes({Name, Arity, ArgTypes, ArgNames})
-
; NumFunctor = 1 ->
ArgTypeInfo = TypeInfo ^ type_info_index(1),
-
Name = "[|]",
Arity = 2,
ArgTypes = [ArgTypeInfo, TypeInfo],
@@ -1397,7 +1407,7 @@
TypeCtorInfo = TypeInfo ^ type_ctor_info_evaled,
TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
- (
+ (
TypeCtorRep = etcr_du,
Result = get_functor_with_names(TypeInfo, Index),
Result = yes({FunctorName, _FunctorArity, ArgTypes, _ArgNames}),
@@ -1472,23 +1482,23 @@
:- func univ_type_info(univ) = type_info.
:- pragma foreign_proc(erlang,
- univ_type_info(Univ::in) = (TypeInfo::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+ univ_type_info(Univ::in) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
{univ_cons, TypeInfo, _} = Univ
").
univ_type_info(_) = _ :-
private_builtin.sorry("univ_type_info").
-
- %
% Construct a du type and store it in a univ.
%
:- func construct_univ(type_info, string, list(univ)) = univ.
:- pragma foreign_proc(erlang,
- construct_univ(TypeInfo::in, Functor::in, Args::in) = (Univ::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+ construct_univ(TypeInfo::in, Functor::in, Args::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
if
is_binary(Functor) ->
List = binary_to_list(Functor);
@@ -1502,14 +1512,14 @@
construct_univ(_, _, _) = _ :-
private_builtin.sorry("construct_univ").
- %
% Construct a tuple and store it in a univ.
%
:- func construct_tuple_univ(type_info, list(univ)) = univ.
:- pragma foreign_proc(erlang,
- construct_tuple_univ(TypeInfo::in, Args::in) = (Univ::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+ construct_tuple_univ(TypeInfo::in, Args::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
Univ = {univ_cons, TypeInfo,
list_to_tuple(lists:map(fun univ_to_value/1, Args))}
").
@@ -1517,28 +1527,28 @@
construct_tuple_univ(_, _) = _ :-
private_builtin.sorry("construct_tuple_univ").
- %
% Construct a empty list and store it in a univ.
%
:- func construct_empty_list_univ(type_info) = univ.
:- pragma foreign_proc(erlang,
- construct_empty_list_univ(TypeInfo::in) = (Univ::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+ construct_empty_list_univ(TypeInfo::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
Univ = {univ_cons, TypeInfo, []}
").
construct_empty_list_univ(_) = _ :-
private_builtin.sorry("construct_empty_list_univ").
- %
% Construct a cons cell and store it in a univ.
%
:- func construct_list_cons_univ(type_info, univ, univ) = univ.
:- pragma foreign_proc(erlang,
- construct_list_cons_univ(TypeInfo::in, H::in, T::in) = (Univ::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+ construct_list_cons_univ(TypeInfo::in, H::in, T::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
Univ = {univ_cons, TypeInfo, [univ_to_value(H) | univ_to_value(T)]}
").
@@ -1546,18 +1556,17 @@
private_builtin.sorry("construct_list_cons_univ").
:- pragma foreign_code(erlang, "
- %
- % Get the value out of the univ
+ % Get the value out of the univ.
% Note we assume that we've checked that the value is consistent
% with another type_info elsewhere,
- % for example in check_arg_types and check_tuple_arg_types
+ % for example in check_arg_types and check_tuple_arg_types.
%
univ_to_value(Univ) ->
{univ_cons, _UnivTypeInfo, Value} = Univ,
Value.
-
+
").
-
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1568,12 +1577,12 @@
:- func construct_tuple_3(type_info, int, list(type_desc), list(univ)) = univ.
:- pragma foreign_proc(erlang,
- construct_tuple_3(TI::in,
- Arity::in, ArgTypes::in, Args::in) = (Term::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+ construct_tuple_3(TI::in, Arity::in, ArgTypes::in, Args::in) = (Term::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ % Get the type_ctor_info from the empty tuple type_info
+ % and use that to create the correct var_arity type_info.
- % Get the type_ctor_info from the empty tuple type_info
- % and use that to create the correct var_arity type_info
TCI = element(?ML_ti_type_ctor_info, TI),
TupleTypeInfo = list_to_tuple([TCI, Arity | ArgTypes]),
@@ -1585,7 +1594,6 @@
construct_tuple_3(_, _, _, _) = _ :-
private_builtin.sorry("construct_tuple_3").
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1631,18 +1639,18 @@
type_ctor_info_evaled(TypeInfo::in) = (TypeCtorInfo::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- %io:format(""~nTypeInfo: ~p~n"", [TypeInfo]),
- %
- % If the type_info is for a type with arity 0,
- % then the type_info is already the type_ctor info.
- % We evaluate the thunk to get the actual type_ctor_info data.
- %
+ % io:format(""~nTypeInfo: ~p~n"", [TypeInfo]),
+
+ % If the type_info is for a type with arity 0,
+ % then the type_info is already the type_ctor info.
+ % We evaluate the thunk to get the actual type_ctor_info data.
+
if
is_function(TypeInfo, 0) ->
TypeCtorInfo = TypeInfo();
true ->
FirstElement = element(?ML_ti_type_ctor_info, TypeInfo),
- if
+ if
is_integer(FirstElement) ->
TypeCtorInfo = TypeInfo;
true ->
@@ -1668,27 +1676,24 @@
var_arity_type_info_arity(_) = 0 :-
det_unimplemented("var_arity_type_info_arity").
- %
% TI ^ type_info_index(I)
%
- % returns the I'th type_info from the given standard type_info TI.
- % NOTE indexes start at one.
- %
+ % Returns the I'th type_info from the given standard type_info TI.
+ % NOTE Indexes start at one.
+ %
:- func type_info_index(int, type_info) = type_info.
type_info_index(I, TI) = TI ^ unsafe_type_info_index(I + 1).
- %
% TI ^ var_arity_type_info_index(I)
%
- % returns the I'th type_info from the given variable arity type_info TI.
- % NOTE indexes start at one.
- %
+ % Returns the I'th type_info from the given variable arity type_info TI.
+ % NOTE Indexes start at one.
+ %
:- func var_arity_type_info_index(int, type_info) = type_info.
var_arity_type_info_index(I, TI) = TI ^ unsafe_type_info_index(I + 2).
- %
% Use type_info_index or var_arity_type_info_index, never this predicate
% directly.
%
@@ -1759,7 +1764,7 @@
type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- % The TypeInfo is never used so this is safe
+ % The TypeInfo is never used so this is safe.
TypeInfo_for_P = 0,
UnifyPred = element(?ML_tci_unify_pred, TypeCtorInfo)
").
@@ -2095,7 +2100,8 @@
:- type erlang_atom.
:- pragma foreign_type("Erlang", erlang_atom, "").
-:- type erlang_atom ---> erlang_atom.
+:- type erlang_atom
+ ---> erlang_atom.
:- type erlang_du_functor
---> erlang_du_functor(
@@ -2161,13 +2167,11 @@
---> pseudo(pseudo_type_info_thunk)
; plain(type_info_thunk).
-
%-----------------------------------------------------------------------------%
:- type ti_info(T) == maybe({type_info, pti_info(T)}).
:- type pti_info(T) == maybe({erlang_du_functor, T}).
- %
% Given a plain or pseudo type_info, return the concrete type_info
% which represents the type.
%
@@ -2225,30 +2229,28 @@
(
ExistLocn = plain_typeinfo(X),
- % plain_typeinfo index's start at 0, so we need to
- % add two to get to the first index.
+ % Plain_typeinfo indexes start at 0, so we need to add two
+ % to get to the first index.
ArgTypeInfo = unsafe_cast(get_subterm(TypeInfo, Term, X, 2))
;
ExistLocn = typeinfo_in_tci(A, B),
- % A starts at index 0 and measures from the start
- % of the list of plain type_infos
- %
- % B starts at index 1 and measures from the start
- % of the type_class_info
- %
- % Hence the addition of two extra arguments to find the
- % type_class_info and then the addition of one extra
- % arg to find the type_info in the type_class_info.
- %
- % Note it's safe to pass a bogus type_info to
- % get_subterm because we never use the returned
- % type_info.
- %
+ % A starts at index 0 and measures from the start
+ % of the list of plain type_infos.
+ %
+ % B starts at index 1 and measures from the start
+ % of the type_class_info.
+ %
+ % Hence the addition of two extra arguments to find the
+ % type_class_info and then the addition of one extra
+ % arg to find the type_info in the type_class_info.
+ %
+ % Note it's safe to pass a bogus type_info to get_subterm
+ % because we never use the returned type_info.
+
Bogus = TypeInfo,
TypeClassInfo = get_subterm(Bogus, Term, A, 2),
- ArgTypeInfo = unsafe_cast(
- get_subterm(Bogus, TypeClassInfo, B, 1))
+ ArgTypeInfo = unsafe_cast(get_subterm(Bogus, TypeClassInfo, B, 1))
)
;
MaybeExist = no,
@@ -2268,7 +2270,8 @@
( type_ctor_is_variable_arity(TypeCtorInfo) ->
Arity = TI ^ var_arity_type_info_arity,
ArgTypeInfos = list.map(var_arity_arg_type_info(I, TI), 1 .. Arity),
- TypeInfo = create_var_arity_type_info(TypeCtorInfo, Arity, ArgTypeInfos)
+ TypeInfo = create_var_arity_type_info(TypeCtorInfo, Arity,
+ ArgTypeInfos)
; TypeCtorInfo ^ type_ctor_arity = 0 ->
TypeInfo = TI
;
@@ -2277,7 +2280,6 @@
TypeInfo = create_type_info(TypeCtorInfo, ArgTypeInfos)
).
-
:- func var_arity_arg_type_info(ti_info(T), TypeInfo, int) = type_info.
var_arity_arg_type_info(Info, TypeInfo, Index) = ArgTypeInfo :-
@@ -2295,8 +2297,9 @@
:- func create_type_info(type_ctor_info_evaled, list(type_info)) = type_info.
:- pragma foreign_proc("Erlang",
- create_type_info(TypeCtorInfo::in, Args::in) = (TypeInfo::out),
- [promise_pure, will_not_call_mercury, thread_safe], "
+ create_type_info(TypeCtorInfo::in, Args::in) = (TypeInfo::out),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
% TypeCtorInfo was evaluated by eval_type_info, so we wrap it back up in a
% thunk. It may or may not be costly to do this, when we could have
% already used the one we extracted out of the type_info.
@@ -2312,15 +2315,15 @@
create_type_info(_, _) = type_info :-
det_unimplemented("create_type_info/2").
-
:- func create_var_arity_type_info(type_ctor_info_evaled,
int, list(type_info)) = type_info.
:- pragma foreign_proc("Erlang",
- create_var_arity_type_info(TypeCtorInfo::in,
- Arity::in, Args::in) = (TypeInfo::out),
- [promise_pure, will_not_call_mercury, thread_safe], "
+ create_var_arity_type_info(TypeCtorInfo::in, Arity::in, Args::in)
+ = (TypeInfo::out),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
% TypeCtorInfo was evaluated by eval_type_info, so we wrap it back up in a
% thunk. It may or may not be costly to do this, when we could have
% already used the one we extracted out of the type_info.
@@ -2330,44 +2333,41 @@
create_var_arity_type_info(_, _, _) = type_info :-
det_unimplemented("create_var_arity_type_info/3").
-
+
%-----------------------------------------------------------------------------%
- %
- % A pseudo_type_info can be represented in one of three ways
+ % A pseudo_type_info can be represented in one of three ways.
% For a type with arity 0
% TypeCtorInfo
% a type with arity > 0
% { TypeCtorInfo, PseudoTypeInfo0, ..., PseudoTypeInfoN }
% a type with variable arity of size N
% { TypeCtorInfo, N, PseudoTypeInfo0, ..., PseudoTypeInfoN }
- %
+ %
:- type pseudo_type_info.
:- pragma foreign_type("Erlang", pseudo_type_info, "").
-:- type pseudo_type_info ---> pseudo_type_info.
+:- type pseudo_type_info
+ ---> pseudo_type_info.
- %
% TI ^ pseudo_type_info_index(I)
%
- % returns the I'th maybe_pseudo_type_info from the given type_info
- % or pseudo_type_info
- % NOTE indexes start at one.
- %
+ % Returns the I'th maybe_pseudo_type_info from the given type_info
+ % or pseudo_type_info.
+ % NOTE Indexes start at one.
+ %
:- func pseudo_type_info_index(int, T) = maybe_pseudo_type_info.
pseudo_type_info_index(I, TI) = TI ^ unsafe_pseudo_type_info_index(I + 1).
- %
% TI ^ var_arity_pseudo_type_info_index(I)
%
- % NOTE indexes start at one.
- %
+ % NOTE Indexes start at one.
+ %
:- func var_arity_pseudo_type_info_index(int, T) = maybe_pseudo_type_info.
-var_arity_pseudo_type_info_index(I, TI) =
+var_arity_pseudo_type_info_index(I, TI) =
TI ^ unsafe_pseudo_type_info_index(I + 2).
- %
% Use pseudo_type_info_index or var_arity_pseudo_type_info_index, never
% this predicate directly.
%
@@ -2378,7 +2378,7 @@
[will_not_call_mercury, promise_pure, thread_safe],
"
Maybe = element(Index, TypeInfo),
- %io:format(""unsafe_pseudo_type_info_index(~p, ~p) = ~p~n"",
+ % io:format(""unsafe_pseudo_type_info_index(~p, ~p) = ~p~n"",
% [Index, TypeInfo, Maybe]),
void
").
@@ -2390,20 +2390,21 @@
:- type pseudo_type_info_thunk.
:- pragma foreign_type("Erlang", pseudo_type_info_thunk, "").
-:- type pseudo_type_info_thunk ---> pseudo_type_info_thunk.
+:- type pseudo_type_info_thunk
+ ---> pseudo_type_info_thunk.
:- type evaluated_pseudo_type_info_thunk
---> universal_type_info(int)
; existential_type_info(int)
- ; pseudo_type_info(pseudo_type_info)
- .
+ ; pseudo_type_info(pseudo_type_info).
:- func eval_pseudo_type_info_thunk(pseudo_type_info_thunk) =
evaluated_pseudo_type_info_thunk.
:- pragma foreign_proc("Erlang",
- eval_pseudo_type_info_thunk(Thunk::in) = (TypeInfo::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+ eval_pseudo_type_info_thunk(Thunk::in) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
if
is_function(Thunk, 0) ->
MaybeTypeInfo = Thunk();
@@ -2411,7 +2412,7 @@
MaybeTypeInfo = Thunk
end,
TypeInfo =
- if
+ if
is_integer(MaybeTypeInfo), MaybeTypeInfo < 512 ->
{ universal_type_info, MaybeTypeInfo };
is_integer(MaybeTypeInfo) ->
@@ -2434,8 +2435,10 @@
:- type type_info_thunk ---> type_info_thunk.
:- func eval_type_info_thunk_2(type_info_thunk) = type_info.
-:- pragma foreign_proc("Erlang", eval_type_info_thunk_2(Thunk::in) = (TypeInfo::out),
- [will_not_call_mercury, thread_safe, promise_pure], "
+:- pragma foreign_proc("Erlang",
+ eval_type_info_thunk_2(Thunk::in) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
TypeInfo = Thunk(),
% io:format(""eval_type_info_thunk_2(~p) = ~p~n"", [Thunk, TypeInfo]),
void
@@ -2450,8 +2453,10 @@
:- pred is_erlang_backend is semidet.
:- implementation.
-:- pragma foreign_proc("Erlang", is_erlang_backend,
- [will_not_call_mercury, thread_safe, promise_pure], "
+:- pragma foreign_proc("Erlang",
+ is_erlang_backend,
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
SUCCESS_INDICATOR = true
").
Index: library/getopt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/getopt.m,v
retrieving revision 1.42
diff -u -r1.42 getopt.m
--- library/getopt.m 21 Mar 2007 22:30:24 -0000 1.42
+++ library/getopt.m 21 Nov 2007 04:09:50 -0000
@@ -1,15 +1,15 @@
%-----------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1994-1999,2001-2006 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: getopt.m.
% Authors: fjh, zs.
% Stability: medium.
-%
+%
% This module exports the predicate getopt.process_options/4,
% which can be used to parse command-line options.
%
@@ -77,7 +77,7 @@
% with another `-', e.g. `-x-' will negate the `-x' option.
% Long options can be negated by preceding them with `--no-',
% e.g. `--no-foo' will negate the `--foo' option.
-%
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -398,21 +398,22 @@
; string.append("--no-", LongOption, Option) ->
LongOptionPred = OptionOps ^ long_option,
( LongOptionPred(LongOption, Flag) ->
- string.append("--", LongOption, OptName),
+ OptName = "--" ++ LongOption,
process_negated_option(OptName, Flag, OptionOps,
OptionTable0, Result1, !OptionsSet),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt.process_arguments(Args0, Args, OptionOps,
[Option | OptionArgs0], OptionArgs, OptionTable1, Result,
!OptionsSet)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs0,
Args = Args0
)
;
- string.append_list(["unrecognized option `", Option, "'"],
- ErrorMsg),
+ ErrorMsg = "unrecognized option `" ++ Option ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -439,15 +440,13 @@
[Option | OptionArgs0], OptionArgs,
OptionTable0, Result, !OptionsSet)
;
- string.append_list(["unknown type for option `", Option, "'"],
- ErrorMsg),
+ ErrorMsg = "unknown type for option `" ++ Option ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
)
;
- string.append("unrecognized option `", OptionName, Tmp),
- string.append(Tmp, "'", ErrorMsg),
+ ErrorMsg = "unrecognized option `" ++ OptionName ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -461,18 +460,19 @@
string.from_char_list(['-', SingleShortOpt], OptName),
process_negated_option(OptName, Flag, OptionOps,
OptionTable0, Result1, !OptionsSet),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt.process_arguments(Args0, Args, OptionOps,
[Option | OptionArgs0], OptionArgs,
OptionTable1, Result, !OptionsSet)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs0,
Args = Args0
)
;
- string.append_list(["unrecognized option `-", ShortOptions,
- "'"], ErrorMsg),
+ ErrorMsg = "unrecognized option `-" ++ ShortOptions ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -486,10 +486,12 @@
getopt.handle_short_options(ShortOptionsList, OptionOps,
Args0, Args1, [Option | OptionArgs0], OptionArgs1,
OptionTable0, Result1, !OptionsSet),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt.process_arguments(Args1, Args, OptionOps,
OptionArgs1, OptionArgs, OptionTable1, Result, !OptionsSet)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs1,
Args = Args0
@@ -537,31 +539,35 @@
OptionArgs1 = OptionArgs0,
MissingArg = no
),
- ( MissingArg = yes ->
- Args = Args0,
- OptionArgs = OptionArgs1,
- string.append_list(["option `", Option, "' needs an argument"],
- ErrorMsg),
- Result = error(ErrorMsg)
- ;
- getopt.need_arg(OptionData, no),
- MaybeOptionArg = yes(_)
- ->
+ (
+ MissingArg = yes,
Args = Args0,
OptionArgs = OptionArgs1,
- string.append_list(["option `", Option,
- "' does not allow an argument"], ErrorMsg),
+ ErrorMsg = "option `" ++ Option ++ "' needs an argument",
Result = error(ErrorMsg)
;
- getopt.process_option(OptionData, Option, Flag, MaybeOptionArg,
- OptionOps, OptionTable0, Result1, !OptionsSet),
- ( Result1 = ok(OptionTable1) ->
- getopt.process_arguments(Args1, Args, OptionOps,
- OptionArgs1, OptionArgs, OptionTable1, Result, !OptionsSet)
- ;
- Result = Result1,
+ MissingArg = no,
+ (
+ getopt.need_arg(OptionData, no),
+ MaybeOptionArg = yes(_)
+ ->
+ Args = Args0,
OptionArgs = OptionArgs1,
- Args = Args1
+ ErrorMsg = "option `" ++ Option ++ "' does not allow an argument",
+ Result = error(ErrorMsg)
+ ;
+ getopt.process_option(OptionData, Option, Flag, MaybeOptionArg,
+ OptionOps, OptionTable0, Result1, !OptionsSet),
+ (
+ Result1 = ok(OptionTable1),
+ getopt.process_arguments(Args1, Args, OptionOps,
+ OptionArgs1, OptionArgs, OptionTable1, Result, !OptionsSet)
+ ;
+ Result1 = error(_),
+ Result = Result1,
+ OptionArgs = OptionArgs1,
+ Args = Args1
+ )
)
).
@@ -593,26 +599,26 @@
string.from_char_list(['-', Opt], Option),
getopt.process_option(OptionData, Option, Flag, MaybeOptionArg,
OptionOps, OptionTable0, Result1, !OptionsSet),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt.handle_short_options(Opts1, OptionOps, Args1, Args,
OptionArgs1, OptionArgs, OptionTable1, Result, !OptionsSet)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs1,
Args = Args1
)
;
string.char_to_string(Opt, OptString),
- string.append_list(["unknown type for option `-",
- OptString, "'"], ErrorMsg),
+ ErrorMsg = "unknown type for option `-" ++ OptString ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
)
;
string.char_to_string(Opt, OptString),
- string.append_list(["unrecognized option `-", OptString, "'"],
- ErrorMsg),
+ ErrorMsg = "unrecognized option `-" ++ OptString ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -914,9 +920,8 @@
maybe_option_table(OptionType)::out) is det.
getopt.numeric_argument(Option, Arg, Result) :-
- string.append_list(["option `", Option,
- "' requires a numeric argument; `", Arg, "' is not numeric"],
- ErrorMsg),
+ ErrorMsg = "option `" ++ Option ++ "'" ++
+ "requires a numeric argument; `" ++ Arg ++ "' is not numeric",
Result = error(ErrorMsg).
%-----------------------------------------------------------------------------%
Index: library/getopt_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/getopt_io.m,v
retrieving revision 1.11
diff -u -r1.11 getopt_io.m
--- library/getopt_io.m 21 Mar 2007 22:30:24 -0000 1.11
+++ library/getopt_io.m 21 Nov 2007 04:36:42 -0000
@@ -1,15 +1,15 @@
%-----------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2005-2006 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: getopt_io.m
% Authors: fjh, zs
% Stability: medium
-%
+%
% This module exports the predicate getopt_io.process_options/6,
% which can be used to parse command-line options.
%
@@ -80,7 +80,7 @@
% Its handling always consists of reading the named file, converting its
% contents into a sequence of words separated by white space, and interpreting
% those words as options in the usual manner.
-%
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -296,7 +296,6 @@
:- import_module string.
:- import_module svset.
-
%-----------------------------------------------------------------------------%
% Please keep the differences between this module and getopt.m to the
@@ -408,18 +407,19 @@
string.append("--", LongOption, OptName),
process_negated_option(OptName, Flag, OptionOps,
OptionTable0, Result1, !OptionsSet),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt_io.process_arguments(Args0, Args, OptionOps,
[Option | OptionArgs0], OptionArgs, OptionTable1, Result,
!OptionsSet, !IO)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs0,
Args = Args0
)
;
- string.append_list(["unrecognized option `", Option, "'"],
- ErrorMsg),
+ ErrorMsg = "unrecognized option `-" ++ Option ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -446,15 +446,13 @@
[Option | OptionArgs0], OptionArgs,
OptionTable0, Result, !OptionsSet, !IO)
;
- string.append_list(["unknown type for option `", Option, "'"],
- ErrorMsg),
+ ErrorMsg = "unknown type for option `" ++ Option ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
)
;
- string.append("unrecognized option `", OptionName, Tmp),
- string.append(Tmp, "'", ErrorMsg),
+ ErrorMsg = "unrecognized option `" ++ OptionName ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -468,18 +466,19 @@
string.from_char_list(['-', SingleShortOpt], OptName),
process_negated_option(OptName, Flag, OptionOps,
OptionTable0, Result1, !OptionsSet),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt_io.process_arguments(Args0, Args, OptionOps,
[Option | OptionArgs0], OptionArgs,
OptionTable1, Result, !OptionsSet, !IO)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs0,
Args = Args0
)
;
- string.append_list(["unrecognized option `-", ShortOptions,
- "'"], ErrorMsg),
+ ErrorMsg = "unrecognized option `-" ++ ShortOptions ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -493,11 +492,13 @@
getopt_io.handle_short_options(ShortOptionsList, OptionOps,
Args0, Args1, [Option | OptionArgs0], OptionArgs1,
OptionTable0, Result1, !OptionsSet, !IO),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt_io.process_arguments(Args1, Args, OptionOps,
OptionArgs1, OptionArgs, OptionTable1, Result, !OptionsSet,
!IO)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs1,
Args = Args0
@@ -512,7 +513,8 @@
Args = [Option | Args1]
).
-:- pred getopt_io.handle_long_option(string::in, OptionType::in, option_data::in,
+:- pred getopt_io.handle_long_option(string::in,
+ OptionType::in, option_data::in,
maybe(string)::in, list(string)::in, list(string)::out,
option_ops_internal(OptionType)::in(option_ops_internal), list(string)::in,
list(string)::out, option_table(OptionType)::in,
@@ -526,7 +528,7 @@
getopt_io.need_arg(OptionData, yes),
MaybeOptionArg0 = no
->
- (
+ (
Args0 = [Arg | ArgsTail],
MaybeOptionArg = yes(Arg),
Args1 = ArgsTail,
@@ -548,8 +550,7 @@
( MissingArg = yes ->
Args = Args0,
OptionArgs = OptionArgs1,
- string.append_list(["option `", Option, "' needs an argument"],
- ErrorMsg),
+ ErrorMsg = "option `" ++ Option ++ "' needs an argument",
Result = error(ErrorMsg)
;
getopt_io.need_arg(OptionData, no),
@@ -557,17 +558,18 @@
->
Args = Args0,
OptionArgs = OptionArgs1,
- string.append_list(["option `", Option,
- "' does not allow an argument"], ErrorMsg),
+ ErrorMsg = "option `" ++ Option ++ "' does not allow an argument",
Result = error(ErrorMsg)
;
getopt_io.process_option(OptionData, Option, Flag, MaybeOptionArg,
OptionOps, OptionTable0, Result1, !OptionsSet, !IO),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt_io.process_arguments(Args1, Args, OptionOps,
OptionArgs1, OptionArgs, OptionTable1, Result, !OptionsSet,
!IO)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs1,
Args = Args1
@@ -602,27 +604,27 @@
string.from_char_list(['-', Opt], Option),
getopt_io.process_option(OptionData, Option, Flag, MaybeOptionArg,
OptionOps, OptionTable0, Result1, !OptionsSet, !IO),
- ( Result1 = ok(OptionTable1) ->
+ (
+ Result1 = ok(OptionTable1),
getopt_io.handle_short_options(Opts1, OptionOps, Args1, Args,
OptionArgs1, OptionArgs, OptionTable1, Result, !OptionsSet,
!IO)
;
+ Result1 = error(_),
Result = Result1,
OptionArgs = OptionArgs1,
Args = Args1
)
;
string.char_to_string(Opt, OptString),
- string.append_list(["unknown type for option `-",
- OptString, "'"], ErrorMsg),
+ ErrorMsg = "unknown type for option `-" ++ OptString ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
)
;
string.char_to_string(Opt, OptString),
- string.append_list(["unrecognized option `-", OptString, "'"],
- ErrorMsg),
+ ErrorMsg = "unrecognized option `-" ++ OptString ++ "'",
Result = error(ErrorMsg),
OptionArgs = OptionArgs0,
Args = Args0
@@ -778,8 +780,8 @@
MaybeArg = no,
error("string_special argument expected in getopt_io.process_option")
).
-getopt_io.process_option(maybe_string_special, Option, Flag, MaybeArg, OptionOps,
- OptionTable0, Result, !OptionsSet, !IO) :-
+getopt_io.process_option(maybe_string_special, Option, Flag, MaybeArg,
+ OptionOps, OptionTable0, Result, !OptionsSet, !IO) :-
(
MaybeArg = yes(_Arg),
getopt_io.process_special(Option, Flag, maybe_string(MaybeArg),
@@ -866,39 +868,33 @@
OptionOps, OptionTable0, Result, !OptionsSet)
;
OptionData = int_special,
- string.append_list(["cannot negate option `", Option, "' --",
- "only boolean, maybe and accumulating options can be negated"],
- ErrorMsg),
+ ErrorMsg = "cannot negate option `" ++ Option ++ "' --" ++
+ "only boolean, maybe and accumulating options can be negated",
Result = error(ErrorMsg)
;
OptionData = string_special,
- string.append_list(["cannot negate option `", Option, "' --",
- "only boolean, maybe and accumulating options can be negated"],
- ErrorMsg),
+ ErrorMsg = "cannot negate option `" ++ Option ++ "' --" ++
+ "only boolean, maybe and accumulating options can be negated",
Result = error(ErrorMsg)
;
OptionData = int(_),
- string.append_list(["cannot negate option `", Option, "' --",
- "only boolean, maybe and accumulating options can be negated"],
- ErrorMsg),
+ ErrorMsg = "cannot negate option `" ++ Option ++ "' --" ++
+ "only boolean, maybe and accumulating options can be negated",
Result = error(ErrorMsg)
;
OptionData = string(_),
- string.append_list(["cannot negate option `", Option, "' --",
- "only boolean, maybe and accumulating options can be negated"],
- ErrorMsg),
+ ErrorMsg = "cannot negate option `" ++ Option ++ "' --" ++
+ "only boolean, maybe and accumulating options can be negated",
Result = error(ErrorMsg)
;
OptionData = special,
- string.append_list(["cannot negate option `", Option, "' --",
- "only boolean, maybe and accumulating options can be negated"],
- ErrorMsg),
+ ErrorMsg = "cannot negate option `" ++ Option ++ "' --" ++
+ "only boolean, maybe and accumulating options can be negated",
Result = error(ErrorMsg)
;
OptionData = file_special,
- string.append_list(["cannot negate option `", Option, "' --",
- "only boolean, maybe and accumulating options can be negated"],
- ErrorMsg),
+ ErrorMsg = "cannot negate option `" ++ Option ++ "' --" ++
+ "only boolean, maybe and accumulating options can be negated",
Result = error(ErrorMsg)
)
;
@@ -941,8 +937,7 @@
)
;
MaybeHandler = none,
- string.append_list(["option `", Option, "' has no handler"],
- ErrorMsg),
+ ErrorMsg = "option `" ++ Option ++ "' has no handler",
Result = error(ErrorMsg)
).
@@ -967,9 +962,8 @@
maybe_option_table(OptionType)::out) is det.
getopt_io.numeric_argument(Option, Arg, Result) :-
- string.append_list(["option `", Option,
- "' requires a numeric argument; `", Arg, "' is not numeric"],
- ErrorMsg),
+ ErrorMsg = "option `" ++ Option ++
+ "' requires a numeric argument; `" ++ Arg ++ "' is not numeric",
Result = error(ErrorMsg).
%-----------------------------------------------------------------------------%
Index: library/group.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/group.m,v
retrieving revision 1.28
diff -u -r1.28 group.m
--- library/group.m 27 Sep 2006 06:16:39 -0000 1.28
+++ library/group.m 21 Nov 2007 04:35:37 -0000
@@ -181,10 +181,14 @@
set.to_sorted_list(S0, S1),
list.length(S1, Sz1),
compare(R, Sz1, Sz0),
- ( R = (>) ->
+ (
+ R = (>),
Sz = Sz1,
GK2 = GK0
;
+ ( R = (=)
+ ; R = (<)
+ ),
Sz = Sz0,
GK2 = GK1
),
Index: library/integer.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/integer.m,v
retrieving revision 1.28
diff -u -r1.28 integer.m
--- library/integer.m 10 May 2007 05:55:38 -0000 1.28
+++ library/integer.m 21 Nov 2007 02:43:36 -0000
@@ -5,11 +5,11 @@
% 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: integer.m.
% Main authors: aet, Dan Hazel <odin at svrc.uq.edu.au>.
% Stability: high.
-%
+%
% Implements an arbitrary precision integer type and basic
% operations on it. (An arbitrary precision integer may have
% any number of digits, unlike an int, which is limited to the
@@ -17,7 +17,7 @@
%
% NOTE: All operators behave as the equivalent operators on ints do.
% This includes the division operators: / // rem div mod.
-%
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -573,11 +573,14 @@
Sum = big_sign(SignX, pos_plus(AbsX, AbsY))
;
C = pos_cmp(AbsX, AbsY),
- ( C = (<) ->
+ (
+ C = (<),
Sum = big_sign(SignY, pos_minus(AbsY, AbsX))
- ; C = (>) ->
+ ;
+ C = (>),
Sum = big_sign(SignX, pos_minus(AbsX, AbsY))
;
+ C = (=),
Sum = integer.zero
)
)
@@ -1073,11 +1076,13 @@
digits_to_string(Digits @ [_ | _]) = Str :-
printbase_rep(printbase_pos_int_to_digits(base),
Digits, i(_, DigitsInPrintBase)),
- ( DigitsInPrintBase = [Head | Tail] ->
+ (
+ DigitsInPrintBase = [Head | Tail],
string.int_to_string(Head, SHead),
digits_to_strings(Tail, Ss, []),
string.append_list([SHead | Ss], Str)
;
+ DigitsInPrintBase = [],
error("integer.digits_to_string/1: empty list")
).
Index: library/io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.405
diff -u -r1.405 io.m
--- library/io.m 30 Oct 2007 00:46:21 -0000 1.405
+++ library/io.m 21 Nov 2007 02:51:55 -0000
@@ -1031,13 +1031,13 @@
:- typeclass io.binary_stream(T).
:- instance io.binary_stream(io.binary_input_stream).
:- instance io.binary_stream(io.binary_output_stream).
-
+
% Seek to an offset relative to Whence (documented above)
% on a specified binary stream. Attempting to seek on a pipe
% or tty results in implementation dependent behaviour.
%
:- pragma obsolete(io.seek_binary/5).
-:- pred io.seek_binary(T::in, io.whence::in, int::in, io::di, io::uo)
+:- pred io.seek_binary(T::in, io.whence::in, int::in, io::di, io::uo)
is det <= io.binary_stream(T).
% Seek to an offset relative to Whence (documented above)
@@ -1055,7 +1055,7 @@
int::in, io::di, io::uo) is det.
% Returns the offset (in bytes) into the specified binary stream.
- %
+ %
% NOTE: this predicate is deprecated; please use either
% io.binary_input_stream_offset or io.binary_output_stream_offset
% instead.
@@ -1809,7 +1809,7 @@
:- pragma foreign_type("Erlang", io.stream, "").
% A unique identifier for an I/O stream.
- %
+ %
:- type io.stream_id == int.
:- func io.get_stream_id(io.stream) = io.stream_id.
@@ -1931,7 +1931,7 @@
Result = ok
;
Result = error(io_error(ErrMsg))
- )
+ )
;
NumBytes = 0,
byte_in_range(!.Bitmap, Start)
@@ -2035,7 +2035,7 @@
Res = ok
;
!:BMs = [!.BM | !.BMs],
-
+
% Double the buffer size each time.
%
io.read_binary_file_as_bitmap_2(Stream, BufferSize * 2,
@@ -2183,7 +2183,7 @@
break;
}
if (char_code == 0) {
- Res = -2;
+ Res = -2;
break;
}
if (char_code != (MR_UnsignedChar) char_code) {
@@ -2324,7 +2324,7 @@
Result0 = error(Error),
Result = error(String, Error)
)
- ;
+ ;
Result = error("", io_error("null character in input"))
).
@@ -2887,7 +2887,13 @@
io.file_type(FollowSymLinks, FileName, MaybeType, !IO) :-
( file_type_implemented ->
- FollowSymLinksInt = (FollowSymLinks = yes -> 1 ; 0),
+ (
+ FollowSymLinks = yes,
+ FollowSymLinksInt = 1
+ ;
+ FollowSymLinks = no,
+ FollowSymLinksInt = 0
+ ),
io.file_type_2(FollowSymLinksInt, FileName, MaybeType, !IO)
;
MaybeType = error(io.make_io_error(
@@ -2896,7 +2902,8 @@
:- pred file_type_implemented is semidet.
-file_type_implemented :- semidet_fail.
+file_type_implemented :-
+ semidet_fail.
:- pragma foreign_proc("C",
file_type_implemented,
@@ -2912,8 +2919,9 @@
:- pragma foreign_proc("C#",
file_type_implemented,
[will_not_call_mercury, promise_pure, thread_safe],
- "SUCCESS_INDICATOR = true;"
-).
+"
+ SUCCESS_INDICATOR = true;
+").
:- pragma foreign_proc("Java",
file_type_implemented,
[will_not_call_mercury, promise_pure, thread_safe],
@@ -3405,7 +3413,8 @@
check_directory_accessibility_dotnet(FileName,
to_int(CheckRead), to_int(CheckWrite), Result, !IO)
;
- ( CheckRead = yes ->
+ (
+ CheckRead = yes,
io.open_input(FileName, InputRes, !IO),
(
InputRes = ok(InputStream),
@@ -3416,6 +3425,7 @@
CheckReadRes = error(InputError)
)
;
+ CheckRead = no,
CheckReadRes = ok
),
(
@@ -3978,12 +3988,15 @@
true
;
io.read_char(input_stream(Stream), CharResult, !IO),
- ( CharResult = ok(Char) ->
+ (
+ CharResult = ok(Char),
array.set(!.Array, !.Pos, Char, !:Array),
!:Pos = !.Pos + 1,
io.read_into_array(Stream, !Array, !Pos, Size, !IO)
;
- true
+ CharResult = error(_)
+ ;
+ CharResult = eof
)
).
@@ -4572,11 +4585,18 @@
% We've read the newline and the trailing full stop.
% Now skip the newline after the full stop.
io.read_char(input_stream(Stream), NewLineRes, !IO),
- ( NewLineRes = error(Error) ->
+ (
+ NewLineRes = error(Error),
Result = error(Error)
- ; NewLineRes = ok('\n') ->
- Result = ok(T)
;
+ NewLineRes = ok(NewLineChar),
+ ( NewLineChar = '\n' ->
+ Result = ok(T)
+ ;
+ Result = error(io_error("io.read_binary: missing newline"))
+ )
+ ;
+ NewLineRes = eof,
Result = error(io_error("io.read_binary: missing newline"))
)
;
@@ -5299,7 +5319,7 @@
io.init_state(!IO) :-
init_std_streams(!IO),
- %
+ %
% In C grades the "current" streams are thread-local values, so can only be
% set after the MR_Context has been initialised for the initial thread.
%
@@ -6151,7 +6171,7 @@
MR_Unsigned mercury_current_text_output_index;
MR_Unsigned mercury_current_binary_input_index;
MR_Unsigned mercury_current_binary_output_index;
-
+
void
mercury_init_io(void)
{
@@ -6185,7 +6205,7 @@
*/
MR_file(mercury_stdin_binary) = stdin;
}
-
+
MR_file(mercury_stdout_binary) = fdopen(dup(fileno(stdout)), ""wb"");
if (MR_file(mercury_stdout_binary) == NULL) {
MR_file(mercury_stdout_binary) = stdout;
@@ -6535,7 +6555,7 @@
mercury_open_stream(FileName, Mode) ->
ParentPid = self(),
- Pid = spawn(fun() ->
+ Pid = spawn(fun() ->
% Raw streams can only be used by the process which opened it.
mercury_start_file_server(ParentPid, FileName, Mode)
end),
@@ -7242,7 +7262,7 @@
%----------------------------------------------------------------------------%
%
-% Input predicates
+% Input predicates
%
io.read_char_code(input_stream(Stream), CharCode, !IO) :-
@@ -7494,7 +7514,7 @@
io.write_bitmap(Bitmap, !IO) :-
io.binary_output_stream(Stream, !IO),
io.write_bitmap(Stream, Bitmap, !IO).
-
+
io.write_bitmap(Bitmap, Start, NumBytes, !IO) :-
io.binary_output_stream(Stream, !IO),
io.write_bitmap(Stream, Bitmap, Start, NumBytes, !IO).
@@ -7878,7 +7898,7 @@
io.write_bytes(binary_output_stream(Stream), Message, !IO) :-
io.write_bytes_2(Stream, Message, !IO).
-:- pred io.write_bytes_2(io.stream::in, string::in, io::di, io::uo) is det.
+:- pred io.write_bytes_2(io.stream::in, string::in, io::di, io::uo) is det.
:- pragma foreign_proc("C",
io.write_bytes_2(Stream::in, Message::in, IO0::di, IO::uo),
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
@@ -7887,7 +7907,7 @@
mercury_print_binary_string(Stream, Message);
MR_update_io(IO0, IO);
").
-
+
io.write_bitmap(binary_output_stream(Stream), Bitmap, !IO) :-
( NumBytes = Bitmap ^ num_bytes ->
io.do_write_bitmap(Stream, Bitmap, 0, NumBytes, !IO)
@@ -10269,7 +10289,8 @@
io.file_type(FollowSymLinks, FileName, ResFileType, !IO),
(
ResFileType = ok(FileType),
- ( FileType = directory ->
+ (
+ FileType = directory,
dir.foldl2(remove_directory_entry, FileName, ok, Res0, !IO),
(
Res0 = ok(MaybeError),
@@ -10285,6 +10306,17 @@
Res = error(Error)
)
;
+ ( FileType = regular_file
+ ; FileType = symbolic_link
+ ; FileType = named_pipe
+ ; FileType = socket
+ ; FileType = character_device
+ ; FileType = block_device
+ ; FileType = message_queue
+ ; FileType = semaphore
+ ; FileType = shared_memory
+ ; FileType = unknown
+ ),
io.remove_file(FileName, Res, !IO)
)
;
@@ -10732,7 +10764,7 @@
io.read_byte(Stream, Result0, !IO),
Result = io.result_to_stream_result(Result0)
)
-].
+].
:- instance stream.bulk_reader(io.binary_input_stream, int,
bitmap, io, io.error)
@@ -10758,7 +10790,7 @@
Whence = stream_whence_to_io_whence(Whence0),
io.seek_binary_input(Stream, Whence, OffSet, !IO)
)
-].
+].
:- func stream_whence_to_io_whence(stream.whence) = io.whence.
@@ -10816,7 +10848,7 @@
Whence = stream_whence_to_io_whence(Whence0),
io.seek_binary_output(Stream, Whence, OffSet, !IO)
)
-].
+].
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: library/list.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/list.m,v
retrieving revision 1.169
diff -u -r1.169 list.m
--- library/list.m 10 Sep 2007 04:44:06 -0000 1.169
+++ library/list.m 21 Nov 2007 03:25:51 -0000
@@ -2584,11 +2584,13 @@
:- func list_to_doc_2(list(T)) = doc.
list_to_doc_2([]) = str("").
-list_to_doc_2([X | Xs]) =
- ( if Xs = [] then
- format_arg(format(X))
- else
- docs([
+list_to_doc_2([X | Xs]) = Doc :-
+ (
+ Xs = [],
+ Doc = format_arg(format(X))
+ ;
+ Xs = [_ | _],
+ Doc = docs([
format_arg(format(X)),
group([str(", "), nl]),
format_susp((func) = list_to_doc_2(Xs))
Index: library/parser.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/parser.m,v
retrieving revision 1.56
diff -u -r1.56 parser.m
--- library/parser.m 1 Nov 2006 06:33:37 -0000 1.56
+++ library/parser.m 21 Nov 2007 03:33:16 -0000
@@ -194,9 +194,11 @@
Result).
parse_tokens_with_op_table(Ops, FileName, Tokens, Result) :-
- ( Tokens = token_nil ->
+ (
+ Tokens = token_nil,
Result = eof
;
+ Tokens = token_cons(_, _, _),
init_parser_state(Ops, FileName, Tokens, ParserState0),
parse_whole_term(Term, ParserState0, ParserState),
final_parser_state(ParserState, VarSet, LeftOverTokens),
@@ -214,18 +216,20 @@
LineNum = BadTokenLineNum
;
% Find the token that caused the error.
- ( ErrorTokens = token_cons(ErrorTok, ErrorTokLineNum, _) ->
+ (
+ ErrorTokens = token_cons(ErrorTok, ErrorTokLineNum, _),
lexer.token_to_string(ErrorTok, TokString),
- string.append_list(["Syntax error at ", TokString, ": ",
- ErrorMessage], Message),
+ Message = "Syntax error at " ++ TokString ++ ": " ++ ErrorMessage,
LineNum = ErrorTokLineNum
;
- ( Tokens = token_cons(_, FirstTokLineNum, _) ->
- LineNum = FirstTokLineNum
+ ErrorTokens = token_nil,
+ (
+ Tokens = token_cons(_, LineNum, _)
;
+ Tokens = token_nil,
error("check_for_errors")
),
- string.append("Syntax error: ", ErrorMessage, Message)
+ Message = "Syntax error: " ++ ErrorMessage
)
),
Result = error(Message, LineNum).
@@ -233,12 +237,16 @@
check_for_errors(ok(Term), VarSet, Tokens, LeftOverTokens, Result) :-
( check_for_bad_token(Tokens, Message, LineNum) ->
Result = error(Message, LineNum)
- ; LeftOverTokens = token_cons(Token, LineNum, _) ->
- lexer.token_to_string(Token, TokString),
- Message = "Syntax error: unexpected " ++ TokString,
- Result = error(Message, LineNum)
;
- Result = term(VarSet, Term)
+ (
+ LeftOverTokens = token_cons(Token, LineNum, _),
+ lexer.token_to_string(Token, TokString),
+ Message = "Syntax error: unexpected " ++ TokString,
+ Result = error(Message, LineNum)
+ ;
+ LeftOverTokens = token_nil,
+ Result = term(VarSet, Term)
+ )
).
:- pred check_for_bad_token(token_list::in, string::out, int::out) is semidet.
@@ -314,9 +322,11 @@
parse_term_2(MaxPriority, TermKind, Term, !PS) :-
parse_left_term(MaxPriority, TermKind, LeftPriority, LeftTerm0, !PS),
- ( LeftTerm0 = ok(LeftTerm) ->
+ (
+ LeftTerm0 = ok(LeftTerm),
parse_rest(MaxPriority, TermKind, LeftPriority, LeftTerm, Term, !PS)
;
+ LeftTerm0 = error(_, _),
% propagate error upwards
Term = LeftTerm0
).
@@ -361,18 +371,22 @@
RightRightAssoc, RightRightPriority),
OpPriority = BinOpPriority,
parse_term_2(RightPriority, TermKind, RightResult, !PS),
- ( RightResult = ok(RightTerm) ->
+ (
+ RightResult = ok(RightTerm),
parse_term_2(RightRightPriority, TermKind, RightRightResult,
!PS),
- ( RightRightResult = ok(RightRightTerm) ->
+ (
+ RightRightResult = ok(RightRightTerm),
get_term_context(!.PS, Context, TermContext),
Term = ok(term.functor(term.atom(Op),
[RightTerm, RightRightTerm], TermContext))
;
+ RightRightResult = error(_, _),
% Propagate error upwards.
Term = RightRightResult
)
;
+ RightResult = error(_, _),
% Propagate error upwards.
Term = RightResult
)
@@ -390,11 +404,13 @@
RightPriority),
parse_term_2(RightPriority, TermKind, RightResult, !PS),
OpPriority = UnOpPriority,
- ( RightResult = ok(RightTerm) ->
+ (
+ RightResult = ok(RightTerm),
get_term_context(!.PS, Context, TermContext),
Term = ok(term.functor(term.atom(Op), [RightTerm],
TermContext))
;
+ RightResult = error(_, _),
% Propagate error upwards.
Term = RightResult
)
@@ -452,7 +468,8 @@
->
adjust_priority_for_assoc(OpPriority, RightAssoc, RightPriority),
parse_term_2(RightPriority, TermKind, RightTerm0, !PS),
- ( RightTerm0 = ok(RightTerm) ->
+ (
+ RightTerm0 = ok(RightTerm),
get_term_context(!.PS, Context, TermContext),
OpTerm0 = term.functor(term.atom(Op),
list.append(VariableTerm, [LeftTerm, RightTerm]),
@@ -467,6 +484,7 @@
),
parse_rest(MaxPriority, TermKind, OpPriority, OpTerm, Term, !PS)
;
+ RightTerm0 = error(_, _),
% Propagate error upwards.
Term = RightTerm0
)
@@ -650,7 +668,8 @@
% "'{}'(1,2,3)". This makes the structure of tuple functors the same
% as other functors.
parse_term(SubTerm0, !PS),
- ( SubTerm0 = ok(SubTerm) ->
+ (
+ SubTerm0 = ok(SubTerm),
conjunction_to_list(SubTerm, ArgTerms),
( parser_get_token(close_curly, !PS) ->
Term = ok(term.functor(term.atom("{}"), ArgTerms,
@@ -659,6 +678,7 @@
parser_unexpected("expecting `}' or operator", Term, !PS)
)
;
+ SubTerm0 = error(_, _),
% Propagate error upwards.
Term = SubTerm0
)
@@ -726,9 +746,11 @@
parse_list(List, !PS) :-
parse_list_elem(Arg0, !PS),
- ( Arg0 = ok(Arg) ->
+ (
+ Arg0 = ok(Arg),
parse_list_2(Arg, List, !PS)
;
+ Arg0 = error(_, _),
% Propagate error.
List = Arg0
).
@@ -741,16 +763,19 @@
get_term_context(!.PS, Context, TermContext),
( Token = comma ->
parse_list(Tail0, !PS),
- ( Tail0 = ok(Tail) ->
+ (
+ Tail0 = ok(Tail),
List = ok(term.functor(term.atom("[|]"), [Arg, Tail],
TermContext))
;
+ Tail0 = error(_, _),
% Propagate error.
List = Tail0
)
; Token = ht_sep ->
parse_arg(Tail0, !PS),
- ( Tail0 = ok(Tail) ->
+ (
+ Tail0 = ok(Tail),
( parser_get_token(close_list, !PS) ->
List = ok(term.functor(term.atom("[|]"), [Arg, Tail],
TermContext))
@@ -758,6 +783,7 @@
parser_unexpected("expecting ']' or operator", List, !PS)
)
;
+ Tail0 = error(_, _),
% Propagate error.
List = Tail0
)
@@ -784,9 +810,11 @@
( parser_get_token_context(Token, Context, !PS) ->
( Token = comma ->
parse_args(Tail0, !PS),
- ( Tail0 = ok(Tail) ->
+ (
+ Tail0 = ok(Tail),
List = ok([Arg|Tail])
;
+ Tail0 = error(_, _),
% Propagate error upwards.
List = Tail0
)
Index: library/rbtree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/rbtree.m,v
retrieving revision 1.29
diff -u -r1.29 rbtree.m
--- library/rbtree.m 10 Sep 2007 04:44:06 -0000 1.29
+++ library/rbtree.m 21 Nov 2007 04:35:57 -0000
@@ -254,10 +254,15 @@
rbtree.insert(black(K0, V0, L0, R0), K, V, Tree) :-
rbtree.insert_2(black(K0, V0, L0, R0), K, V, Tree0),
% Ensure that the root of the tree is black.
- ( Tree0 = red(K1, V1, L1, R1) ->
+ (
+ Tree0 = black(_, _, _, _),
+ Tree = Tree0
+ ;
+ Tree0 = red(K1, V1, L1, R1),
Tree = black(K1, V1, L1, R1)
;
- Tree = Tree0
+ Tree0 = empty,
+ error("rbtree.set: new tree is empty")
).
% rbtree.insert_2:
@@ -436,10 +441,15 @@
rbtree.set(black(K0, V0, L0, R0), K, V, Tree) :-
rbtree.set_2(black(K0, V0, L0, R0), K, V, Tree0),
% Ensure that the root of the tree is black.
- ( Tree0 = red(K1, V1, L1, R1) ->
+ (
+ Tree0 = black(_, _, _, _),
+ Tree = Tree0
+ ;
+ Tree0 = red(K1, V1, L1, R1),
Tree = black(K1, V1, L1, R1)
;
- Tree = Tree0
+ Tree0 = empty,
+ error("rbtree.set: new tree is empty")
).
% rbtree.set_2:
@@ -654,9 +664,8 @@
Result = (=),
rbtree.insert_duplicate_2(L0, K, V, NewL),
(
- % Only need to start looking for a rotation case
- % if the current node is black(known), and its
- % new child red.
+ % Only need to start looking for a rotation case if the
+ % current node is black(known), and its new child red.
NewL = red(LK, LV, LL, LR)
->
% Check to see if a grandchild is red and if so rotate.
@@ -882,20 +891,28 @@
rbtree.remove_largest(empty, _K, _V, _Tree) :-
fail.
rbtree.remove_largest(red(K0, V0, L, R), NewK, NewV, Tree) :-
- ( R = empty ->
+ (
+ R = empty,
NewK = K0,
NewV = V0,
Tree = L
;
+ ( R = red(_, _, _, _)
+ ; R = black(_, _, _, _)
+ ),
rbtree.remove_largest(R, NewK, NewV, NewR),
Tree = red(K0, V0, L, NewR)
).
rbtree.remove_largest(black(K0, V0, L, R), NewK, NewV, Tree) :-
- ( R = empty ->
+ (
+ R = empty,
NewK = K0,
NewV = V0,
Tree = L
;
+ ( R = red(_, _, _, _)
+ ; R = black(_, _, _, _)
+ ),
rbtree.remove_largest(R, NewK, NewV, NewR),
Tree = black(K0, V0, L, NewR)
).
@@ -907,20 +924,28 @@
rbtree.remove_smallest(empty, _K, _V, _Tree) :-
fail.
rbtree.remove_smallest(red(K0, V0, L, R), NewK, NewV, Tree) :-
- ( L = empty ->
+ (
+ L = empty,
NewK = K0,
NewV = V0,
Tree = R
;
+ ( L = red(_, _, _, _)
+ ; L = black(_, _, _, _)
+ ),
rbtree.remove_smallest(L, NewK, NewV, NewL),
Tree = red(K0, V0, NewL, R)
).
rbtree.remove_smallest(black(K0, V0, L, R), NewK, NewV, Tree) :-
- ( L = empty ->
+ (
+ L = empty,
NewK = K0,
NewV = V0,
Tree = R
;
+ ( L = red(_, _, _, _)
+ ; L = black(_, _, _, _)
+ ),
rbtree.remove_smallest(L, NewK, NewV, NewL),
Tree = black(K0, V0, NewL, R)
).
Index: library/rtree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/rtree.m,v
retrieving revision 1.5
diff -u -r1.5 rtree.m
--- library/rtree.m 23 Oct 2006 05:37:22 -0000 1.5
+++ library/rtree.m 21 Nov 2007 04:24:08 -0000
@@ -1425,9 +1425,14 @@
is semidet.
fold_subtree(P, K, T, !Acc) :-
- ( T = leaf(V) ->
+ (
+ T = leaf(V),
P(K, V, !Acc)
;
+ ( T = two(_, _, _, _)
+ ; T = three(_, _, _, _, _, _)
+ ; T = four(_, _, _, _, _, _, _, _)
+ ),
fold_2(P, T, !Acc)
).
@@ -1449,28 +1454,33 @@
map_values_2(_, leaf(_), _) :-
error("map_values_2: unexpected leaf.").
map_values_2(P, two(K0, T0, K1, T1), two(K0, U0, K1, U1)) :-
- map_values_2(P, K0, T0, U0),
- map_values_2(P, K1, T1, U1).
+ map_values_key_2(P, K0, T0, U0),
+ map_values_key_2(P, K1, T1, U1).
map_values_2(P, three(K0, T0, K1, T1, K2, T2), three(K0, U0, K1, U1, K2, U2)) :-
- map_values_2(P, K0, T0, U0),
- map_values_2(P, K1, T1, U1),
- map_values_2(P, K2, T2, U2).
+ map_values_key_2(P, K0, T0, U0),
+ map_values_key_2(P, K1, T1, U1),
+ map_values_key_2(P, K2, T2, U2).
map_values_2(P, four(K0, T0, K1, T1, K2, T2, K3, T3),
four(K0, U0, K1, U1, K2, U2, K3, U3)) :-
- map_values_2(P, K0, T0, U0),
- map_values_2(P, K1, T1, U1),
- map_values_2(P, K2, T2, U2),
- map_values_2(P, K3, T3, U3).
-
-:- pred map_values_2(pred(K, V, W), K, rtree_2(K, V), rtree_2(K, W)).
-:- mode map_values_2(pred(in, in, out) is det, in, in, out) is det.
-:- mode map_values_2(pred(in, in, out) is semidet, in, in, out) is semidet.
-
-map_values_2(P, K, T, U) :-
- ( T = leaf(V) ->
+ map_values_key_2(P, K0, T0, U0),
+ map_values_key_2(P, K1, T1, U1),
+ map_values_key_2(P, K2, T2, U2),
+ map_values_key_2(P, K3, T3, U3).
+
+:- pred map_values_key_2(pred(K, V, W), K, rtree_2(K, V), rtree_2(K, W)).
+:- mode map_values_key_2(pred(in, in, out) is det, in, in, out) is det.
+:- mode map_values_key_2(pred(in, in, out) is semidet, in, in, out) is semidet.
+
+map_values_key_2(P, K, T, U) :-
+ (
+ T = leaf(V),
P(K, V, W),
U = leaf(W)
;
+ ( T = two(_, _, _, _)
+ ; T = three(_, _, _, _, _, _)
+ ; T = four(_, _, _, _, _, _, _, _)
+ ),
map_values_2(P, T, U)
).
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.81
diff -u -r1.81 rtti_implementation.m
--- library/rtti_implementation.m 20 Aug 2007 03:36:16 -0000 1.81
+++ library/rtti_implementation.m 21 Nov 2007 03:42:23 -0000
@@ -612,10 +612,14 @@
SubTermB = get_subterm(ArgTypeInfo, TermB, Loc - 1, 0),
generic_compare(SubResult, SubTermA, unsafe_cast(SubTermB)),
- ( SubResult = (=) ->
+ (
+ SubResult = (=),
compare_tuple_pos(Loc + 1, TupleArity, TypeInfo, Result,
TermA, TermB)
;
+ ( SubResult = (<)
+ ; SubResult = (>)
+ ),
Result = SubResult
)
).
@@ -802,27 +806,40 @@
% to the type_ctor_infos.
compare(NameRes, TypeCtorInfo1 ^ type_ctor_name,
TypeCtorInfo2 ^ type_ctor_name),
- ( NameRes = (=) ->
+ (
+ NameRes = (=),
compare(ModNameRes,
TypeCtorInfo1 ^ type_ctor_module_name,
TypeCtorInfo2 ^ type_ctor_module_name),
(
ModNameRes = (=),
- type_ctor_is_variable_arity(TypeCtorInfo1)
- ->
- Arity1 = get_var_arity_typeinfo_arity(TypeInfo1),
- Arity2 = get_var_arity_typeinfo_arity(TypeInfo2),
- compare(ArityRes, Arity1, Arity2),
- ( ArityRes = (=) ->
- compare_var_arity_typeinfos(1, Arity1, Res,
- TypeInfo1, TypeInfo2)
+ ( type_ctor_is_variable_arity(TypeCtorInfo1) ->
+ Arity1 = get_var_arity_typeinfo_arity(TypeInfo1),
+ Arity2 = get_var_arity_typeinfo_arity(TypeInfo2),
+ compare(ArityRes, Arity1, Arity2),
+ (
+ ArityRes = (=),
+ compare_var_arity_typeinfos(1, Arity1, Res,
+ TypeInfo1, TypeInfo2)
+ ;
+ ( ArityRes = (<)
+ ; ArityRes = (>)
+ ),
+ Res = ArityRes
+ )
;
- Res = ArityRes
+ Res = (=)
)
;
+ ( ModNameRes = (<)
+ ; ModNameRes = (>)
+ ),
Res = ModNameRes
)
;
+ ( NameRes = (<)
+ ; NameRes = (>)
+ ),
Res = NameRes
).
@@ -837,10 +854,14 @@
SubTypeInfoB = TypeInfoB ^ var_arity_type_info_index(Loc),
compare_collapsed_type_infos(SubResult, SubTypeInfoA, SubTypeInfoB),
- ( SubResult = (=) ->
+ (
+ SubResult = (=),
compare_var_arity_typeinfos(Loc + 1, Arity, Result,
TypeInfoA, TypeInfoB)
;
+ ( SubResult = (<)
+ ; SubResult = (>)
+ ),
Result = SubResult
)
).
@@ -1400,9 +1421,7 @@
get_arg_type_info(TypeInfoParams, PseudoTypeInfo, Term, FunctorDesc,
ArgTypeInfo) :-
- (
- typeinfo_is_variable(PseudoTypeInfo, VarNum)
- ->
+ ( typeinfo_is_variable(PseudoTypeInfo, VarNum) ->
get_type_info_for_var(TypeInfoParams, VarNum, Term, FunctorDesc,
ExpandedTypeInfo),
( typeinfo_is_variable(ExpandedTypeInfo, _) ->
@@ -1413,9 +1432,7 @@
;
CastTypeInfo = type_info_cast(PseudoTypeInfo),
TypeCtorInfo = get_type_ctor_info(CastTypeInfo),
- (
- type_ctor_is_variable_arity(TypeCtorInfo)
- ->
+ ( type_ctor_is_variable_arity(TypeCtorInfo) ->
Arity = pseudotypeinfo_get_higher_order_arity(CastTypeInfo),
StartRegionSize = 2
;
@@ -1425,28 +1442,31 @@
ArgTypeInfo0 = maybe.no,
UpperBound = Arity + StartRegionSize - 1,
- iterate_foldl(StartRegionSize, UpperBound,
+ ProcessArgTypeInfos =
(pred(I::in, TI0::in, TI::out) is det :-
PTI = get_pti_from_type_info(CastTypeInfo, I),
get_arg_type_info(TypeInfoParams, PTI, Term, FunctorDesc,
ETypeInfo),
- (
- same_pointer_value_untyped(ETypeInfo, PTI)
- ->
+ ( same_pointer_value_untyped(ETypeInfo, PTI) ->
TI = TI0
;
- TI0 = maybe.yes(TypeInfo0)
- ->
- unsafe_promise_unique(TypeInfo0, TypeInfo1),
- update_type_info_index(I, ETypeInfo, TypeInfo1, TypeInfo),
- TI = maybe.yes(TypeInfo)
- ;
- NewTypeInfo0 = new_type_info(CastTypeInfo, UpperBound),
- update_type_info_index(I, ETypeInfo, NewTypeInfo0,
- NewTypeInfo),
- TI = maybe.yes(NewTypeInfo)
+ (
+ TI0 = yes(TypeInfo0),
+ unsafe_promise_unique(TypeInfo0, TypeInfo1),
+ update_type_info_index(I, ETypeInfo,
+ TypeInfo1, TypeInfo),
+ TI = yes(TypeInfo)
+ ;
+ TI0 = no,
+ NewTypeInfo0 = new_type_info(CastTypeInfo, UpperBound),
+ update_type_info_index(I, ETypeInfo,
+ NewTypeInfo0, NewTypeInfo),
+ TI = yes(NewTypeInfo)
+ )
)
- ), ArgTypeInfo0, MaybeArgTypeInfo),
+ ),
+ iterate_foldl(StartRegionSize, UpperBound, ProcessArgTypeInfos,
+ ArgTypeInfo0, MaybeArgTypeInfo),
(
MaybeArgTypeInfo = maybe.yes(ArgTypeInfo1),
ArgTypeInfo = ArgTypeInfo1
Index: library/string.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/string.m,v
retrieving revision 1.267
diff -u -r1.267 string.m
--- library/string.m 10 Sep 2007 04:45:06 -0000 1.267
+++ library/string.m 21 Nov 2007 03:51:56 -0000
@@ -2447,18 +2447,7 @@
% Prefix with appropriate sign or zero padding.
% The previous step has deliberately left room for this.
- ( Int < 0 ->
- SignedStr = "-" ++ FieldStr
- ; member('+', Flags) ->
- SignedStr = "+" ++ FieldStr
- ; member(' ', Flags) ->
- SignedStr = " " ++ FieldStr
- ; ZeroPadded = yes ->
- SignedStr = "0" ++ FieldStr
- ;
- SignedStr = FieldStr
- ),
-
+ SignedStr = add_int_prefix_if_needed(Flags, ZeroPadded, Int, FieldStr),
String = justify_string(Flags, Width, SignedStr).
% Format an unsigned int, unsigned octal, or unsigned hexadecimal
@@ -2602,21 +2591,9 @@
;
FieldStr = PrecModStr,
ZeroPadded = no
-
),
% Finishing up ..
- ( Float < 0.0 ->
- SignedStr = "-" ++ FieldStr
- ; member('+', Flags) ->
- SignedStr = "+" ++ FieldStr
- ; member(' ', Flags) ->
- SignedStr = " " ++ FieldStr
- ; ZeroPadded = yes ->
- SignedStr = "0" ++ FieldStr
- ;
- SignedStr = FieldStr
- ),
-
+ SignedStr = add_float_prefix_if_needed(Flags, ZeroPadded, Float, FieldStr),
NewFloat = justify_string(Flags, Width, SignedStr).
% Format a scientific number to a specified number of significant
@@ -2664,18 +2641,7 @@
),
% Finishing up ..
- ( Float < 0.0 ->
- SignedStr = "-" ++ FieldStr
- ; member('+', Flags) ->
- SignedStr = "+" ++ FieldStr
- ; member(' ', Flags) ->
- SignedStr = " " ++ FieldStr
- ; ZeroPadded = yes ->
- SignedStr = "0" ++ FieldStr
- ;
- SignedStr = FieldStr
- ),
-
+ SignedStr = add_float_prefix_if_needed(Flags, ZeroPadded, Float, FieldStr),
NewFloat = justify_string(Flags, Width, SignedStr).
% Format a scientific number (e,E)
@@ -2727,19 +2693,46 @@
),
% Finishing up ..
- ( Float < 0.0 ->
+ SignedStr = add_float_prefix_if_needed(Flags, ZeroPadded, Float, FieldStr),
+ NewFloat = justify_string(Flags, Width, SignedStr).
+
+:- func add_int_prefix_if_needed(flags, bool, int, string) = string.
+
+add_int_prefix_if_needed(Flags, ZeroPadded, Int, FieldStr) = SignedStr :-
+ ( Int < 0 ->
SignedStr = "-" ++ FieldStr
; member('+', Flags) ->
SignedStr = "+" ++ FieldStr
; member(' ', Flags) ->
SignedStr = " " ++ FieldStr
- ; ZeroPadded = yes ->
- SignedStr = "0" ++ FieldStr
;
- SignedStr = FieldStr
- ),
+ (
+ ZeroPadded = yes,
+ SignedStr = "0" ++ FieldStr
+ ;
+ ZeroPadded = no,
+ SignedStr = FieldStr
+ )
+ ).
- NewFloat = justify_string(Flags, Width, SignedStr).
+:- func add_float_prefix_if_needed(flags, bool, float, string) = string.
+
+add_float_prefix_if_needed(Flags, ZeroPadded, Float, FieldStr) = SignedStr :-
+ ( Float < 0.0 ->
+ SignedStr = "-" ++ FieldStr
+ ; member('+', Flags) ->
+ SignedStr = "+" ++ FieldStr
+ ; member(' ', Flags) ->
+ SignedStr = " " ++ FieldStr
+ ;
+ (
+ ZeroPadded = yes,
+ SignedStr = "0" ++ FieldStr
+ ;
+ ZeroPadded = no,
+ SignedStr = FieldStr
+ )
+ ).
:- func justify_string(flags, maybe_width, string) = string.
Index: library/term_to_xml.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/term_to_xml.m,v
retrieving revision 1.18
diff -u -r1.18 term_to_xml.m
--- library/term_to_xml.m 6 Mar 2007 05:48:34 -0000 1.18
+++ library/term_to_xml.m 21 Nov 2007 04:29:35 -0000
@@ -1,15 +1,15 @@
%-----------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1993-2006 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: term_to_xml.m.
% Main author: maclarty.
% Stability: low.
-%
+%
% This module provides two mechanisms for converting Mercury terms
% to XML documents.
%
@@ -46,7 +46,7 @@
%
% In both methods the XML document can be annotated with a stylesheet
% reference.
-%
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -95,7 +95,7 @@
; comment(string)
% An XML comment. The comment should not
% include the `<!--' and `-->'. Any occurrences of
- % the substring "--" will be replaced by " - ",
+ % the substring "--" will be replaced by " - ",
% since "--" is not allowed in XML comments.
; entity(string)
@@ -464,7 +464,7 @@
in, in, di, uo) is det.
:- mode write_xml_element_general(in, in(canonicalize), in(element_mapping),
in, in, di, uo) is det.
-:- mode write_xml_element_general(in, in(include_details_cc),
+:- mode write_xml_element_general(in, in(include_details_cc),
in(element_mapping), in, in, di, uo) is cc_multi.
:- mode write_xml_element_general(in, in, in(element_mapping),
in, in, di, uo) is cc_multi.
@@ -540,7 +540,7 @@
:- pred write_dtd_from_type_to_stream(io.output_stream::in, type_desc::in,
element_mapping::in(element_mapping), dtd_generation_result::out,
io::di, io::uo) is det.
-
+
:- pragma obsolete(write_xml_element_general/6).
:- pred write_xml_element_general(deconstruct.noncanon_handling,
element_mapping, int, T, io, io).
@@ -571,8 +571,7 @@
%-----------------------------------------------------------------------------%
write_xml_doc(Stream, Term, !State) :-
- write_xml_doc_style_dtd(Stream, Term, no_stylesheet, no_dtd,
- !State).
+ write_xml_doc_style_dtd(Stream, Term, no_stylesheet, no_dtd, !State).
write_xml_doc_style_dtd(Stream, Term, MaybeStyleSheet, MaybeDTD, !State) :-
write_xml_header(Stream, no, !State),
@@ -606,24 +605,26 @@
DTDResult, !State) :-
DTDResult = can_generate_dtd_2(MaybeDTD, ElementMapping, type_of(Term)),
(
- DTDResult = ok
- ->
+ DTDResult = ok,
write_xml_header(Stream, no, !State),
write_stylesheet_ref(Stream, MaybeStyleSheet, !State),
write_doctype(Stream, canonicalize, Term, ElementMapping, MaybeDTD, _,
!State),
- write_xml_element_general(Stream, canonicalize, ElementMapping, 0,
+ write_xml_element_general(Stream, canonicalize, ElementMapping, 0,
Term, !State)
;
- true
+ ( DTDResult = multiple_functors_for_root
+ ; DTDResult = duplicate_elements(_, _)
+ ; DTDResult = unsupported_dtd_type(_)
+ ; DTDResult = type_not_ground(_)
+ )
).
write_xml_doc_general_cc(Stream, Term, ElementMapping, MaybeStyleSheet,
MaybeDTD, DTDResult, !State) :-
DTDResult = can_generate_dtd_2(MaybeDTD, ElementMapping, type_of(Term)),
(
- DTDResult = ok
- ->
+ DTDResult = ok,
write_xml_header(Stream, no, !State),
write_stylesheet_ref(Stream, MaybeStyleSheet, !State),
write_doctype(Stream, include_details_cc, Term, ElementMapping,
@@ -631,7 +632,11 @@
write_xml_element_general(Stream, include_details_cc, ElementMapping,
0, Term, !State)
;
- true
+ ( DTDResult = multiple_functors_for_root
+ ; DTDResult = duplicate_elements(_, _)
+ ; DTDResult = unsupported_dtd_type(_)
+ ; DTDResult = type_not_ground(_)
+ )
).
write_xml_element_general(Stream, NonCanon, ElementMapping, IndentLevel, Term,
@@ -1192,7 +1197,7 @@
MaybeFieldNames, _, !State)
).
-:- pred write_xml_element_univ_do_not_allow(Stream::in,
+:- pred write_xml_element_univ_do_not_allow(Stream::in,
element_pred::in(element_pred),
int::in, univ::in, list(maybe(string))::in, list(maybe(string))::out,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
@@ -1202,7 +1207,7 @@
write_xml_element_univ(Stream, do_not_allow, MakeElement, IndentLevel,
Univ, MaybeFieldNames0, MaybeFieldNames, !State).
-:- pred write_xml_element_univ_canonicalize(Stream::in,
+:- pred write_xml_element_univ_canonicalize(Stream::in,
element_pred::in(element_pred),
int::in, univ::in, list(maybe(string))::in, list(maybe(string))::out,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
@@ -1400,8 +1405,7 @@
write_dtd_from_type(Stream, TypeDesc, ElementMapping, DTDResult, !State) :-
DTDResult = can_generate_dtd(ElementMapping, TypeDesc),
(
- DTDResult = ok
- ->
+ DTDResult = ok,
get_element_pred(ElementMapping, MakeElement),
(
get_elements_and_args(MakeElement, TypeDesc,
@@ -1421,7 +1425,11 @@
++ ": not ok to generate DTD"))
)
;
- true
+ ( DTDResult = multiple_functors_for_root
+ ; DTDResult = duplicate_elements(_, _)
+ ; DTDResult = unsupported_dtd_type(_)
+ ; DTDResult = type_not_ground(_)
+ )
).
can_generate_dtd(ElementMapping, TypeDesc) = Result :-
Index: library/version_array.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/version_array.m,v
retrieving revision 1.15
diff -u -r1.15 version_array.m
--- library/version_array.m 30 May 2007 02:42:43 -0000 1.15
+++ library/version_array.m 21 Nov 2007 04:31:58 -0000
@@ -6,11 +6,11 @@
% Public License - see the file COPYING.LIB in the Mercury distribution.
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%-----------------------------------------------------------------------------%
-%
+%
% File: version_array.m.
% Author: Ralph Becket <rafe at cs.mu.oz.au>.
% Stability: low.
-%
+%
% (See the header comments in version_types.m for an explanation of version
% types.)
%
@@ -28,7 +28,7 @@
% XXX This implementation is not yet guaranteed to work with the agc (accurate
% garbage collection) grades. Specifically, MR_deep_copy and MR_agc_deep_copy
% currently do not recognise version arrays.
-%
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -43,8 +43,7 @@
%
:- func empty = version_array(T).
- % new(N, X) returns an array of size N with each item initialised
- % to X.
+ % new(N, X) returns an array of size N with each item initialised to X.
%
:- func new(int, T) = version_array(T).
@@ -231,12 +230,14 @@
% attributes!
:- pragma foreign_type("C", version_array(T), "struct ML_va *")
- where equality is eq_version_array,
- comparison is cmp_version_array.
+ where
+ equality is eq_version_array,
+ comparison is cmp_version_array.
% This is necessary for the library to compile in the il and java
% grades.
-:- type version_array(T) ---> version_array(T).
+:- type version_array(T)
+ ---> version_array(T).
:- pragma terminates(eq_version_array/2).
:- pred eq_version_array(version_array(T)::in, version_array(T)::in)
@@ -266,9 +267,13 @@
SizeA = VAa ^ size,
SizeB = VAb ^ size,
compare(SizeResult, SizeA, SizeB),
- ( SizeResult = (=) ->
+ (
+ SizeResult = (=),
cmp_version_array_2(0, SizeA, VAa, VAb, R)
;
+ ( SizeResult = (<)
+ ; SizeResult = (>)
+ ),
R = SizeResult
).
@@ -280,9 +285,14 @@
R = (=)
else
compare(R0, VAa ^ elem(I), VAb ^ elem(I)),
- ( if R0 = (=)
- then cmp_version_array_2(I + 1, Size, VAa, VAb, R)
- else R = R0
+ (
+ R0 = (=),
+ cmp_version_array_2(I + 1, Size, VAa, VAb, R)
+ ;
+ ( R0 = (<)
+ ; R0 = (>)
+ ),
+ R = R0
)
).
@@ -305,7 +315,7 @@
does_not_affect_liveness],
"
MR_Integer i;
-
+
VA = MR_GC_NEW(struct ML_va);
VA->index = -1;
VA->value = (MR_Word) NULL;
@@ -325,7 +335,7 @@
MR_Integer i;
MR_Integer size_VA0;
MR_Integer min;
-
+
size_VA0 = ML_va_size(VA0);
min = (N <= size_VA0 ? N : size_VA0);
VA = MR_GC_NEW(struct ML_va);
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/c_interface/standalone_c
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
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 ssdb
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
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
Index: tests/invalid/reserve_tag.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/reserve_tag.err_exp,v
retrieving revision 1.4
diff -u -r1.4 reserve_tag.err_exp
--- tests/invalid/reserve_tag.err_exp 7 Sep 2006 05:51:32 -0000 1.4
+++ tests/invalid/reserve_tag.err_exp 21 Nov 2007 23:50:08 -0000
@@ -7,7 +7,7 @@
reserve_tag.m:024: error: undefined type `reserve_tag.list'/1.
reserve_tag.m:025: In `pragma reserve_tag' declaration for
reserve_tag.m:025: `reserve_tag.exported_type'/0:
-reserve_tag.m:025: error: `reserve_tag' declaration must have the same
+reserve_tag.m:025: error: `pragma reserve_tag' declaration must have the same
reserve_tag.m:025: visibility as the type definition.
reserve_tag.m:032: In `pragma reserve_tag' declaration for
reserve_tag.m:032: `reserve_tag.invalid_arity'/1:
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/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing 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 messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list