mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-15 01:13:30 +00:00
823de2d37b
The objective of this step is two-fold:
- to fix --inhibit-warnings, making it shut up all warning
and informational messages; and
- to ensure that it *stays* fixed, even when after new diagnostics
are added.
As part of this fix, this diff adds a whole bunch of new warning
options, in order to control the warnings that previously were
not controlled by any option. (There was no need for new
informational options.)
As it happens, we have long used severity_informational for messages
that did not report any information about the code being compiled,
but to report actions that the compiler was taking. Create a new
option category, oc_report, for the new options that now control
those diagnostics.
---------------------
compiler/error_spec.m:
Change severity_warning and severity_informational to take an option
as as argument. The semantics is that the diagnostic in which
the severity occurs is conditional on that option, meaning that
it is printed only if that option is set to "yes".
Delete the severity_conditional function symbol from the severity
type, since the mechanism just above handles its only use case.
Define subtypes to represent error_specs in a standard form.
compiler/error_sort.m:
Provide operations to convert error specs into their standard form.
Make the sorting operation itself operate on the standard form.
compiler/write_error_spec.m:
Convert error_specs to standard form before writing them out,
in order to avoid duplicating the code for their standardization.
Change the code that writes out error_specs to operate on the
standard form. Implement the test implicit in the warning and
and informational severities in this code.
compiler/error_util.m:
compiler/compiler_util.m:
Delete operations that do not make sense with the new severity type.
---------------------
compiler/options.m:
Add new options to control all the previously-uncontrolled
warning and informational messages.
NEWS.md:
Announce the *public* new options.
compiler/option_categories.m:
compiler/print_help.m:
Add the new option category, and fake-include it in the help text
and the user guide. (The inclusion is fake because none of the
options in the new category are user visible, meaning the section
containing them is not visible either.)
---------------------
compiler/det_infer_goal.m:
Start a severity warning diagnostic with "Warning:"
instead of "Error:".
compiler/mark_trace_goals.m:
Fix an incorrect error message.
compiler/purity.m:
Replace a correct/incorrect color pair with two inconsistent colors,
because there is a reasonable probability of each one being right.
---------------------
compiler/accumulator.m:
compiler/add_clause.m:
compiler/add_mode.m:
compiler/add_pragma.m:
compiler/add_pragma_tabling.m:
compiler/add_pred.m:
compiler/add_type.m:
compiler/check_module_interface.m:
compiler/check_type_inst_mode_defns.m:
compiler/check_typeclass.m:
compiler/color_schemes.m:
compiler/common.m:
compiler/convert_import_use.m:
compiler/convert_parse_tree.m:
compiler/dead_proc_elim.m:
compiler/det_check_proc.m:
compiler/det_check_switch.m:
compiler/det_infer_goal.m:
compiler/du_type_layout.m:
compiler/format_call_errors.m:
compiler/grab_modules.m:
compiler/hlds_call_tree.m:
compiler/inst_check.m:
compiler/introduce_parallelism.m:
compiler/make_hlds_error.m:
compiler/make_hlds_warn.m:
compiler/mark_tail_calls.m:
compiler/mark_trace_goals.m:
compiler/mercury_compile_main.m:
compiler/mercury_compile_make_hlds.m:
compiler/mode_errors.m:
compiler/modes.m:
compiler/module_qual.qual_errors.m:
compiler/opt_deps_spec.m:
compiler/options_file.m:
compiler/parse_goal.m:
compiler/post_term_analysis.m:
compiler/post_typecheck.m:
compiler/pre_typecheck.m:
compiler/purity.m:
compiler/read_modules.m:
compiler/recompilation.check.m:
compiler/simplify_goal.m:
compiler/simplify_goal_call.m:
compiler/simplify_goal_disj.m:
compiler/simplify_goal_ite.m:
compiler/split_parse_tree_src.m:
compiler/state_var.m:
compiler/stratify.m:
compiler/style_checks.m:
compiler/superhomogeneous.m:
compiler/table_gen.m:
compiler/term_constr_errors.m:
compiler/term_errors.m:
compiler/termination.m:
compiler/typecheck_clauses.m:
compiler/typecheck_error_overload.m:
compiler/typecheck_error_undef.m:
compiler/typecheck_errors.m:
compiler/typecheck_msgs.m:
compiler/unused_args.m:
compiler/unused_imports.m:
compiler/warn_unread_modules.m:
compiler/write_module_interface_files.m:
Conform to the changes above, mostly by either
- adding an option to all warning and informational messages,
sometimes using existing warning options and sometimes new ones,
or
- turning already explicitly-conditional-on-an-option messages
into implicitly-conditional-on-that-option messages.
---------------------
tests/invalid/one_member.m:
Conform to the change in det_infer_goal.m.
tests/invalid/require_tailrec_1.err_exp:
tests/invalid/require_tailrec_2.err_exp:
Actually obey the options for these modules in Mercury.options.
tests/invalid_purity/purity.err_exp:
tests/warnings/purity_warnings.err_exp:
Conform to the change in purity.m.
tests/warnings/moved_trace_goal.err_exp:
Conform to the change in mark_trace_goals.m.
tests/warnings/help_text.err_exp:
Expect the documentation of all the new options.
1045 lines
41 KiB
Mathematica
1045 lines
41 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1996-2012 The University of Melbourne.
|
|
% Copyright (C) 2017, 2025 The Mercury Team.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: stratify.m.
|
|
% Main authors: ohutch, conway.
|
|
%
|
|
% This module performs stratification analysis.
|
|
% It works by processing the call graph one scc at a time.
|
|
% It traverses the goal for each procedure in the scc and reports an error
|
|
% or warning (depending on the context) for any negated call to another member
|
|
% of the scc. It will also emit a message if it encounters a higher order call,
|
|
% or a call to an outside module.
|
|
%
|
|
% It has a second pass which is not currently enabled.
|
|
%
|
|
% The second pass looks for possible non stratified code by looking at
|
|
% higher order calls. This second pass works by rebuilding the call
|
|
% graph with any possible arcs that can arise though higher order calls,
|
|
% and then traversing the new sccs looking for negative loops.
|
|
%
|
|
% The second pass is necessary because the rebuilt call graph does not
|
|
% allow the detection of definite non-stratification.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds.stratify.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_spec.
|
|
|
|
:- import_module list.
|
|
|
|
% Perform stratification analysis for the given module. If the
|
|
% "warn-non-stratification" option is set, this predicate will check
|
|
% the entire module for stratification, otherwise it will only check
|
|
% the predicates in the stratified_preds set of the module_info structure.
|
|
%
|
|
:- pred check_module_for_stratification(module_info::in, module_info::out,
|
|
list(error_spec)::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.mode_test.
|
|
:- import_module hlds.hlds_dependency_graph.
|
|
:- import_module hlds.hlds_error_util.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module libs.
|
|
:- import_module libs.dependency_graph.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.parse_tree_out_info.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_type_test.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module bool.
|
|
:- import_module digraph.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module string.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
check_module_for_stratification(!ModuleInfo, Specs) :-
|
|
module_info_ensure_dependency_info(!ModuleInfo, DepInfo),
|
|
FOSCCs = dependency_info_get_bottom_up_sccs(DepInfo),
|
|
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals, warn_non_stratification, Warn),
|
|
module_info_get_must_be_stratified_preds(!.ModuleInfo,
|
|
MustBeStratifiedPreds),
|
|
first_order_check_sccs(FOSCCs, MustBeStratifiedPreds, Warn, !.ModuleInfo,
|
|
[], Specs).
|
|
|
|
% The following code was used for the second pass of this module but
|
|
% as that pass is disabled, so is this code. The higher order code
|
|
% is disabled because it is currently unable to detect cases where a
|
|
% higher order proc is hidden in some complex data structure.
|
|
%
|
|
% gen_conservative_graph(!.ModuleInfo, DepGraph0, DepGraph, HOInfo),
|
|
% digraph.return_sccs_in_from_to_order(DepGraph, HOSCCs1),
|
|
% dep_sets_to_lists_and_sets(HOSCCs1, [], HOSCCs),
|
|
% higher_order_check_sccs(HOSCCs, HOInfo, ModuleInfo, !Specs).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred stratify_get_pred_id(pred_proc_id::in, pred_id::out) is det.
|
|
|
|
stratify_get_pred_id(proc(PredId, _), PredId).
|
|
|
|
% Check the first order SCCs for stratification.
|
|
%
|
|
:- pred first_order_check_sccs(list(set(pred_proc_id))::in,
|
|
set(pred_id)::in, bool::in, module_info::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
first_order_check_sccs([], _, _, _, !Specs).
|
|
first_order_check_sccs([HeadSCC | TailSCCs], MustBeStratifiedPreds, Warn,
|
|
ModuleInfo, !Specs) :-
|
|
set.map(stratify_get_pred_id, HeadSCC, HeadSCCPreds),
|
|
set.intersect(HeadSCCPreds, MustBeStratifiedPreds,
|
|
MustBeStratifiedPredsInScc),
|
|
( if
|
|
( Warn = yes
|
|
; set.is_non_empty(MustBeStratifiedPredsInScc)
|
|
)
|
|
then
|
|
first_order_check_scc(HeadSCC, is_warning(warn_non_stratification),
|
|
ModuleInfo, !Specs)
|
|
else
|
|
true
|
|
),
|
|
first_order_check_sccs(TailSCCs, MustBeStratifiedPreds, Warn,
|
|
ModuleInfo, !Specs).
|
|
|
|
:- pred first_order_check_scc(set(pred_proc_id)::in, error_or_warning::in,
|
|
module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
first_order_check_scc(Scc, ErrorOrWarning, ModuleInfo, !Specs) :-
|
|
first_order_check_scc_loop(set.to_sorted_list(Scc), Scc,
|
|
ErrorOrWarning, ModuleInfo, !Specs).
|
|
|
|
:- pred first_order_check_scc_loop(list(pred_proc_id)::in,
|
|
set(pred_proc_id)::in, error_or_warning::in, module_info::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
first_order_check_scc_loop([], _WholeScc, _, _, !Specs).
|
|
first_order_check_scc_loop([PredProcId | PredProcIds], WholeScc,
|
|
ErrorOrWarning, ModuleInfo, !Specs) :-
|
|
PredProcId = proc(PredId, ProcId),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_proc_table(PredInfo, ProcTable),
|
|
map.lookup(ProcTable, ProcId, Proc),
|
|
proc_info_get_goal(Proc, Goal),
|
|
first_order_check_goal(Goal, no, WholeScc,
|
|
PredProcId, ErrorOrWarning, ModuleInfo, !Specs),
|
|
first_order_check_scc_loop(PredProcIds, WholeScc, ErrorOrWarning,
|
|
ModuleInfo, !Specs).
|
|
|
|
:- pred first_order_check_goal(hlds_goal::in, bool::in, set(pred_proc_id)::in,
|
|
pred_proc_id::in, error_or_warning::in, module_info::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
first_order_check_goal(Goal, Negated, WholeScc, ThisPredProcId, ErrorOrWarning,
|
|
ModuleInfo, !Specs) :-
|
|
Goal = hlds_goal(GoalExpr, GoalInfo),
|
|
(
|
|
( GoalExpr = conj(_ConjType, Goals)
|
|
; GoalExpr = disj(Goals)
|
|
),
|
|
first_order_check_goals(Goals, Negated, WholeScc, ThisPredProcId,
|
|
ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = switch(_Var, _Fail, Cases),
|
|
first_order_check_cases(Cases, Negated, WholeScc, ThisPredProcId,
|
|
ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = if_then_else(_Vars, Cond, Then, Else),
|
|
first_order_check_goal(Cond, yes, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs),
|
|
first_order_check_goal(Then, Negated, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs),
|
|
first_order_check_goal(Else, Negated, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = negation(SubGoal),
|
|
first_order_check_goal(SubGoal, yes, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = scope(Reason, SubGoal),
|
|
( if
|
|
Reason = from_ground_term(_, FGT),
|
|
( FGT = from_ground_term_construct
|
|
; FGT = from_ground_term_deconstruct
|
|
)
|
|
then
|
|
% These scopes cannot contain any calls.
|
|
true
|
|
else
|
|
first_order_check_goal(SubGoal, Negated, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs)
|
|
)
|
|
;
|
|
( GoalExpr = plain_call(CPred, CProc, _Args, _BuiltinState, _UC, _Sym)
|
|
; GoalExpr = call_foreign_proc(_Attributes, CPred, CProc, _, _, _, _)
|
|
),
|
|
Callee = proc(CPred, CProc),
|
|
( if
|
|
Negated = yes,
|
|
set.member(Callee, WholeScc)
|
|
then
|
|
Context = goal_info_get_context(GoalInfo),
|
|
ErrorMsg = "call introduces a non-stratified loop.",
|
|
Spec = generate_stratify_error(ModuleInfo, ThisPredProcId, Context,
|
|
ErrorMsg, ErrorOrWarning),
|
|
!:Specs = [Spec | !.Specs]
|
|
else
|
|
true
|
|
)
|
|
;
|
|
GoalExpr = generic_call(_Var, _Args, _Modes, _MaybeArgRegs, _Det)
|
|
% Do nothing.
|
|
;
|
|
GoalExpr = unify(_LHS, _RHS, _Mode, _Unification, _UnifyContext)
|
|
% Do nothing.
|
|
;
|
|
GoalExpr = shorthand(ShortHand),
|
|
(
|
|
ShortHand = atomic_goal(_, _, _, _, MainGoal, OrElseGoals, _),
|
|
first_order_check_goal(MainGoal, Negated, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs),
|
|
first_order_check_goals(OrElseGoals, Negated, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
ShortHand = try_goal(_, _, SubGoal),
|
|
first_order_check_goal(SubGoal, Negated, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
ShortHand = bi_implication(_, _),
|
|
% These should have been expanded out by now.
|
|
unexpected($pred, "bi_implication")
|
|
)
|
|
).
|
|
|
|
:- pred first_order_check_goals(list(hlds_goal)::in, bool::in,
|
|
set(pred_proc_id)::in, pred_proc_id::in, error_or_warning::in,
|
|
module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
first_order_check_goals([], _, _, _, _, _, !Specs).
|
|
first_order_check_goals([Goal | Goals], Negated,
|
|
WholeScc, ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs) :-
|
|
first_order_check_goal(Goal, Negated, WholeScc, ThisPredProcId,
|
|
ErrorOrWarning, ModuleInfo, !Specs),
|
|
first_order_check_goals(Goals, Negated, WholeScc, ThisPredProcId,
|
|
ErrorOrWarning, ModuleInfo, !Specs).
|
|
|
|
:- pred first_order_check_cases(list(case)::in, bool::in,
|
|
set(pred_proc_id)::in, pred_proc_id::in, error_or_warning::in,
|
|
module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
first_order_check_cases([], _, _, _, _, _, !Specs).
|
|
first_order_check_cases([Case | Goals], Negated, WholeScc, ThisPredProcId,
|
|
ErrorOrWarning, ModuleInfo, !Specs) :-
|
|
Case = case(_, _, Goal),
|
|
first_order_check_goal(Goal, Negated, WholeScc,
|
|
ThisPredProcId, ErrorOrWarning, ModuleInfo, !Specs),
|
|
first_order_check_cases(Goals, Negated, WholeScc, ThisPredProcId,
|
|
ErrorOrWarning, ModuleInfo, !Specs).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% XXX Currently we don't allow the higher order case so this code is disabled.
|
|
|
|
% Check the higher order SCCs for stratification.
|
|
%
|
|
:- pred higher_order_check_sccs(
|
|
assoc_list(list(pred_proc_id), set(pred_proc_id))::in, ho_map::in,
|
|
module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
:- pragma consider_used(pred(higher_order_check_sccs/5)).
|
|
|
|
higher_order_check_sccs([], _HOInfo, _ModuleInfo, !Specs).
|
|
higher_order_check_sccs([HeadSCC | TailSCCs], HOInfo, ModuleInfo, !Specs) :-
|
|
HeadSCC = HeadSCCProcs - HeadSCCPreds,
|
|
higher_order_check_scc(HeadSCCProcs, HeadSCCPreds, HOInfo, ModuleInfo,
|
|
!Specs),
|
|
higher_order_check_sccs(TailSCCs, HOInfo, ModuleInfo, !Specs).
|
|
|
|
:- pred higher_order_check_scc(list(pred_proc_id)::in, set(pred_proc_id)::in,
|
|
ho_map::in, module_info::in, list(error_spec)::in, list(error_spec)::out)
|
|
is det.
|
|
|
|
higher_order_check_scc([], _WholeScc, _HOInfo, _ModuleInfo, !Specs).
|
|
higher_order_check_scc([PredProcId | Remaining], WholeScc, HOInfo,
|
|
ModuleInfo, !Specs) :-
|
|
PredProcId = proc(PredId, ProcId),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals, warn_non_stratification, Warn),
|
|
( if
|
|
Warn = yes,
|
|
map.search(HOInfo, PredProcId, HigherOrderInfo)
|
|
then
|
|
HigherOrderInfo = strat_ho_info(HOCalls, _),
|
|
set.intersect(HOCalls, WholeScc, HOLoops),
|
|
( if set.is_empty(HOLoops) then
|
|
HighOrderLoops = no
|
|
else
|
|
HighOrderLoops = yes
|
|
),
|
|
pred_info_get_proc_table(PredInfo, ProcTable),
|
|
map.lookup(ProcTable, ProcId, Proc),
|
|
proc_info_get_goal(Proc, Goal),
|
|
ErrorOrWarning = is_warning(warn_non_stratification),
|
|
higher_order_check_goal(Goal, no, WholeScc, PredProcId, HighOrderLoops,
|
|
ErrorOrWarning, ModuleInfo, !Specs)
|
|
else
|
|
true
|
|
),
|
|
higher_order_check_scc(Remaining, WholeScc, HOInfo, ModuleInfo, !Specs).
|
|
|
|
:- pred higher_order_check_goal(hlds_goal::in, bool::in, set(pred_proc_id)::in,
|
|
pred_proc_id::in, bool::in, error_or_warning::in,
|
|
module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
higher_order_check_goal(Goal, Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs) :-
|
|
Goal = hlds_goal(GoalExpr, GoalInfo),
|
|
(
|
|
( GoalExpr = conj(_ConjType, Goals)
|
|
; GoalExpr = disj(Goals)
|
|
),
|
|
higher_order_check_goals(Goals, Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = switch(_Var, _Fail, Cases),
|
|
higher_order_check_cases(Cases, Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = if_then_else(_Vars, Cond, Then, Else),
|
|
higher_order_check_goal(Cond, yes, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs),
|
|
higher_order_check_goal(Then, Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs),
|
|
higher_order_check_goal(Else, Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = negation(SubGoal),
|
|
higher_order_check_goal(SubGoal, yes, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs)
|
|
;
|
|
GoalExpr = scope(Reason, SubGoal),
|
|
( if
|
|
Reason = from_ground_term(_, FGT),
|
|
( FGT = from_ground_term_construct
|
|
; FGT = from_ground_term_deconstruct
|
|
)
|
|
then
|
|
% These scopes cannot contain any calls.
|
|
true
|
|
else
|
|
higher_order_check_goal(SubGoal, Negated, WholeScc,
|
|
ThisPredProcId, HighOrderLoops, ErrorOrWarning,
|
|
ModuleInfo, !Specs)
|
|
)
|
|
;
|
|
GoalExpr = plain_call(_CPred, _CProc, _Args, _Builtin, _UC, SymName),
|
|
( if
|
|
% XXX Is this good enough to detect all calls to solutions ?
|
|
HighOrderLoops = yes,
|
|
unqualify_name(SymName) = "solutions"
|
|
then
|
|
Context = goal_info_get_context(GoalInfo),
|
|
ErrorMsg = "call to solutions/2 introduces a non-stratified loop.",
|
|
Spec = generate_stratify_error(ModuleInfo, ThisPredProcId, Context,
|
|
ErrorMsg, ErrorOrWarning),
|
|
!:Specs = [Spec | !.Specs]
|
|
else
|
|
true
|
|
)
|
|
;
|
|
GoalExpr = generic_call(GenericCall, _Vars, _Modes, _MaybeArgRegs,
|
|
_Det),
|
|
( if
|
|
Negated = yes,
|
|
HighOrderLoops = yes,
|
|
( GenericCall = higher_order(_, _, _, _, _), Msg = "higher order"
|
|
; GenericCall = class_method(_, _, _, _), Msg = "class method"
|
|
)
|
|
then
|
|
Context = goal_info_get_context(GoalInfo),
|
|
ErrorMsg = Msg ++ " call may introduce a non-stratified loop.",
|
|
Spec = generate_stratify_error(ModuleInfo, ThisPredProcId, Context,
|
|
ErrorMsg, ErrorOrWarning),
|
|
!:Specs = [Spec | !.Specs]
|
|
else
|
|
true
|
|
)
|
|
;
|
|
GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
|
|
% Do nothing.
|
|
;
|
|
GoalExpr = unify(_LHS, _RHS, _Mode, _Unification, _UnifyContext)
|
|
% Do nothing.
|
|
;
|
|
GoalExpr = shorthand(ShortHand),
|
|
(
|
|
ShortHand = atomic_goal(_, _, _, _, MainGoal, OrElseGoals, _),
|
|
higher_order_check_goal(MainGoal, Negated, WholeScc,
|
|
ThisPredProcId, HighOrderLoops, ErrorOrWarning,
|
|
ModuleInfo, !Specs),
|
|
higher_order_check_goals(OrElseGoals, Negated, WholeScc,
|
|
ThisPredProcId, HighOrderLoops, ErrorOrWarning,
|
|
ModuleInfo, !Specs)
|
|
;
|
|
ShortHand = try_goal(_, _, SubGoal),
|
|
higher_order_check_goal(SubGoal, Negated, WholeScc,
|
|
ThisPredProcId, HighOrderLoops, ErrorOrWarning,
|
|
ModuleInfo, !Specs)
|
|
;
|
|
ShortHand = bi_implication(_, _),
|
|
% These should have been expanded out by now.
|
|
unexpected($pred, "bi_implication")
|
|
)
|
|
).
|
|
|
|
:- pred higher_order_check_goals(list(hlds_goal)::in, bool::in,
|
|
set(pred_proc_id)::in, pred_proc_id::in, bool::in, error_or_warning::in,
|
|
module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
higher_order_check_goals([], _, _, _, _, _, _, !Specs).
|
|
higher_order_check_goals([Goal | Goals], Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs) :-
|
|
higher_order_check_goal(Goal, Negated, WholeScc,
|
|
ThisPredProcId, HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs),
|
|
higher_order_check_goals(Goals, Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs).
|
|
|
|
:- pred higher_order_check_cases(list(case)::in, bool::in,
|
|
set(pred_proc_id)::in, pred_proc_id::in, bool::in, error_or_warning::in,
|
|
module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
higher_order_check_cases([], _, _, _, _, _, _, !Specs).
|
|
higher_order_check_cases([Case | Goals], Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs) :-
|
|
Case = case(_, _, Goal),
|
|
higher_order_check_goal(Goal, Negated, WholeScc,
|
|
ThisPredProcId, HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs),
|
|
higher_order_check_cases(Goals, Negated, WholeScc, ThisPredProcId,
|
|
HighOrderLoops, ErrorOrWarning, ModuleInfo, !Specs).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Direction higher order params can flow in a procedure.
|
|
:- type ho_in_out
|
|
---> ho_in
|
|
; ho_out
|
|
; ho_in_out
|
|
; ho_none.
|
|
|
|
% This structure is used to hold the higher order characteristics of a
|
|
% procedure.
|
|
:- type strat_ho_info
|
|
---> strat_ho_info(
|
|
% Possible higher order addresses that can reach the procedure.
|
|
set(pred_proc_id),
|
|
|
|
% Possible paths the address can take in and out
|
|
% of the procedure.
|
|
ho_in_out
|
|
).
|
|
|
|
% A map from all non imported procedures to there higher order info.
|
|
:- type ho_map == map(pred_proc_id, strat_ho_info).
|
|
|
|
% A map from all non imported procs to all the procedures they can call.
|
|
:- type call_map == map(pred_proc_id, set(pred_proc_id)).
|
|
|
|
% Given a module and a dependency graph, this predicate builds
|
|
% a new dependency graph with all possible higher order calls added.
|
|
% It also returns a map of all the higher order info it collects.
|
|
%
|
|
:- pred gen_conservative_graph(module_info::in,
|
|
hlds_dependency_graph::in, hlds_dependency_graph::out, ho_map::out) is det.
|
|
:- pragma consider_used(pred(gen_conservative_graph/4)).
|
|
|
|
gen_conservative_graph(ModuleInfo, !DepGraph, HOInfo) :-
|
|
stratify_get_call_info(ModuleInfo, ProcCalls, HOInfo0, CallsHO),
|
|
map.keys(ProcCalls, Callers),
|
|
iterate_solution(Callers, ProcCalls, CallsHO, HOInfo0, HOInfo),
|
|
map.to_assoc_list(HOInfo, HOInfoL),
|
|
add_new_arcs(HOInfoL, CallsHO, !DepGraph).
|
|
|
|
% For a given module, collects for each non imported procedure
|
|
% a set of called procedures and a higher order info structure.
|
|
% This pred also returns a set of all non imported procedures that
|
|
% make a higher order call.
|
|
%
|
|
:- pred stratify_get_call_info(module_info::in, call_map::out,
|
|
ho_map::out, set(pred_proc_id)::out) is det.
|
|
|
|
stratify_get_call_info(ModuleInfo, !:ProcCalls, !:HOInfo, !:CallsHO) :-
|
|
map.init(!:ProcCalls),
|
|
map.init(!:HOInfo),
|
|
set.init(!:CallsHO),
|
|
module_info_get_valid_pred_ids(ModuleInfo, PredIds),
|
|
expand_predids(PredIds, ModuleInfo, !ProcCalls, !HOInfo, !CallsHO).
|
|
|
|
% Finds the transitive closure of a given list of procedures.
|
|
% This pred is used to see how face(???) a higher order address
|
|
% can reach though procedure calls.
|
|
%
|
|
:- pred iterate_solution(list(pred_proc_id)::in, call_map::in,
|
|
set(pred_proc_id)::in, ho_map::in, ho_map::out) is det.
|
|
|
|
iterate_solution(PredProcs, ProcCalls, CallsHO, !HOInfo) :-
|
|
stratify_tc(PredProcs, ProcCalls, CallsHO, !HOInfo, no, Changed),
|
|
(
|
|
Changed = no
|
|
;
|
|
Changed = yes,
|
|
disable_warning [suspicious_recursion] (
|
|
iterate_solution(PredProcs, ProcCalls, CallsHO, !HOInfo)
|
|
)
|
|
).
|
|
|
|
% For each caller, merge any higher order addresses it takes with all of
|
|
% its callees, and return if any change has occurred.
|
|
%
|
|
:- pred stratify_tc(list(pred_proc_id)::in, call_map::in,
|
|
set(pred_proc_id)::in, ho_map::in, ho_map::out, bool::in, bool::out)
|
|
is det.
|
|
|
|
stratify_tc([], _, _, !HOInfo, !Changed).
|
|
stratify_tc([PredProcId | PredProcIds], ProcCalls, CallsHO, !HOInfo,
|
|
!Changed) :-
|
|
map.lookup(ProcCalls, PredProcId, PCalls),
|
|
set.to_sorted_list(PCalls, PCallsL),
|
|
merge_calls(PCallsL, PredProcId, CallsHO, yes, !HOInfo, !Changed),
|
|
stratify_tc(PredProcIds, ProcCalls, CallsHO, !HOInfo, !Changed).
|
|
|
|
% Merge any higher order addresses that can pass between the given caller
|
|
% and callees. This code also merges any possible addresses that can pass
|
|
% in and out of higher order calls.
|
|
%
|
|
:- pred merge_calls(list(pred_proc_id)::in, pred_proc_id::in,
|
|
set(pred_proc_id)::in, bool::in, ho_map::in, ho_map::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
merge_calls([], _, _, _, !HOInfo, !Changed).
|
|
merge_calls([C | Cs], P, CallsHO, DoingFirstOrder, !HOInfo, !Changed) :-
|
|
( if map.search(!.HOInfo, C, CInfo) then
|
|
map.lookup(!.HOInfo, P, PInfo),
|
|
CInfo = strat_ho_info(CHaveAT0, CHOInOut),
|
|
PInfo = strat_ho_info(PHaveAT0, PHOInOut),
|
|
% First merge the first order info, if we need to.
|
|
( if CHOInOut = ho_none then
|
|
true
|
|
else
|
|
(
|
|
CHOInOut = ho_in,
|
|
( if set.subset(PHaveAT0, CHaveAT0) then
|
|
CHaveAT = CHaveAT0
|
|
else
|
|
set.union(PHaveAT0, CHaveAT0, CHaveAT),
|
|
!:Changed = yes
|
|
),
|
|
PHaveAT = PHaveAT0
|
|
;
|
|
CHOInOut = ho_out,
|
|
( if set.subset(CHaveAT0, PHaveAT0) then
|
|
PHaveAT = PHaveAT0
|
|
else
|
|
set.union(CHaveAT0, PHaveAT0, PHaveAT),
|
|
!:Changed = yes
|
|
),
|
|
CHaveAT = CHaveAT0
|
|
;
|
|
CHOInOut = ho_in_out,
|
|
( if CHaveAT0 = PHaveAT0 then
|
|
CHaveAT = CHaveAT0,
|
|
PHaveAT = PHaveAT0
|
|
else
|
|
set.union(CHaveAT0, PHaveAT0, NewHaveAT),
|
|
CHaveAT = NewHaveAT,
|
|
PHaveAT = NewHaveAT,
|
|
!:Changed = yes
|
|
)
|
|
;
|
|
CHOInOut = ho_none,
|
|
% XXX What is a good message for this?
|
|
unexpected($pred, "ho_none")
|
|
),
|
|
NewCInfo = strat_ho_info(CHaveAT, CHOInOut),
|
|
NewPInfo = strat_ho_info(PHaveAT, PHOInOut),
|
|
map.det_update(C, NewCInfo, !HOInfo),
|
|
map.det_update(P, NewPInfo, !HOInfo)
|
|
),
|
|
% Then, if we need to, merge the higher order info.
|
|
( if
|
|
DoingFirstOrder = yes,
|
|
set.member(P, CallsHO)
|
|
then
|
|
map.lookup(!.HOInfo, P, PHOInfo),
|
|
PHOInfo = strat_ho_info(PossibleCalls, _),
|
|
set.to_sorted_list(PossibleCalls, PossibleCallsL),
|
|
merge_calls(PossibleCallsL, P, CallsHO, no, !HOInfo, !Changed)
|
|
else
|
|
true
|
|
)
|
|
else
|
|
true
|
|
),
|
|
merge_calls(Cs, P, CallsHO, DoingFirstOrder, !HOInfo, !Changed).
|
|
|
|
% Given the set of procedures that make higher order calls and a
|
|
% list of procedures and higher order call info, this predicate rebuilds
|
|
% the given call graph with new arcs for every possible higher order call.
|
|
%
|
|
:- pred add_new_arcs(assoc_list(pred_proc_id, strat_ho_info)::in,
|
|
set(pred_proc_id)::in,
|
|
hlds_dependency_graph::in, hlds_dependency_graph::out) is det.
|
|
|
|
add_new_arcs([], _, !DepGraph).
|
|
add_new_arcs([Caller - CallerInfo | Cs], CallsHO, !DepGraph) :-
|
|
% Only add arcs for callers who call higher order procs.
|
|
( if set.member(Caller, CallsHO) then
|
|
CallerInfo = strat_ho_info(PossibleCallees0, _),
|
|
set.to_sorted_list(PossibleCallees0, PossibleCallees),
|
|
digraph.lookup_key(!.DepGraph, Caller, CallerKey),
|
|
add_new_arcs2(PossibleCallees, CallerKey, !DepGraph)
|
|
else
|
|
true
|
|
),
|
|
add_new_arcs(Cs, CallsHO, !DepGraph).
|
|
|
|
:- pred add_new_arcs2(list(pred_proc_id)::in, hlds_dependency_graph_key::in,
|
|
hlds_dependency_graph::in, hlds_dependency_graph::out) is det.
|
|
|
|
add_new_arcs2([], _, !DepGraph).
|
|
add_new_arcs2([Callee | Cs], CallerKey, !DepGraph) :-
|
|
digraph.lookup_key(!.DepGraph, Callee, CalleeKey),
|
|
digraph.add_edge(CallerKey, CalleeKey, !DepGraph),
|
|
add_new_arcs2(Cs, CallerKey, !DepGraph).
|
|
|
|
% For each given pred id, pass all non imported procs onto the
|
|
% stratify_process_procs predicate.
|
|
%
|
|
:- pred expand_predids(list(pred_id)::in, module_info::in,
|
|
call_map::in, call_map::out, ho_map::in, ho_map::out,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out) is det.
|
|
|
|
expand_predids([], _, !ProcCalls, !HOInfo, !CallsHO).
|
|
expand_predids([PredId | PredIds], ModuleInfo, !ProcCalls, !HOInfo,
|
|
!CallsHO) :-
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
Procs = pred_info_all_non_imported_procids(PredInfo),
|
|
pred_info_get_proc_table(PredInfo, ProcTable),
|
|
pred_info_get_arg_types(PredInfo, ArgTypes),
|
|
stratify_process_procs(Procs, ModuleInfo, PredId, ArgTypes, ProcTable,
|
|
!ProcCalls, !HOInfo, !CallsHO),
|
|
expand_predids(PredIds, ModuleInfo, !ProcCalls, !HOInfo, !CallsHO).
|
|
|
|
% For each given proc id, generate the set of procedures it calls
|
|
% and its higher order info structure.
|
|
%
|
|
:- pred stratify_process_procs(list(proc_id)::in, module_info::in, pred_id::in,
|
|
list(mer_type)::in, proc_table::in, call_map::in, call_map::out,
|
|
ho_map::in, ho_map::out, set(pred_proc_id)::in, set(pred_proc_id)::out)
|
|
is det.
|
|
|
|
stratify_process_procs([], _, _, _, _, !ProcCalls, !HOInfo, !CallsHO).
|
|
stratify_process_procs([ProcId | ProcIds], ModuleInfo, PredId, ArgTypes,
|
|
ProcTable, !ProcCalls, !HOInfo, !CallsHO) :-
|
|
stratify_process_proc(ProcId, ModuleInfo, PredId, ArgTypes, ProcTable,
|
|
!ProcCalls, !HOInfo, !CallsHO),
|
|
stratify_process_procs(ProcIds, ModuleInfo, PredId, ArgTypes, ProcTable,
|
|
!ProcCalls, !HOInfo, !CallsHO).
|
|
|
|
:- pred stratify_process_proc(proc_id::in, module_info::in, pred_id::in,
|
|
list(mer_type)::in, proc_table::in, call_map::in, call_map::out,
|
|
ho_map::in, ho_map::out, set(pred_proc_id)::in, set(pred_proc_id)::out)
|
|
is det.
|
|
|
|
stratify_process_proc(ProcId, ModuleInfo, PredId, ArgTypes, ProcTable,
|
|
!ProcCalls, !HOInfo, !CallsHO) :-
|
|
map.lookup(ProcTable, ProcId, ProcInfo),
|
|
proc_info_get_argmodes(ProcInfo, ArgModes),
|
|
proc_info_get_goal(ProcInfo, Goal),
|
|
PredProcId = proc(PredId, ProcId),
|
|
stratify_analyze_proc_body(Goal, Calls, HaveAT, CallsHigherOrder),
|
|
map.det_insert(PredProcId, Calls, !ProcCalls),
|
|
higherorder_in_out(ArgTypes, ArgModes, ModuleInfo, HOInOut),
|
|
map.det_insert(PredProcId, strat_ho_info(HaveAT, HOInOut), !HOInfo),
|
|
(
|
|
CallsHigherOrder = calls_higher_order,
|
|
set.insert(PredProcId, !CallsHO)
|
|
;
|
|
CallsHigherOrder = does_not_calls_higher_order
|
|
).
|
|
|
|
% Determine if a given set of modes and types indicates that
|
|
% higher order values can be passed into and/or out of a procedure.
|
|
%
|
|
:- pred higherorder_in_out(list(mer_type)::in, list(mer_mode)::in,
|
|
module_info::in, ho_in_out::out) is det.
|
|
|
|
higherorder_in_out(Types, Modes, ModuleInfo, HOInOut) :-
|
|
higherorder_in_out1(Types, Modes, ModuleInfo, no, HOIn, no, HOOut),
|
|
bool_2_ho_in_out(HOIn, HOOut, HOInOut).
|
|
|
|
:- pred bool_2_ho_in_out(bool::in, bool::in, ho_in_out::out) is det.
|
|
|
|
bool_2_ho_in_out(yes, no, ho_in).
|
|
bool_2_ho_in_out(no, yes, ho_out).
|
|
bool_2_ho_in_out(yes, yes, ho_in_out).
|
|
bool_2_ho_in_out(no, no, ho_none).
|
|
|
|
:- pred higherorder_in_out1(list(mer_type)::in, list(mer_mode)::in,
|
|
module_info::in, bool::in, bool::out, bool::in, bool::out) is det.
|
|
|
|
higherorder_in_out1([], [], _ModuleInfo, !HOIn, !HOOut).
|
|
higherorder_in_out1([], [_ | _], _, !HOIn, !HOOut) :-
|
|
unexpected($pred, "mismatched lists").
|
|
higherorder_in_out1([_ | _], [], _, !HOIn, !HOOut) :-
|
|
unexpected($pred, "mismatched lists").
|
|
higherorder_in_out1([Type | Types], [Mode | Modes], ModuleInfo,
|
|
!HOIn, !HOOut) :-
|
|
( if
|
|
% XXX We should use a more general check for higher order constants
|
|
% in parameters; users could hide higher order constants in data
|
|
% structures.
|
|
type_is_higher_order(Type)
|
|
then
|
|
( if mode_is_input(ModuleInfo, Mode) then
|
|
!:HOIn = yes
|
|
else if mode_is_output(ModuleInfo, Mode) then
|
|
!:HOOut = yes
|
|
else
|
|
true
|
|
)
|
|
else
|
|
true
|
|
),
|
|
higherorder_in_out1(Types, Modes, ModuleInfo, !HOIn, !HOOut).
|
|
|
|
:- type calls_higher_order
|
|
---> does_not_calls_higher_order
|
|
; calls_higher_order.
|
|
|
|
% Return the set of all procedures called in the given goal
|
|
% and all addresses taken in the given goal.
|
|
%
|
|
:- pred stratify_analyze_proc_body(hlds_goal::in, set(pred_proc_id)::out,
|
|
set(pred_proc_id)::out, calls_higher_order::out) is det.
|
|
|
|
stratify_analyze_proc_body(Goal, Calls, TakenAddrs, CallsHO) :-
|
|
set.init(Calls0),
|
|
set.init(TakenAddrs0),
|
|
stratify_analyze_goal(Goal, Calls0, Calls, TakenAddrs0, TakenAddrs,
|
|
does_not_calls_higher_order, CallsHO).
|
|
|
|
:- pred stratify_analyze_goal(hlds_goal::in,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out,
|
|
calls_higher_order::in, calls_higher_order::out) is det.
|
|
|
|
stratify_analyze_goal(Goal, !Calls, !HasAT, !CallsHO) :-
|
|
Goal = hlds_goal(GoalExpr, _GoalInfo),
|
|
(
|
|
GoalExpr = unify(_Var, RHS, _Mode, Unification, _Context),
|
|
% See if a goal has its address taken.
|
|
(
|
|
% Currently this code assumes that all procs called in a lambda
|
|
% goal have addresses taken. This is not always to case, but
|
|
% should be a suitable approximation for the stratification
|
|
% analysis.
|
|
RHS = rhs_lambda_goal(_Purity, _Groundness, _PredOrFunc,
|
|
_NonLocals, _ArgVarsModes, _Determinism, LambdaGoal),
|
|
stratify_get_called_procs(LambdaGoal, [], CalledProcs),
|
|
set.insert_list(CalledProcs, !HasAT)
|
|
;
|
|
RHS = rhs_var(_)
|
|
;
|
|
RHS = rhs_functor(_, _, _)
|
|
),
|
|
(
|
|
% Currently when this pass is run the construct/4 case will not
|
|
% happen as higher order constants have been transformed to
|
|
% lambda goals. See above.
|
|
Unification = construct(_, ConsId, _, _, _, _, _),
|
|
( if ConsId = closure_cons(ShroudedPredProcId) then
|
|
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
set.insert(PredProcId, !HasAT)
|
|
else
|
|
% Do nothing.
|
|
true
|
|
)
|
|
;
|
|
( Unification = deconstruct(_, _, _, _, _, _)
|
|
; Unification = assign(_, _)
|
|
; Unification = simple_test(_, _)
|
|
)
|
|
% Do nothing.
|
|
;
|
|
Unification = complicated_unify(_, _, _),
|
|
unexpected($pred, "complicated_unify")
|
|
)
|
|
;
|
|
GoalExpr = plain_call(CPred, CProc, _Args, _Builtin, _UC, _Sym),
|
|
% Add this call to the call list.
|
|
set.insert(proc(CPred, CProc), !Calls)
|
|
;
|
|
GoalExpr = call_foreign_proc(_Attrib, _CPred, _CProc, _, _, _, _)
|
|
% Do nothing.
|
|
% XXX If the foreign proc may_call_mercury, then we may be missing
|
|
% some calls.
|
|
;
|
|
GoalExpr = generic_call(_Var, _Vars, _Modes, _MaybeArgRegs, _Det),
|
|
% Record that the higher order call was made.
|
|
!:CallsHO = calls_higher_order
|
|
;
|
|
( GoalExpr = conj(_ConjType, Goals)
|
|
; GoalExpr = disj(Goals)
|
|
),
|
|
stratify_analyze_goals(Goals, !Calls, !HasAT, !CallsHO)
|
|
;
|
|
GoalExpr = switch(_Var, _Fail, Cases),
|
|
stratify_analyze_cases(Cases, !Calls, !HasAT, !CallsHO)
|
|
;
|
|
GoalExpr = if_then_else(_Vars, Cond, Then, Else),
|
|
stratify_analyze_goal(Cond, !Calls, !HasAT, !CallsHO),
|
|
stratify_analyze_goal(Then, !Calls, !HasAT, !CallsHO),
|
|
stratify_analyze_goal(Else, !Calls, !HasAT, !CallsHO)
|
|
;
|
|
GoalExpr = negation(SubGoal),
|
|
stratify_analyze_goal(SubGoal, !Calls, !HasAT, !CallsHO)
|
|
;
|
|
GoalExpr = scope(Reason, SubGoal),
|
|
( if
|
|
Reason = from_ground_term(_, FGT),
|
|
( FGT = from_ground_term_construct
|
|
; FGT = from_ground_term_deconstruct
|
|
)
|
|
then
|
|
% The code in these scopes does not make calls (either first order
|
|
% or higher order), and it does not take addresses.
|
|
true
|
|
else
|
|
stratify_analyze_goal(SubGoal, !Calls, !HasAT, !CallsHO)
|
|
)
|
|
;
|
|
GoalExpr = shorthand(ShortHand),
|
|
(
|
|
ShortHand = atomic_goal(_, _, _, _, MainGoal, OrElseGoals, _),
|
|
stratify_analyze_goal(MainGoal, !Calls, !HasAT, !CallsHO),
|
|
stratify_analyze_goals(OrElseGoals, !Calls, !HasAT, !CallsHO)
|
|
;
|
|
ShortHand = try_goal(_, _, SubGoal),
|
|
stratify_analyze_goal(SubGoal, !Calls, !HasAT, !CallsHO)
|
|
;
|
|
ShortHand = bi_implication(_, _),
|
|
% These should have been expanded out by now.
|
|
unexpected($pred, "bi_implication")
|
|
)
|
|
).
|
|
|
|
:- pred stratify_analyze_goals(list(hlds_goal)::in,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out,
|
|
calls_higher_order::in, calls_higher_order::out) is det.
|
|
|
|
stratify_analyze_goals([], !Calls, !HasAT, !CallsHO).
|
|
stratify_analyze_goals([Goal | Goals], !Calls, !HasAT, !CallsHO) :-
|
|
stratify_analyze_goal(Goal, !Calls, !HasAT, !CallsHO),
|
|
stratify_analyze_goals(Goals, !Calls, !HasAT, !CallsHO).
|
|
|
|
:- pred stratify_analyze_cases(list(case)::in,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out,
|
|
calls_higher_order::in, calls_higher_order::out) is det.
|
|
|
|
stratify_analyze_cases([], !Calls, !HasAT, !CallsHO).
|
|
stratify_analyze_cases([Case | Goals], !Calls, !HasAT, !CallsHO) :-
|
|
Case = case(_, _, Goal),
|
|
stratify_analyze_goal(Goal, !Calls, !HasAT, !CallsHO),
|
|
stratify_analyze_cases(Goals, !Calls, !HasAT, !CallsHO).
|
|
|
|
% This pred returns a list of all the calls in a given set of goals,
|
|
% including calls in unification lambda functions and pred_proc_id's
|
|
% in constructs.
|
|
%
|
|
:- pred stratify_get_called_procs(hlds_goal::in,
|
|
list(pred_proc_id)::in, list(pred_proc_id)::out) is det.
|
|
|
|
stratify_get_called_procs(Goal, !Calls) :-
|
|
Goal = hlds_goal(GoalExpr, _),
|
|
(
|
|
GoalExpr = unify(_Var, RHS, _Mode, Unification, _Context),
|
|
(
|
|
% Currently this code assumes that all procs called in a lambda
|
|
% goal have addresses taken. This is not always to case, but
|
|
% should be a suitable approximation for the stratification
|
|
% analysis.
|
|
RHS = rhs_lambda_goal(_Purity, _Groundness, _PredOrFunc,
|
|
_NonLocals, _ArgVarsModes, _Determinism, LambdaGoal),
|
|
stratify_get_called_procs(LambdaGoal, !Calls)
|
|
;
|
|
RHS = rhs_var(_)
|
|
;
|
|
RHS = rhs_functor(_, _, _)
|
|
),
|
|
(
|
|
% Currently when this pass is run the construct/4 case will not
|
|
% happen as higher order constants have been transformed to lambda
|
|
% goals. See above.
|
|
Unification = construct(_, ConsId, _, _, _, _, _),
|
|
( if ConsId = closure_cons(ShroudedPredProcId) then
|
|
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
!:Calls = [PredProcId | !.Calls]
|
|
else
|
|
% Do nothing.
|
|
true
|
|
)
|
|
;
|
|
( Unification = deconstruct(_, _, _, _, _, _)
|
|
; Unification = assign(_, _)
|
|
; Unification = simple_test(_, _)
|
|
)
|
|
% Do nothing.
|
|
;
|
|
Unification = complicated_unify(_, _, _),
|
|
unexpected($pred, "complicated_unify")
|
|
)
|
|
;
|
|
GoalExpr = plain_call(CPred, CProc, _Args, _Builtin, _UC, _Sym),
|
|
% Add this call to the call list.
|
|
!:Calls = [proc(CPred, CProc) | !.Calls]
|
|
;
|
|
GoalExpr = call_foreign_proc(_Attrib, _CPred, _CProc, _, _, _, _)
|
|
% Do nothing.
|
|
;
|
|
GoalExpr = generic_call(_Var, _Vars, _Modes, _MaybeArgRegs, _Det)
|
|
% Do nothing.
|
|
;
|
|
( GoalExpr = conj(_ConjType, Goals)
|
|
; GoalExpr = disj(Goals)
|
|
),
|
|
stratify_get_called_procs_goals(Goals, !Calls)
|
|
;
|
|
GoalExpr = switch(_Var, _Fail, Cases),
|
|
stratify_get_called_procs_cases(Cases, !Calls)
|
|
;
|
|
GoalExpr = if_then_else(_Vars, Cond, Then, Else),
|
|
stratify_get_called_procs(Cond, !Calls),
|
|
stratify_get_called_procs(Then, !Calls),
|
|
stratify_get_called_procs(Else, !Calls)
|
|
;
|
|
GoalExpr = negation(SubGoal),
|
|
stratify_get_called_procs(SubGoal, !Calls)
|
|
;
|
|
GoalExpr = scope(Reason, SubGoal),
|
|
( if
|
|
Reason = from_ground_term(_, FGT),
|
|
( FGT = from_ground_term_construct
|
|
; FGT = from_ground_term_deconstruct
|
|
)
|
|
then
|
|
% The code in these scopes does not make calls.
|
|
true
|
|
else
|
|
stratify_get_called_procs(SubGoal, !Calls)
|
|
)
|
|
;
|
|
GoalExpr = shorthand(ShortHand),
|
|
(
|
|
ShortHand = atomic_goal(_, _, _, _, MainGoal, OrElseGoals, _),
|
|
stratify_get_called_procs(MainGoal, !Calls),
|
|
stratify_get_called_procs_goals(OrElseGoals, !Calls)
|
|
;
|
|
ShortHand = try_goal(_, _, SubGoal),
|
|
stratify_get_called_procs(SubGoal, !Calls)
|
|
;
|
|
ShortHand = bi_implication(_, _),
|
|
% These should have been expanded out by now.
|
|
unexpected($pred, "bi_implication")
|
|
)
|
|
).
|
|
|
|
:- pred stratify_get_called_procs_goals(list(hlds_goal)::in,
|
|
list(pred_proc_id)::in, list(pred_proc_id)::out) is det.
|
|
|
|
stratify_get_called_procs_goals([], !Calls).
|
|
stratify_get_called_procs_goals([Goal | Goals], !Calls) :-
|
|
stratify_get_called_procs(Goal, !Calls),
|
|
stratify_get_called_procs_goals(Goals, !Calls).
|
|
|
|
:- pred stratify_get_called_procs_cases(list(case)::in,
|
|
list(pred_proc_id)::in, list(pred_proc_id)::out) is det.
|
|
|
|
stratify_get_called_procs_cases([], !Calls).
|
|
stratify_get_called_procs_cases([Case | Cases], !Calls) :-
|
|
Case = case(_, _, Goal),
|
|
stratify_get_called_procs(Goal, !Calls),
|
|
stratify_get_called_procs_cases(Cases, !Calls).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type error_or_warning
|
|
---> is_error
|
|
; is_warning(option).
|
|
|
|
:- func generate_stratify_error(module_info, pred_proc_id, prog_context,
|
|
string, error_or_warning) = error_spec.
|
|
|
|
generate_stratify_error(ModuleInfo, PredProcId, Context, Message,
|
|
ErrorOrWarning) = Spec :-
|
|
ProcColonPieces = describe_one_proc_name_maybe_argmodes(ModuleInfo,
|
|
output_mercury, yes(color_subject), should_not_module_qualify,
|
|
[suffix(":")], PredProcId),
|
|
Preamble = [words("In")] ++ ProcColonPieces ++ [nl],
|
|
(
|
|
ErrorOrWarning = is_warning(WarnOption),
|
|
ErrOrWarnMsg = words("warning:"),
|
|
Severity = severity_warning(WarnOption)
|
|
;
|
|
ErrorOrWarning = is_error,
|
|
ErrOrWarnMsg = words("error:"),
|
|
Severity = severity_error
|
|
),
|
|
MainPieces =
|
|
[ErrOrWarnMsg] ++ color_as_incorrect([words(Message)]) ++ [nl],
|
|
VerbosePieces =
|
|
[words("A non-stratified loop is a loop in the call graph"),
|
|
words("of the given predicate/function that allows it to call"),
|
|
words("itself in a negated context. This can cause problems for"),
|
|
words("bottom-up evaluation of the predicate/function."), nl],
|
|
Msg = simple_msg(Context,
|
|
[always(Preamble ++ MainPieces),
|
|
verbose_only(verbose_once, VerbosePieces)]),
|
|
Spec = error_spec($pred, Severity, phase_code_gen, [Msg]).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module check_hlds.stratify.
|
|
%-----------------------------------------------------------------------------%
|