mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-16 06:14:59 +00:00
Code Issues Projects Releases Wiki Activity
Files
b86f973fa9650dbc7ea6d4818c4e93fcf22a7e2d
mercury/compiler/exception_analysis.m
Peter Wang b86f973fa9 Allow the use of Mercury abstract machine float registers for passing 
Branches: main

Allow the use of Mercury abstract machine float registers for passing
double-precision float arguments in higher order calls.

In of itself this is not so useful for typical Mercury code.  However, as
all non-local procedures are potentially the targets of higher order calls,
without this change first order calls to non-local procedures could not use
float registers either.  That is the actual motivation for this change.

The basic mechanism is straightforward.  As before, do_call_closure_* is
invoked to place the closure's hidden arguments into r1, ..., rN, and extra
input arguments shifted into rN+1, etc.  With float registers, extra input
arguments may also be in f1, f2, etc. and the closure may also have hidden
float arguments.  Optimising for calls, we order the closure's hidden
arguments so that all float register arguments come after all regular
register arguments in the vector.  Having the arguments out of order does
complicate code which needs to deconstruct closures, but that is not so
important.

Polymorphism complicates things.  A closure with type pred(float) may be
passed to a procedure expecting pred(T).  Due to the `float' argument type,
the closure expects its argument in a float register.  But when passed to the
procedure, the polymorphic argument type means it would be called with the
argument in a regular register.

Higher-order insts already contain information about the calling convention,
without which a higher-order term cannot be called.  We extend higher-order
insts to include information about the register class required for each
argument.  For example, we can distinguish between:

	pred(in) is semidet /* arg regs: [reg_f] */
and
	pred(in) is semidet /* arg regs: [reg_r] */

Using this information, we can create a wrapper around a higher-order
variable if it appears in a context requiring a different calling convention.
We do this in a new HLDS pass, called float_regs.m.

Note: Mercury code has a tendency to lose insts for higher-order terms, then
"recover" them by hacky means.  The float_regs pass depends on higher-order
insts; it is impossible to create a wrapper for a procedure without knowing
how to call it.  The float_regs pass will report errors which we otherwise
accepted, due to higher-order insts being unavailable.  It should be possible
for the user to adjust the code to satisfy the pass, though the user may not
understand why it should be necessary.  In most cases, it probably really
*is* unnecessary.  We may be able to make the float_regs pass more tolerant
of missing higher-order insts in the future.

Class method calls do not use float registers because I didn't want to deal
with them yet.


compiler/options.m:
compiler/handle_options.m:
	Always enable float registers in low-level C grades when floats are
	wider than a word.

compiler/make_hlds_passes.m:
	Always allow double word floats to be stored unboxed in cells on C
	grades.

compiler/hlds_goal.m:
	Add an extra field to `generic_call' which gives the register class
	to use for each argument.  This is set by the float_regs pass.

compiler/prog_data.m:
	Add an extra field to `pred_inst_info' which records the register class
	to use for each argument.  This is set by the float_regs pass.

compiler/hlds_pred.m:
	Add a field to `proc_sub_info' which lists the headvars which must be
	passed via regular registers despite their types.

	Add a field to `pred_sub_info' to record the original unsubstituted
	argument types for instance method predicates.

compiler/check_typeclass.m:
	In the pred_info of an instance method predicate, record the original
	argument types before substituting the type variables for the instance.

compiler/float_regs.m:
compiler/transform_hlds.m:
	Add the new HLDS pass.

compiler/mercury_compile_middle_passes.m:
	Run the new pass if float registers are enabled.

compiler/lambda.m:
	Export the predicate to produce a predicate from a lambda.
	This is reused by float_regs.m to create wrapper closures.

	Add an argument to `expand_lambda' to set the reg_r_headvars field on
	the newly created procedure.

	Delete some unused fields from `lambda_info'.

compiler/arg_info.m:
	Make `generate_proc_arg_info' no longer always use regular registers
	for calls to exported procedures.  Do always use regular registers for
	class methods calls.

	Add a version of `make_arg_infos' which takes an explicit list of
	argument registers.  Rename the previous version.

	Add `generic_call_arg_reg_types' to return the argument registers
	for a generic call.

	Add a version of `compute_in_and_out_vars' which additionally separates
	arguments for float and regular registers.

compiler/call_gen.m:
	Use float registers for argument passing in higher-order calls, as
	directed by the new field in `generic_call'.

compiler/code_util.m:
	Add a function to encode the number of regular and float register
	arguments when making a higher-order call.

compiler/llds.m:
	Say that the `do_call_closure_N' functions only work for zero float
	register arguments.

compiler/follow_vars.m:
compiler/interval.m:
	Account for the use of float registers by generic call goals in these
	passes.

compiler/unify_gen.m:
	Move float register arguments to the end of a closure's hidden
	arguments vector, after regular register arguments.

	Count hidden regular and float register arguments separately, but
	encode them in the same word in the closure.  This is preferable to
	using two words because it reduces the differences between grades
	with and without float registers present.

	Disable generating code which creates a closure from an existing
	closure, if float registers exist.  That code does not understand the
	reordered hidden arguments vector yet.

compiler/continuation_info.m:
	Replace an argument's type_info in the closure layout if the argument
	is a float *and* is passed via a regular register, when floats are
	normally passed via float registers.  Instead, give it the type_info
	for `private_builtin.float_box'.

compiler/builtin_lib_types.m:
	Add function to return the type of `private_builtin.float_box/0'.

compiler/hlds_out_goal.m:
compiler/hlds_out_pred.m:
compiler/mercury_to_mercury.m:
	Dump the new fields added to `generic_call', `pred_inst_info' and
	`proc_sub_info'.

compiler/prog_type.m:
	Add helper predicate.

compiler/*.m:
	Conform to changes.

library/private_builtin.m:
	Add a type `float_box'.

runtime/mercury_ho_call.h:
	Describe the modified closure representation.

	Rename the field which counts the number of hidden arguments to prevent
	it being used incorrectly, as it now encodes two numbers (potentially).

	Add macros to unpack the encoded field.

runtime/mercury_ho_call.c:
	Update the description of how higher-order calls work.

	Update code which extracts closure arguments to take account the
	arguments being reordered in the hidden arguments vector.

runtime/mercury_deep_copy.c:
runtime/mercury_deep_copy_body.h:
runtime/mercury_layout_util.c:
runtime/mercury_ml_expand_body.h:
	Update code which extracts closure arguments to take account the
	arguments being reordered in the hidden arguments vector.

runtime/mercury_type_info.c:
runtime/mercury_type_info.h:
	Add helper function.

tools/make_spec_ho_call:
	Update the generated do_call_closure_* functions to place float
	register arguments.

tests/hard_coded/Mercury.options:
tests/hard_coded/Mmakefile:
tests/hard_coded/ho_float_reg.exp:
tests/hard_coded/ho_float_reg.m:
	Add new test case.

tests/hard_coded/copy_pred.exp:
tests/hard_coded/copy_pred.m:
tests/hard_coded/deconstruct_arg.exp:
tests/hard_coded/deconstruct_arg.exp2:
tests/hard_coded/deconstruct_arg.m:
	Extend test cases with float arguments in closures.

tests/debugger/higher_order.exp2:
	Add alternative output, changed due to closure wrapping.

tests/hard_coded/ho_univ_to_type.m:
	Adjust test case so that the float_regs pass does not report errors
	about missing higher-order insts.

compiler/notes/compiler_design.html:
	Describe the new module.

	Delete a duplicated paragraph.

compiler/notes/todo.html:
TODO:
	Delete one hundred billion year old todos.
2012-02-13 00:11:57 +00:00

1351 lines
53 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2004-2012 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: exception_analysis.m.
% Author: juliensf.
%
% This module performs an exception tracing analysis. The aim is to annotate
% the HLDS with information about whether each procedure might or will not
% throw an exception.
%
% This information can be useful to the compiler when applying certain types
% of optimization.
%
% After running the analysis the exception behaviour of each procedure
% is one of:
%
% (1) will_not_throw_exception
% (2) may_throw_an_exception
% (3) conditional
%
% (1) guarantees that, for all inputs, the procedure will not throw an
% exception.
%
% (2) means that a call to that procedure might result in an exception
% being thrown for at least some inputs.
%
% We distinguish between two kinds of exception. Those that
% are ultimately a result of a call to exception.throw/1, which
% we refer to as "user exceptions" and those that result from a
% unification or comparison where one of the types involved has
% a user-defined equality/comparison predicate that throws
% an exception. We refer to the latter kind, as "type exceptions".
%
% This means that for some polymorphic procedures we cannot
% say what will happen until we know the values of the type variables.
% And so we have ...
%
% (3) means that the exception status of the procedure is dependent upon the
% values of some higher-order variables, or the values of some type
% variables or both. This means that we cannot say anything definite
% about the procedure but for calls to the procedure where have the
% necessary information we can say what will happen.
%
% In the event that we cannot determine the exception status we just assume
% the worst and mark the procedure as maybe throwing a user exception.
%
% For procedures that are defined using the FFI we currently assume that if a
% procedure will not make calls back to Mercury then it cannot throw
% a Mercury exception; if it does make calls to Mercury then it might
% throw an exception.
%
% NOTE: Some backends, e.g the Java backend, use exceptions in the target
% language for various things but we're not interested in that here.
%
% TODO:
% - improve handling of polymorphic procedures (requires type features
% analysis)
% - higher order stuff
% - check what user-defined equality and comparison preds
% actually do rather than assuming that they always
% may throw exceptions.
% - handle existential and solver types - currently we just
% assume that any call to unify or compare for these types
% might result in an exception being thrown.
% - Fix optimizations to use exception information from the analysis
% registry correctly - predicates in goal_form.m and the optimizations
% that use them need to be updated.
%
% XXX We need to be a bit careful with transformations like tabling that
% might add calls to exception.throw - at the moment this isn't a problem
% because exception analysis takes place after the tabling transformation.
%
%----------------------------------------------------------------------------%
:- module transform_hlds.exception_analysis.
:- interface.
:- import_module analysis.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module parse_tree.prog_data.
:- import_module io.
%----------------------------------------------------------------------------%
% Perform the exception analysis on a module.
%
:- pred analyse_exceptions_in_module(module_info::in, module_info::out,
io::di, io::uo) is det.
% Write out the exception pragmas for this module.
%
:- pred write_pragma_exceptions(module_info::in, exception_info::in,
pred_id::in, io::di, io::uo) is det.
% Look the exception status of the given procedure. This predicate
% is intended to be used by optimisations that use exception analysis
% information, *not* for use within the exception analysis itself.
% This predicate abstracts away differences between
% intermodule-optimization and intermodule-analysis.
%
% NOTE: if intermodule-analysis is enabled then this procedure will
% update the IMDG as well.
%
:- pred lookup_exception_analysis_result(pred_proc_id::in,
exception_status::out, module_info::in, module_info::out) is det.
%----------------------------------------------------------------------------%
%
% Types and instances for the intermodule analysis framework
%
:- type exception_analysis_answer.
:- instance analysis(no_func_info, any_call, exception_analysis_answer).
:- instance partial_order(no_func_info, exception_analysis_answer).
:- instance answer_pattern(no_func_info, exception_analysis_answer).
:- instance to_term(exception_analysis_answer).
%----------------------------------------------------------------------------%
%----------------------------------------------------------------------------%
:- implementation.
:- import_module check_hlds.type_util.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module libs.file_util.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.file_names.
:- import_module parse_tree.prog_type.
:- import_module transform_hlds.dependency_graph.
:- import_module transform_hlds.mmc_analysis.
:- import_module bool.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module term.
%----------------------------------------------------------------------------%
%
% Perform exception analysis on a module
%
analyse_exceptions_in_module(!ModuleInfo, !IO) :-
module_info_ensure_dependency_info(!ModuleInfo),
module_info_dependency_info(!.ModuleInfo, DepInfo),
hlds_dependency_info_get_dependency_ordering(DepInfo, SCCs),
list.foldl(check_scc_for_exceptions, SCCs, !ModuleInfo),
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_bool_option(Globals, make_optimization_interface,
MakeOptInt),
globals.lookup_bool_option(Globals, intermodule_analysis,
IntermodAnalysis),
globals.lookup_bool_option(Globals, make_analysis_registry,
MakeAnalysisReg),
% Only write exception analysis pragmas to `.opt' files for
% `--intermodule-optimization', not `--intermodule-analysis'.
(
MakeOptInt = yes,
IntermodAnalysis = no
->
make_optimization_interface(!.ModuleInfo, !IO)
;
true
),
% Record results if making the analysis registry. We do this in a
% separate pass so that we record results for exported `:- external'
% procedures, which don't get analysed because we don't have clauses
% for them.
(
MakeAnalysisReg = yes,
module_info_get_analysis_info(!.ModuleInfo, AnalysisInfo0),
module_info_get_valid_predids(PredIds, !ModuleInfo),
list.foldl(maybe_record_exception_result(!.ModuleInfo),
PredIds, AnalysisInfo0, AnalysisInfo),
module_info_set_analysis_info(AnalysisInfo, !ModuleInfo)
;
MakeAnalysisReg = no
).
%----------------------------------------------------------------------------%
%
% Perform exception analysis on a SCC
%
:- type scc == list(pred_proc_id).
:- type proc_results == list(proc_result).
:- type proc_result
---> proc_result(
ppid :: pred_proc_id,
% The ppid of the procedure whose analysis results are
% stored in this structure.
status :: exception_status,
% Exception status of this procedure not counting any input
% from (mutually-)recursive inputs.
rec_calls :: type_status,
% The collective type status of the types of the terms that
% are arguments of (mutually-)recursive calls.
maybe_analysis_status :: maybe(analysis_status)
% The analysis status used for intermodule-analysis. This
% should be `no' if we are not compiling with
% intermodule-analysis enabled.
).
:- pred check_scc_for_exceptions(scc::in,
module_info::in, module_info::out) is det.
check_scc_for_exceptions(SCC, !ModuleInfo) :-
check_procs_for_exceptions(SCC, ProcResults, !ModuleInfo),
%
% The `Results' above are the results of analysing each individual
% procedure in the SCC - we now have to combine them in a meaningful way.
%
combine_individual_proc_results(ProcResults, Status, MaybeAnalysisStatus),
%
% Update the exception_info table with information about this SCC.
%
module_info_get_exception_info(!.ModuleInfo, ExceptionInfo0),
Update = (pred(PPId::in, Info0::in, Info::out) is det :-
Info = Info0 ^ elem(PPId) :=
proc_exception_info(Status, MaybeAnalysisStatus)
),
list.foldl(Update, SCC, ExceptionInfo0, ExceptionInfo),
module_info_set_exception_info(ExceptionInfo, !ModuleInfo).
% Check each procedure in the SCC individually.
%
:- pred check_procs_for_exceptions(scc::in, proc_results::out,
module_info::in, module_info::out) is det.
check_procs_for_exceptions(SCC, Result, !ModuleInfo) :-
list.foldl2(check_proc_for_exceptions(SCC), SCC, [], Result,
!ModuleInfo).
% Examine how procedures interact with other procedures that are
% mutually-recursive to them.
%
:- pred combine_individual_proc_results(proc_results::in,
exception_status::out, maybe(analysis_status)::out) is det.
combine_individual_proc_results([], _, _) :-
unexpected($module, $pred, "Empty SCC during exception analysis.").
combine_individual_proc_results(ProcResults @ [_|_], SCC_Result,
MaybeAnalysisStatus) :-
(
% If none of the procedures may throw an exception or are conditional
% then the SCC cannot throw an exception either.
all [ProcResult] list.member(ProcResult, ProcResults) =>
ProcResult ^ status = will_not_throw
->
SCC_Result = will_not_throw
;
% If none of the procedures may throw an exception but at least one of
% them is conditional then somewhere in the SCC there is a call to
% unify or compare that may rely on the types of the polymorphically
% typed arguments.
%
% We need to check that any recursive calls do not introduce types
% that might have user-defined equality or comparison predicate that
% throw exceptions.
%
all [EResult] (
list.member(EResult, ProcResults)
=>
EResult ^ status \= may_throw(_)
),
some [CResult] (
list.member(CResult, ProcResults),
CResult ^ status = throw_conditional
)
->
SCC_Result = handle_mixed_conditional_scc(ProcResults)
;
% If none of the procedures can throw a user_exception but one or more
% can throw a type_exception then mark the SCC as maybe throwing a
% type_exception.
all [EResult] (
list.member(EResult, ProcResults)
=>
EResult ^ status \= may_throw(user_exception)
),
some [TResult] (
list.member(TResult, ProcResults),
TResult ^ status = may_throw(type_exception)
)
->
SCC_Result = may_throw(type_exception)
;
SCC_Result = may_throw(user_exception)
),
combine_proc_result_maybe_analysis_statuses(ProcResults,
MaybeAnalysisStatus).
% XXX There is some code duplication with trailing_analysis.m
% here ... we should factor out this code into a utility module
% for intermodule-analysis at some point.
%
:- pred combine_proc_result_maybe_analysis_statuses(proc_results::in,
maybe(analysis_status)::out) is det.
combine_proc_result_maybe_analysis_statuses(ProcResults,
MaybeAnalysisStatus) :-
list.map(maybe_analysis_status, ProcResults, MaybeAnalysisStatuses),
list.foldl(combine_maybe_analysis_status, MaybeAnalysisStatuses,
yes(optimal), MaybeAnalysisStatus).
:- pred maybe_analysis_status(proc_result::in, maybe(analysis_status)::out)
is det.
maybe_analysis_status(ProcResult, ProcResult ^ maybe_analysis_status).
%----------------------------------------------------------------------------%
%
% Process individual procedures
%
:- pred check_proc_for_exceptions(scc::in, pred_proc_id::in,
proc_results::in, proc_results::out, module_info::in, module_info::out)
is det.
check_proc_for_exceptions(SCC, PPId, !Results, !ModuleInfo) :-
module_info_pred_proc_info(!.ModuleInfo, PPId, _, ProcInfo),
proc_info_get_goal(ProcInfo, Body),
proc_info_get_vartypes(ProcInfo, VarTypes),
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_bool_option(Globals, intermodule_analysis,
IntermodAnalysis),
MaybeAnalysisStatus0 = maybe_optimal(IntermodAnalysis),
Result0 = proc_result(PPId, will_not_throw, type_will_not_throw,
MaybeAnalysisStatus0),
check_goal_for_exceptions(SCC, VarTypes, Body, Result0, Result,
!ModuleInfo),
list.cons(Result, !Results).
:- pred check_goal_for_exceptions(scc::in, vartypes::in, hlds_goal::in,
proc_result::in, proc_result::out, module_info::in, module_info::out)
is det.
check_goal_for_exceptions(SCC, VarTypes, hlds_goal(GoalExpr, GoalInfo),
!Result, !ModuleInfo) :-
( goal_info_get_determinism(GoalInfo) = detism_erroneous ->
!Result ^ status := may_throw(user_exception)
;
check_goal_for_exceptions_2(SCC, VarTypes, GoalExpr, GoalInfo,
!Result, !ModuleInfo)
).
:- pred check_goal_for_exceptions_2(scc::in, vartypes::in,
hlds_goal_expr::in, hlds_goal_info::in, proc_result::in, proc_result::out,
module_info::in, module_info::out) is det.
check_goal_for_exceptions_2(SCC, VarTypes, GoalExpr, GoalInfo,
!Result, !ModuleInfo) :-
(
GoalExpr = unify(_, _, _, Kind, _),
(
Kind = complicated_unify(_, _, _),
unexpected($module, $pred,
"complicated unify during exception analysis.")
;
( Kind = construct(_, _, _, _, _, _, _)
; Kind = deconstruct(_, _, _, _, _, _)
; Kind = assign(_, _)
; Kind = simple_test(_, _)
)
)
;
GoalExpr = plain_call(CallPredId, CallProcId, Args, _, _, _),
check_goal_for_exceptions_plain_call(SCC, VarTypes,
CallPredId, CallProcId, Args, !Result, !ModuleInfo)
;
GoalExpr = generic_call(Details, Args, _, _, _),
check_goal_for_exceptions_generic_call(VarTypes, Details, Args,
GoalInfo, !Result, !ModuleInfo)
;
GoalExpr = call_foreign_proc(Attributes, _, _, _, _, _, _),
% NOTE: for --intermodule-analysis the results for for foreign_procs
% will *always* be optimal (since we always rely on user annotation),
% so there's nothing to do here.
MayCallMercury = get_may_call_mercury(Attributes),
(
MayCallMercury = proc_may_call_mercury,
get_may_throw_exception(Attributes) = MayThrowException,
% We do not need to deal with erroneous predicates here because
% they will have already been processed.
(
MayThrowException = default_exception_behaviour,
!Result ^ status := may_throw(user_exception)
;
MayThrowException = proc_will_not_throw_exception
)
;
MayCallMercury = proc_will_not_call_mercury
)
;
( GoalExpr = disj(Goals)
; GoalExpr = conj(_, Goals)
),
check_goals_for_exceptions(SCC, VarTypes, Goals, !Result, !ModuleInfo)
;
GoalExpr = switch(_, _, Cases),
CaseGoals = list.map((func(case(_, _, CaseGoal)) = CaseGoal), Cases),
check_goals_for_exceptions(SCC, VarTypes, CaseGoals, !Result,
!ModuleInfo)
;
GoalExpr = if_then_else(_, If, Then, Else),
check_goals_for_exceptions(SCC, VarTypes, [If, Then, Else],
!Result, !ModuleInfo)
;
GoalExpr = negation(SubGoal),
check_goal_for_exceptions(SCC, VarTypes, SubGoal, !Result, !ModuleInfo)
;
GoalExpr = scope(Reason, SubGoal),
(
Reason = from_ground_term(_, FGT),
( FGT = from_ground_term_construct
; FGT = from_ground_term_deconstruct
)
->
true
;
check_goal_for_exceptions(SCC, VarTypes, SubGoal, !Result,
!ModuleInfo)
)
;
GoalExpr = shorthand(_),
% These should have been expanded out by now.
unexpected($module, $pred,
"shorthand goal encountered during exception analysis.")
).
:- pred check_goal_for_exceptions_plain_call(scc::in, vartypes::in,
pred_id::in, proc_id::in, list(prog_var)::in,
proc_result::in, proc_result::out, module_info::in, module_info::out)
is det.
check_goal_for_exceptions_plain_call(SCC, VarTypes, CallPredId, CallProcId,
CallArgs, !Result, !ModuleInfo) :-
CallPPId = proc(CallPredId, CallProcId),
module_info_pred_info(!.ModuleInfo, CallPredId, CallPredInfo),
(
% Handle (mutually-)recursive calls.
list.member(CallPPId, SCC)
->
Types = list.map((func(Var) = VarTypes ^ det_elem(Var)), CallArgs),
TypeStatus = check_types(!.ModuleInfo, Types),
combine_type_status(TypeStatus, !.Result ^ rec_calls, NewTypeStatus),
!Result ^ rec_calls := NewTypeStatus
;
pred_info_is_builtin(CallPredInfo)
->
% Builtins won't throw exceptions.
true
;
% Handle unify and compare.
(
ModuleName = pred_info_module(CallPredInfo),
any_mercury_builtin_module(ModuleName),
Name = pred_info_name(CallPredInfo),
Arity = pred_info_orig_arity(CallPredInfo),
( SpecialPredId = spec_pred_compare
; SpecialPredId = spec_pred_unify
),
special_pred_name_arity(SpecialPredId, Name, _, Arity)
;
pred_info_get_origin(CallPredInfo, Origin),
Origin = origin_special_pred(SpecialPredId - _),
( SpecialPredId = spec_pred_compare
; SpecialPredId = spec_pred_unify
)
)
->
% For unification/comparison the exception status depends upon the the
% types of the arguments. In particular whether some component of
% that type has a user-defined equality/comparison predicate that
% throws an exception.
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_bool_option(Globals, intermodule_analysis,
IntermodAnalysis),
MaybeAnalysisStatus = maybe_optimal(IntermodAnalysis),
check_vars(!.ModuleInfo, VarTypes, CallArgs, MaybeAnalysisStatus,
!Result)
;
check_nonrecursive_call(VarTypes, CallPPId, CallArgs, CallPredInfo,
!Result, !ModuleInfo)
).
:- pred check_goal_for_exceptions_generic_call(vartypes::in,
generic_call::in, list(prog_var)::in, hlds_goal_info::in,
proc_result::in, proc_result::out, module_info::in, module_info::out)
is det.
check_goal_for_exceptions_generic_call(VarTypes, Details, Args, GoalInfo,
!Result, !ModuleInfo) :-
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_bool_option(Globals, intermodule_analysis,
IntermodAnalysis),
(
Details = higher_order(Var, _, _, _),
ClosureValueMap = goal_info_get_ho_values(GoalInfo),
( ClosureValues = ClosureValueMap ^ elem(Var) ->
get_closures_exception_status(IntermodAnalysis, ClosureValues,
MaybeWillNotThrow, MaybeAnalysisStatus, !ModuleInfo),
(
MaybeWillNotThrow = maybe_will_not_throw(ConditionalProcs),
(
ConditionalProcs = []
% The possible values of the higher-order variable are all
% procedures that are known not to throw exceptions.
;
ConditionalProcs = [_ | _],
% For 'conditional' procedures we need to make sure that
% if any type variables are bound at the generic_call
% site, then this does not cause the closure to throw an
% exception (because of a user-defined equality or
% comparison predicate that throws an exception.)
%
% If we can resolve all of the polymorphism at this
% generic_call site, then we can reach a definite
% conclusion about it.
%
% If we cannot do so, then we propagate the 'conditional'
% status to the current predicate if all the type
% variables involved are universally quantified, or mark
% it as throwing an exception if some of them are
% existentially quantified.
%
% XXX This is too conservative but we don't currently
% perform a fine-grained enough analysis of where
% out-of-line unifications/comparisons occur to be able to
% do better.
check_vars(!.ModuleInfo, VarTypes, Args,
MaybeAnalysisStatus, !Result)
)
;
MaybeWillNotThrow = may_throw,
!Result ^ status := may_throw(user_exception)
)
;
!Result ^ status := may_throw(user_exception)
)
;
% XXX We could do better with class methods.
Details = class_method(_, _, _, _),
!Result ^ status := may_throw(user_exception)
;
Details = event_call(_)
;
Details = cast(_)
).
:- pred check_goals_for_exceptions(scc::in, vartypes::in,
hlds_goals::in, proc_result::in, proc_result::out,
module_info::in, module_info::out) is det.
check_goals_for_exceptions(_, _, [], !Result, !ModuleInfo).
check_goals_for_exceptions(SCC, VarTypes, [Goal | Goals], !Result,
!ModuleInfo) :-
check_goal_for_exceptions(SCC, VarTypes, Goal, !Result, !ModuleInfo),
% We can stop searching if we find a user exception. However if we find
% a type exception then we still need to check that there is not a user
% exception somewhere in the rest of the SCC.
CurrentStatus = !.Result ^ status,
(
CurrentStatus = may_throw(user_exception)
;
( CurrentStatus = will_not_throw
; CurrentStatus = throw_conditional
; CurrentStatus = may_throw(type_exception)
),
check_goals_for_exceptions(SCC, VarTypes, Goals, !Result, !ModuleInfo)
).
%----------------------------------------------------------------------------%
%
% Further code to handle higher-order variables
%
% The exception status of a collection of procedures that can be called
% through a higher-order variable.
%
:- type closures_exception_status
---> may_throw
% One or more of the closures throws an exception.
; maybe_will_not_throw(list(pred_proc_id)).
% None of the procedures throws a user exception, but the ones in
% the list are conditional. Any polymorphic/higher-order
% args needed to either be checked at the generic_call site or
% the conditional status needs to be propagated up the call-graph
% to a point where it can be resolved.
% For the set of procedures that might be called through a particular
% higher-order variable at a particular program point (as determined by
% closure analysis), work out what the overall exception and analysis
% status is going to be.
%
:- pred get_closures_exception_status(bool::in, set(pred_proc_id)::in,
closures_exception_status::out, maybe(analysis_status)::out,
module_info::in, module_info::out) is det.
get_closures_exception_status(IntermodAnalysis, Closures,
Conditionals, AnalysisStatus, !ModuleInfo) :-
module_info_get_exception_info(!.ModuleInfo, ExceptionInfo),
AnalysisStatus0 = maybe_optimal(IntermodAnalysis),
set.fold3(
get_closure_exception_status(IntermodAnalysis, ExceptionInfo),
Closures, maybe_will_not_throw([]), Conditionals,
AnalysisStatus0, AnalysisStatus, !ModuleInfo).
:- pred get_closure_exception_status(
bool::in, exception_info::in, pred_proc_id::in,
closures_exception_status::in, closures_exception_status::out,
maybe(analysis_status)::in, maybe(analysis_status)::out,
module_info::in, module_info::out) is det.
get_closure_exception_status(IntermodAnalysis, ExceptionInfo, PPId,
!MaybeWillNotThrow, !AS, !ModuleInfo) :-
module_info_pred_proc_info(!.ModuleInfo, PPId, PredInfo, _),
(
IntermodAnalysis = yes,
pred_info_is_imported_not_external(PredInfo)
->
search_analysis_status(PPId, ExceptionStatus, AnalysisStatus,
!ModuleInfo),
MaybeAnalysisStatus = yes(AnalysisStatus)
;
( ProcExceptionInfo = ExceptionInfo ^ elem(PPId) ->
ProcExceptionInfo = proc_exception_info(ExceptionStatus,
MaybeAnalysisStatus)
;
ExceptionStatus = may_throw(user_exception),
MaybeAnalysisStatus = maybe_optimal(IntermodAnalysis)
)
),
(
!.MaybeWillNotThrow = may_throw
;
!.MaybeWillNotThrow = maybe_will_not_throw(Conditionals),
(
ExceptionStatus = throw_conditional,
!:MaybeWillNotThrow = maybe_will_not_throw([PPId | Conditionals])
;
ExceptionStatus = will_not_throw
;
ExceptionStatus = may_throw(_),
!:MaybeWillNotThrow = may_throw
)
),
combine_maybe_analysis_status(MaybeAnalysisStatus, !AS).
%----------------------------------------------------------------------------%
:- pred update_proc_result(exception_status::in, maybe(analysis_status)::in,
proc_result::in, proc_result::out) is det.
update_proc_result(CurrentStatus, CurrentAnalysisStatus, !Result) :-
OldStatus = !.Result ^ status,
OldAnalysisStatus = !.Result ^ maybe_analysis_status,
NewStatus = combine_exception_status(CurrentStatus, OldStatus),
combine_maybe_analysis_status(CurrentAnalysisStatus, OldAnalysisStatus,
NewAnalysisStatus),
!Result ^ status := NewStatus,
!Result ^ maybe_analysis_status := NewAnalysisStatus.
:- func combine_exception_status(exception_status, exception_status)
= exception_status.
combine_exception_status(will_not_throw, Y) = Y.
combine_exception_status(X @ may_throw(user_exception), _) = X.
combine_exception_status(X @ may_throw(type_exception), will_not_throw) = X.
combine_exception_status(X @ may_throw(type_exception), throw_conditional) = X.
combine_exception_status(may_throw(type_exception), Y @ may_throw(_)) = Y.
combine_exception_status(throw_conditional, throw_conditional) =
throw_conditional.
combine_exception_status(throw_conditional, will_not_throw) =
throw_conditional.
combine_exception_status(throw_conditional, Y @ may_throw(_)) = Y.
:- pred combine_maybe_analysis_status(maybe(analysis_status)::in,
maybe(analysis_status)::in, maybe(analysis_status)::out) is det.
combine_maybe_analysis_status(MaybeStatusA, MaybeStatusB, MaybeStatus) :-
(
MaybeStatusA = yes(StatusA),
MaybeStatusB = yes(StatusB)
->
MaybeStatus = yes(analysis.lub(StatusA, StatusB))
;
MaybeStatus = no
).
%----------------------------------------------------------------------------%
%
% Extra procedures for handling calls.
%
:- pred check_nonrecursive_call(vartypes::in,
pred_proc_id::in, prog_vars::in, pred_info::in,
proc_result::in, proc_result::out,
module_info::in, module_info::out) is det.
check_nonrecursive_call(VarTypes, PPId, Args, PredInfo, !Result, !ModuleInfo) :-
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_bool_option(Globals, intermodule_analysis,
IntermodAnalysis),
(
% If we are using `--intermodule-analysis' then use the analysis
% framework for imported procedures.
IntermodAnalysis = yes,
pred_info_is_imported_not_external(PredInfo)
->
search_analysis_status(PPId, CalleeResult, AnalysisStatus,
!ModuleInfo),
MaybeAnalysisStatus = yes(AnalysisStatus),
update_proc_result(CalleeResult, MaybeAnalysisStatus, !Result)
;
module_info_get_exception_info(!.ModuleInfo, ExceptionInfo),
( map.search(ExceptionInfo, PPId, CalleeExceptionInfo) ->
CalleeExceptionInfo = proc_exception_info(CalleeExceptionStatus,
MaybeAnalysisStatus),
(
CalleeExceptionStatus = will_not_throw,
update_proc_result(will_not_throw, MaybeAnalysisStatus,
!Result)
;
CalleeExceptionStatus = may_throw(ExceptionType),
update_proc_result(may_throw(ExceptionType),
MaybeAnalysisStatus, !Result)
;
CalleeExceptionStatus = throw_conditional,
check_vars(!.ModuleInfo, VarTypes, Args, MaybeAnalysisStatus,
!Result)
)
;
% If we do not have any information about the callee procedure
% then assume that it might throw an exception.
% Analysis statuses on individual results are meaningless now.
MaybeAnalysisStatus = maybe_optimal(IntermodAnalysis),
update_proc_result(may_throw(user_exception), MaybeAnalysisStatus,
!Result)
)
).
:- pred check_vars(module_info::in, vartypes::in, prog_vars::in,
maybe(analysis_status)::in, proc_result::in, proc_result::out) is det.
check_vars(ModuleInfo, VarTypes, Vars, MaybeAnalysisStatus, !Result) :-
Types = list.map((func(Var) = VarTypes ^ det_elem(Var)), Vars),
TypeStatus = check_types(ModuleInfo, Types),
(
TypeStatus = type_will_not_throw
;
TypeStatus = type_may_throw,
update_proc_result(may_throw(type_exception), MaybeAnalysisStatus,
!Result)
;
TypeStatus = type_conditional,
update_proc_result(throw_conditional, MaybeAnalysisStatus, !Result)
).
%----------------------------------------------------------------------------%
%
% Predicates for checking mixed SCCs
%
% A "mixed SCC" is one where at least one of the procedures in the SCC is
% known not to throw an exception, at least one of them is conditional and
% none of them may throw an exception (of either sort).
%
% In order to determine the status of such a SCC we also need to take the
% effect of the recursive calls into account. This is because calls to a
% conditional procedure from a procedure that is mutually recursive to it may
% introduce types that could cause a type_exception to be thrown.
%
% We currently assume that if these types are introduced somewhere in the SCC
% then they may be propagated around the entire SCC - hence if a part of the
% SCC is conditional we need to make sure other parts don't supply it with
% input whose types may have user-defined equality/comparison predicates.
% NOTE: it is possible to write rather contrived programs that can exhibit
% rather strange behaviour which is why all this is necessary.
:- func handle_mixed_conditional_scc(proc_results) = exception_status.
handle_mixed_conditional_scc(Results) =
(
all [TypeStatus] (
list.member(Result, Results)
=>
Result ^ rec_calls \= type_may_throw
)
->
throw_conditional
;
% Somewhere a type that causes an exception is being
% passed around the SCC via one or more of the recursive
% calls.
may_throw(type_exception)
).
%----------------------------------------------------------------------------%
%
% Stuff for processing types.
%
% This is used in the analysis of calls to polymorphic procedures.
%
% By saying a `type can throw an exception' we mean that an exception might be
% thrown as a result of a unification or comparison involving the type because
% it has a user-defined equality/comparison predicate that may throw an
% exception.
%
% XXX We don't actually need to examine all the types, just those that are
% potentially going to be involved in unification/comparisons. At the moment
% we don't keep track of that information so the current procedure is as
% follows:
%
% Examine the functor and then recursively examine the arguments.
% * If everything will not throw then the type will not throw
% * If at least one of the types may_throw then the type will throw
% * If at least one of the types is conditional and none of them throw then
% the type is conditional.
:- type type_status
---> type_will_not_throw
% This type does not have user-defined equality
% or comparison predicates.
% XXX (Or it has ones that are known not to throw
% exceptions).
; type_may_throw
% This type has a user-defined equality or comparison
% predicate that is known to throw an exception.
; type_conditional.
% This type is polymorphic. We cannot say anything about
% it until we know the values of the type-variables.
% Return the collective type status of a list of types.
%
:- func check_types(module_info, list(mer_type)) = type_status.
check_types(ModuleInfo, Types) = Status :-
list.foldl(check_type(ModuleInfo), Types, type_will_not_throw, Status).
:- pred check_type(module_info::in, mer_type::in, type_status::in,
type_status::out) is det.
check_type(ModuleInfo, Type, !Status) :-
combine_type_status(check_type(ModuleInfo, Type), !Status).
:- pred combine_type_status(type_status::in, type_status::in,
type_status::out) is det.
combine_type_status(type_will_not_throw, type_will_not_throw,
type_will_not_throw).
combine_type_status(type_will_not_throw, type_conditional, type_conditional).
combine_type_status(type_will_not_throw, type_may_throw, type_may_throw).
combine_type_status(type_conditional, type_will_not_throw, type_conditional).
combine_type_status(type_conditional, type_conditional, type_conditional).
combine_type_status(type_conditional, type_may_throw, type_may_throw).
combine_type_status(type_may_throw, _, type_may_throw).
% Return the type status of an individual type.
%
:- func check_type(module_info, mer_type) = type_status.
check_type(ModuleInfo, Type) = Status :-
(
( is_solver_type(ModuleInfo, Type)
; is_existq_type(ModuleInfo, Type))
->
% XXX At the moment we just assume that existential types and
% solver types result in a type exception being thrown.
Status = type_may_throw
;
TypeCategory = classify_type(ModuleInfo, Type),
Status = check_type_2(ModuleInfo, Type, TypeCategory)
).
:- func check_type_2(module_info, mer_type, type_ctor_category) = type_status.
check_type_2(ModuleInfo, Type, CtorCat) = WillThrow :-
(
( CtorCat = ctor_cat_builtin(_)
; CtorCat = ctor_cat_higher_order
; CtorCat = ctor_cat_system(_)
; CtorCat = ctor_cat_void
; CtorCat = ctor_cat_builtin_dummy
),
WillThrow = type_will_not_throw
;
CtorCat = ctor_cat_variable,
WillThrow = type_conditional
;
CtorCat = ctor_cat_tuple,
( type_to_ctor_and_args(Type, _TypeCtor, Args) ->
WillThrow = check_types(ModuleInfo, Args)
;
unexpected($module, $pred, "expected tuple type")
)
;
CtorCat = ctor_cat_enum(_),
( type_has_user_defined_equality_pred(ModuleInfo, Type, _UC) ->
% XXX This is very conservative.
WillThrow = type_may_throw
;
WillThrow = type_will_not_throw
)
;
CtorCat = ctor_cat_user(_),
type_to_ctor_and_args_det(Type, TypeCtor, Args),
( type_has_user_defined_equality_pred(ModuleInfo, Type, _UC) ->
% XXX We can do better than this by examining what these preds
% actually do. Something similar needs to be sorted out for
% termination analysis as well, so we'll wait until that is done.
WillThrow = type_may_throw
;
( type_ctor_is_safe(TypeCtor) ->
WillThrow = check_types(ModuleInfo, Args)
;
WillThrow = type_may_throw
)
)
).
% Succeeds if the exception status of the type represented by the given
% type_ctor can be determined by examining the exception status of the
% arguments, if any.
%
% NOTE: This list does not need to include enumerations since they
% are already handled above. Also, this list does not need to include
% non-abstract equivalence types.
%
:- pred type_ctor_is_safe(type_ctor::in) is semidet.
type_ctor_is_safe(TypeCtor) :-
TypeCtor = type_ctor(qualified(unqualified(ModuleName), CtorName), Arity),
type_ctor_is_safe_2(ModuleName, CtorName, Arity).
:- pred type_ctor_is_safe_2(string::in, string::in, arity::in) is semidet.
type_ctor_is_safe_2("assoc_list", "assoc_list", 1).
type_ctor_is_safe_2("bag", "bag", 1).
type_ctor_is_safe_2("bimap", "bimap", 2).
type_ctor_is_safe_2("builtin", "c_pointer", 0).
type_ctor_is_safe_2("cord", "cord", 1).
type_ctor_is_safe_2("eqvclass", "eqvclass", 1).
type_ctor_is_safe_2("injection", "injection", 2).
type_ctor_is_safe_2("integer", "integer", 0).
type_ctor_is_safe_2("io", "input_stream", 0).
type_ctor_is_safe_2("io", "output_stream", 0).
type_ctor_is_safe_2("io", "binary_stream", 0).
type_ctor_is_safe_2("io", "stream_id", 0).
type_ctor_is_safe_2("io", "res", 0).
type_ctor_is_safe_2("io", "res", 1).
type_ctor_is_safe_2("io", "maybe_partial_res", 1).
type_ctor_is_safe_2("io", "result", 0).
type_ctor_is_safe_2("io", "result", 1).
type_ctor_is_safe_2("io", "read_result", 1).
type_ctor_is_safe_2("io", "error", 0).
type_ctor_is_safe_2("list", "list", 1).
type_ctor_is_safe_2("map", "map", 2).
type_ctor_is_safe_2("maybe", "maybe", 1).
type_ctor_is_safe_2("maybe_error", "maybe_error", 1).
type_ctor_is_safe_2("multi_map", "multi_map", 2).
type_ctor_is_safe_2("pair", "pair", 2).
type_ctor_is_safe_2("pqueue", "pqueue", 2).
type_ctor_is_safe_2("queue", "queue", 1).
type_ctor_is_safe_2("rational", "rational", 0).
type_ctor_is_safe_2("rbtree", "rbtree", 2).
type_ctor_is_safe_2("rtree", "rtree", 2).
type_ctor_is_safe_2("set", "set", 1).
type_ctor_is_safe_2("set_bbbtree", "set_bbbtree", 1).
type_ctor_is_safe_2("set_ctree234", "set_ctree234", 1).
type_ctor_is_safe_2("set_ordlist", "set_ordlist", 1).
type_ctor_is_safe_2("set_tree234", "set_tree234", 1).
type_ctor_is_safe_2("set_unordlist", "set_unordlist", 1).
type_ctor_is_safe_2("stack", "stack", 1).
type_ctor_is_safe_2("string", "poly_type", 0).
type_ctor_is_safe_2("string", "justified_column", 0).
type_ctor_is_safe_2("term", "term", 1).
type_ctor_is_safe_2("term", "const", 0).
type_ctor_is_safe_2("term", "context", 0).
type_ctor_is_safe_2("term", "var", 1).
type_ctor_is_safe_2("term", "var_supply", 1).
type_ctor_is_safe_2("varset", "varset", 1).
%----------------------------------------------------------------------------%
%
% Types and instances for the intermodule analysis framework
%
:- type exception_analysis_answer
---> exception_analysis_answer(exception_status).
:- func analysis_name = string.
analysis_name = "exception_analysis".
:- instance analysis(no_func_info, any_call, exception_analysis_answer)
where [
analysis_name(_, _) = analysis_name,
analysis_version_number(_, _) = 1,
preferred_fixpoint_type(_, _) = least_fixpoint,
bottom(_, _) = exception_analysis_answer(will_not_throw),
top(_, _) = exception_analysis_answer(may_throw(user_exception)),
get_func_info(_, _, _, _, _, no_func_info)
].
:- instance answer_pattern(no_func_info, exception_analysis_answer) where [].
:- instance partial_order(no_func_info, exception_analysis_answer) where [
( more_precise_than(no_func_info, Answer1, Answer2) :-
Answer1 = exception_analysis_answer(Status1),
Answer2 = exception_analysis_answer(Status2),
exception_status_more_precise_than(Status1, Status2)
),
equivalent(no_func_info, Status, Status)
].
:- pred exception_status_more_precise_than(exception_status::in,
exception_status::in) is semidet.
exception_status_more_precise_than(will_not_throw, throw_conditional).
exception_status_more_precise_than(will_not_throw, may_throw(_)).
exception_status_more_precise_than(throw_conditional, may_throw(_)).
exception_status_more_precise_than(may_throw(type_exception),
may_throw(user_exception)).
:- instance to_term(exception_analysis_answer) where [
func(to_term/1) is answer_to_term,
pred(from_term/2) is answer_from_term
].
:- func answer_to_term(exception_analysis_answer) = term.
answer_to_term(Answer) = Term :-
Answer = exception_analysis_answer(Status),
exception_status_to_string(Status, String),
Term = term.functor(atom(String), [], context_init).
:- pred answer_from_term(term::in, exception_analysis_answer::out) is semidet.
answer_from_term(Term, exception_analysis_answer(Status)) :-
Term = term.functor(atom(String), [], _),
exception_status_to_string(Status, String).
:- pred exception_status_to_string(exception_status, string).
:- mode exception_status_to_string(in, out) is det.
:- mode exception_status_to_string(out, in) is semidet.
exception_status_to_string(will_not_throw, "will_not_throw").
exception_status_to_string(throw_conditional, "conditional").
exception_status_to_string(may_throw(type_exception),
"may_throw_type_exception").
exception_status_to_string(may_throw(user_exception),
"may_throw_user_exception").
%----------------------------------------------------------------------------%
%
% Additional predicates used for intermodule analysis
%
:- pred search_analysis_status(pred_proc_id::in,
exception_status::out, analysis_status::out,
module_info::in, module_info::out) is det.
search_analysis_status(PPId, Result, AnalysisStatus, !ModuleInfo) :-
module_info_get_analysis_info(!.ModuleInfo, AnalysisInfo0),
search_analysis_status_2(!.ModuleInfo, PPId, Result, AnalysisStatus,
AnalysisInfo0, AnalysisInfo),
module_info_set_analysis_info(AnalysisInfo, !ModuleInfo).
:- pred search_analysis_status_2(module_info::in, pred_proc_id::in,
exception_status::out, analysis_status::out,
analysis_info::in, analysis_info::out) is det.
search_analysis_status_2(ModuleInfo, PPId, Result, AnalysisStatus,
!AnalysisInfo) :-
module_name_func_id(ModuleInfo, PPId, ModuleName, FuncId),
Call = any_call,
lookup_best_result(!.AnalysisInfo, ModuleName, FuncId, no_func_info, Call,
MaybeBestResult),
(
MaybeBestResult = yes(analysis_result(BestCall, BestAnswer,
AnalysisStatus)),
BestAnswer = exception_analysis_answer(Result),
record_dependency(ModuleName, FuncId, no_func_info, BestCall,
_ : exception_analysis_answer, !AnalysisInfo)
;
MaybeBestResult = no,
% If we do not have any information about the callee procedure then
% assume that it throws an exception.
top(no_func_info, Call) = Answer,
Answer = exception_analysis_answer(Result),
AnalysisStatus = optimal,
record_request(analysis_name, ModuleName, FuncId, Call, !AnalysisInfo)
).
:- pred maybe_record_exception_result(module_info::in, pred_id::in,
analysis_info::in, analysis_info::out) is det.
maybe_record_exception_result(ModuleInfo, PredId, !AnalysisInfo) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
ProcIds = pred_info_procids(PredInfo),
list.foldl(maybe_record_exception_result_2(ModuleInfo, PredId, PredInfo),
ProcIds, !AnalysisInfo).
:- pred maybe_record_exception_result_2(module_info::in, pred_id::in,
pred_info::in, proc_id::in, analysis_info::in, analysis_info::out) is det.
maybe_record_exception_result_2(ModuleInfo, PredId, PredInfo, ProcId,
!AnalysisInfo) :-
should_write_exception_info(ModuleInfo, PredId, ProcId, PredInfo,
for_analysis_framework, ShouldWrite),
(
ShouldWrite = yes,
PPId = proc(PredId, ProcId),
module_info_get_exception_info(ModuleInfo, ExceptionInfo),
lookup_proc_exception_info(ExceptionInfo, PPId, Status, ResultStatus),
module_name_func_id(ModuleInfo, PPId, ModuleName, FuncId),
record_result(ModuleName, FuncId, any_call,
exception_analysis_answer(Status), ResultStatus, !AnalysisInfo)
;
ShouldWrite = no
).
:- pred lookup_proc_exception_info(exception_info::in, pred_proc_id::in,
exception_status::out, analysis_status::out) is det.
lookup_proc_exception_info(ExceptionInfo, PPId, Status, ResultStatus) :-
( map.search(ExceptionInfo, PPId, ProcExceptionInfo) ->
ProcExceptionInfo = proc_exception_info(Status, MaybeResultStatus),
(
MaybeResultStatus = yes(ResultStatus)
;
MaybeResultStatus = no,
unexpected($module, $pred, "no result status")
)
;
% Probably an exported `:- external' procedure.
Status = may_throw(user_exception),
ResultStatus = optimal
).
:- type should_write_for
---> for_analysis_framework
; for_pragma.
:- pred should_write_exception_info(module_info::in, pred_id::in, proc_id::in,
pred_info::in, should_write_for::in, bool::out) is det.
should_write_exception_info(ModuleInfo, PredId, ProcId, PredInfo,
WhatFor, ShouldWrite) :-
(
procedure_is_exported(ModuleInfo, PredInfo, ProcId),
not is_unify_or_compare_pred(PredInfo),
(
WhatFor = for_analysis_framework
;
WhatFor = for_pragma,
module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo),
TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _),
not set.member(PredId, TypeSpecForcePreds),
%
% XXX Writing out pragmas for the automatically generated class
% instance methods causes the compiler to abort when it reads them
% back in.
%
pred_info_get_markers(PredInfo, Markers),
not check_marker(Markers, marker_class_instance_method),
not check_marker(Markers, marker_named_class_instance_method)
)
->
ShouldWrite = yes
;
ShouldWrite = no
).
:- func maybe_optimal(bool) = maybe(analysis_status).
maybe_optimal(no) = no.
maybe_optimal(yes) = yes(optimal).
%----------------------------------------------------------------------------%
%
% Stuff for intermodule optimization.
%
:- pred make_optimization_interface(module_info::in, io::di, io::uo)
is det.
make_optimization_interface(ModuleInfo, !IO) :-
module_info_get_globals(ModuleInfo, Globals),
module_info_get_name(ModuleInfo, ModuleName),
module_name_to_file_name(Globals, ModuleName, ".opt.tmp",
do_not_create_dirs, OptFileName, !IO),
globals.lookup_bool_option(Globals, verbose, Verbose),
maybe_write_string(Verbose, "% Appending exceptions 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),
module_info_get_exception_info(ModuleInfo, ExceptionInfo),
module_info_get_valid_predids(PredIds, ModuleInfo, _ModuleInfo),
list.foldl(write_pragma_exceptions(ModuleInfo, ExceptionInfo),
PredIds, !IO),
io.set_output_stream(OldStream, _, !IO),
io.close_output(OptFile, !IO),
maybe_write_string(Verbose, " done.\n", !IO)
;
OptFileRes = error(IOError),
maybe_write_string(Verbose, " failed!\n", !IO),
io.error_message(IOError, IOErrorMessage),
io.write_strings(["Error opening file `",
OptFileName, "' for output: ", IOErrorMessage], !IO),
io.set_exit_status(1, !IO)
).
write_pragma_exceptions(ModuleInfo, ExceptionInfo, PredId, !IO) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
ProcIds = pred_info_procids(PredInfo),
list.foldl(
write_pragma_exceptions_2(ModuleInfo, ExceptionInfo, PredId, PredInfo),
ProcIds, !IO).
:- pred write_pragma_exceptions_2(module_info::in, exception_info::in,
pred_id::in, pred_info::in, proc_id::in, io::di, io::uo) is det.
write_pragma_exceptions_2(ModuleInfo, ExceptionInfo, PredId, PredInfo, ProcId,
!IO) :-
should_write_exception_info(ModuleInfo, PredId, ProcId, PredInfo,
for_pragma, ShouldWrite),
(
ShouldWrite = yes,
ModuleName = pred_info_module(PredInfo),
Name = pred_info_name(PredInfo),
Arity = pred_info_orig_arity(PredInfo),
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
proc_id_to_int(ProcId, ModeNum),
( map.search(ExceptionInfo, proc(PredId, ProcId), ProcExceptionInfo) ->
ProcExceptionInfo = proc_exception_info(Status, _),
mercury_output_pragma_exceptions(PredOrFunc,
qualified(ModuleName, Name), Arity, ModeNum, Status, !IO)
;
true
)
;
ShouldWrite = no
).
%----------------------------------------------------------------------------%
%
% External interface to exception analysis information
%
lookup_exception_analysis_result(PPId, ExceptionStatus, !ModuleInfo) :-
PPId = proc(PredId, _),
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
IsImported = pred_to_bool(pred_info_is_imported_not_external(PredInfo)),
module_info_get_globals(!.ModuleInfo, Globals),
globals.lookup_bool_option(Globals, intermodule_analysis,
IntermodAnalysis),
globals.lookup_bool_option(Globals, analyse_exceptions,
ExceptionAnalysis),
% If we the procedure we are calling is imported and we are using
% intermodule-analysis then we need to look up the exception status in the
% analysis registry; otherwise we look it up in the the exception_info
% table.
UseAnalysisRegistry = IsImported `bool.and` IntermodAnalysis
`bool.and` ExceptionAnalysis,
(
% If the procedure is not imported then it's exception_status
% will be in the exception_info table.
UseAnalysisRegistry = no,
module_info_get_exception_info(!.ModuleInfo, ExceptionInfo),
(
map.search(ExceptionInfo, PPId, ProcExceptionInfo)
->
ProcExceptionInfo = proc_exception_info(ExceptionStatus, _)
;
ExceptionStatus = may_throw(user_exception)
)
;
UseAnalysisRegistry = yes,
some [!AnalysisInfo] (
module_info_get_analysis_info(!.ModuleInfo, !:AnalysisInfo),
module_name_func_id(!.ModuleInfo, PPId, ModuleName, FuncId),
lookup_best_result(!.AnalysisInfo, ModuleName, FuncId,
no_func_info, any_call, MaybeBestResult),
(
MaybeBestResult = yes(analysis_result(_Call, Answer,
AnalysisStatus)),
(
AnalysisStatus = invalid,
unexpected($module, $pred,
"invalid exception_analysis answer")
;
( AnalysisStatus = optimal
; AnalysisStatus = suboptimal
),
Answer = exception_analysis_answer(ExceptionStatus)
)
;
MaybeBestResult = no,
ExceptionStatus = may_throw(user_exception)
),
record_dependency(ModuleName, FuncId, no_func_info, any_call,
_ : exception_analysis_answer, !AnalysisInfo),
module_info_set_analysis_info(!.AnalysisInfo, !ModuleInfo)
)
).
%----------------------------------------------------------------------------%
:- end_module transform_hlds.exception_analysis.
%----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink