%-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %-----------------------------------------------------------------------------% % Copyright (C) 2004-2005 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: % - higher order stuff % - use intermodule-analysis framework % - 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. % % 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 hlds.hlds_module. :- import_module hlds.hlds_pred. :- import_module io. % Perform the exception analysis on a module. % :- pred exception_analysis.process_module(module_info::in, module_info::out, io::di, io::uo) is det. % Write out the exception pragmas for this module. % :- pred exception_analysis.write_pragma_exceptions(module_info::in, exception_info::in, pred_id::in, io::di, io::uo) is det. %----------------------------------------------------------------------------% %----------------------------------------------------------------------------% :- implementation. :- import_module check_hlds.mode_util. :- import_module check_hlds.type_util. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_pred. :- import_module hlds.make_hlds. :- import_module hlds.passes_aux. :- import_module hlds.special_pred. :- import_module libs.globals. :- import_module libs.options. :- import_module mdbcomp__prim_data. :- import_module parse_tree.error_util. :- import_module parse_tree.mercury_to_mercury. :- import_module parse_tree.modules. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_out. :- import_module parse_tree.prog_util. :- import_module parse_tree.prog_type. :- import_module transform_hlds.dependency_graph. :- import_module bool. :- import_module list. :- import_module map. :- import_module set. :- import_module std_util. :- import_module string. :- import_module term. %----------------------------------------------------------------------------% % % Perform exception analysis on a module. % exception_analysis.process_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(process_scc, SCCs, !ModuleInfo), globals.io_lookup_bool_option(make_optimization_interface, MakeOptInt, !IO), ( if MakeOptInt = yes then exception_analysis.make_opt_int(!.ModuleInfo, !IO) else true ). %----------------------------------------------------------------------------% % % 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, 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. ). :- pred process_scc(scc::in, module_info::in, module_info::out) is det. process_scc(SCC, !ModuleInfo) :- ProcResults = check_procs_for_exceptions(SCC, !.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. % Status = combine_individual_proc_results(ProcResults), % % Update the exception info. 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) := Status ), list.foldl(Update, SCC, ExceptionInfo0, ExceptionInfo), module_info_set_exception_info(ExceptionInfo, !ModuleInfo). % Check each procedure in the SCC individually. % :- func check_procs_for_exceptions(scc, module_info) = proc_results. check_procs_for_exceptions(SCC, ModuleInfo) = Result :- list.foldl(check_proc_for_exceptions(SCC, ModuleInfo), SCC, [], Result). % Examine how the procedures interact with other procedures that % are mutually-recursive to them. % :- func combine_individual_proc_results(proc_results) = exception_status. combine_individual_proc_results([]) = _ :- unexpected(this_file, "Empty SCC during exception analysis."). combine_individual_proc_results(ProcResults @ [_|_]) = SCC_Result :- ( % 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 = 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) ). %----------------------------------------------------------------------------% % % Process individual procedures. % :- pred check_proc_for_exceptions(scc::in, module_info::in, pred_proc_id::in, proc_results::in, proc_results::out) is det. check_proc_for_exceptions(SCC, ModuleInfo, PPId, !Results) :- module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo), proc_info_goal(ProcInfo, Body), proc_info_vartypes(ProcInfo, VarTypes), Result0 = proc_result(PPId, will_not_throw, type_will_not_throw), check_goal_for_exceptions(SCC, ModuleInfo, VarTypes, Body, Result0, Result), list.cons(Result, !Results). :- pred check_goal_for_exceptions(scc::in, module_info::in, vartypes::in, hlds_goal::in, proc_result::in, proc_result::out) is det. check_goal_for_exceptions(SCC, ModuleInfo, VarTypes, Goal - GoalInfo, !Result) :- ( goal_info_get_determinism(GoalInfo, erroneous) -> !:Result = !.Result ^ status := may_throw(user_exception) ; check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, Goal, GoalInfo, !Result) ). :- pred check_goal_for_exceptions_2(scc::in, module_info::in, vartypes::in, hlds_goal_expr::in, hlds_goal_info::in, proc_result::in, proc_result::out) is det. check_goal_for_exceptions_2(_, _, _, Goal, _, !Result) :- Goal = unify(_, _, _, Kind, _), ( Kind = complicated_unify(_, _, _) -> unexpected(this_file, "complicated unify during exception analysis.") ; true ). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, Goal, _, !Result) :- Goal = call(CallPredId, CallProcId, CallArgs, _, _, _), 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 = !.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 = 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. check_vars(ModuleInfo, VarTypes, CallArgs, !Result) ; check_nonrecursive_call(ModuleInfo, VarTypes, CallPPId, CallArgs, !Result) ). check_goal_for_exceptions_2(_, ModuleInfo, VarTypes, Goal, GoalInfo, !Result) :- Goal = generic_call(Details, Args, _ArgModes, _), ( Details = higher_order(Var, _, _, _), ClosureValueMap = goal_info_get_ho_values(GoalInfo), ( ClosureValues = ClosureValueMap ^ elem(Var) -> ( get_conditional_closures(ModuleInfo, ClosureValues, Conditional) -> ( Conditional = [] % The possible values of the higher-order variable % are all procedures that are known not to throw % exceptions. ; Conditional = [_|_], % % 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, !Result) ) ; !:Result = !.Result ^ status := may_throw(user_exception) ) ; !:Result = !.Result ^ status := may_throw(user_exception) ) ; % XXX We could do better with class methods. Details = class_method(_, _, _, _), !:Result = !.Result ^ status := may_throw(user_exception) ; Details = cast(_) ; Details = aditi_builtin(_, _), !:Result = !.Result ^ status := may_throw(user_exception) ). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, not(Goal), _, !Result) :- check_goal_for_exceptions(SCC, ModuleInfo, VarTypes, Goal, !Result). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, Goal, _, !Result) :- Goal = scope(_, ScopeGoal), check_goal_for_exceptions(SCC, ModuleInfo, VarTypes, ScopeGoal, !Result). check_goal_for_exceptions_2(_, _, _, Goal, _, !Result) :- Goal = foreign_proc(Attributes, _, _, _, _, _), ( may_call_mercury(Attributes) = may_call_mercury -> 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 = !.Result ^ status := may_throw(user_exception) ; true ) ; true ). check_goal_for_exceptions_2(_, _, _, shorthand(_), _, _, _) :- unexpected(this_file, "shorthand goal encountered during exception analysis."). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, Goal, _, !Result) :- Goal = switch(_, _, Cases), CaseGoals = list.map((func(case(_, CaseGoal)) = CaseGoal), Cases), check_goals_for_exceptions(SCC, ModuleInfo, VarTypes, CaseGoals, !Result). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, Goal, _, !Result) :- Goal = if_then_else(_, If, Then, Else), check_goals_for_exceptions(SCC, ModuleInfo, VarTypes, [If, Then, Else], !Result). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, disj(Goals), _, !Result) :- check_goals_for_exceptions(SCC, ModuleInfo, VarTypes, Goals, !Result). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, par_conj(Goals), _, !Result) :- check_goals_for_exceptions(SCC, ModuleInfo, VarTypes, Goals, !Result). check_goal_for_exceptions_2(SCC, ModuleInfo, VarTypes, conj(Goals), _, !Result) :- check_goals_for_exceptions(SCC, ModuleInfo, VarTypes, Goals, !Result). :- pred check_goals_for_exceptions(scc::in, module_info::in, vartypes::in, hlds_goals::in, proc_result::in, proc_result::out) is det. check_goals_for_exceptions(_, _, _, [], !Result). check_goals_for_exceptions(SCC, ModuleInfo, VarTypes, [ Goal | Goals ], !Result) :- check_goal_for_exceptions(SCC, ModuleInfo, VarTypes, Goal, !Result), % % 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. % ( if !.Result ^ status = may_throw(user_exception) then true else check_goals_for_exceptions(SCC, ModuleInfo, VarTypes, Goals, !Result) ). %----------------------------------------------------------------------------% % % Further code to handle higher-order variables % % Given a list of procedure ids extract those whose exception status % has been set to 'conditional'. Fails if one of the procedures in % the set has an exception status that indicates it may throw an % exception, or if the exception status for a procedure has not yet % been set. % :- pred get_conditional_closures(module_info::in, set(pred_proc_id)::in, list(pred_proc_id)::out) is semidet. get_conditional_closures(ModuleInfo, Closures, Conditionals) :- module_info_get_exception_info(ModuleInfo, ExceptionInfo), set.fold(get_conditional_closure(ExceptionInfo), Closures, [], Conditionals). :- pred get_conditional_closure(exception_info::in, pred_proc_id::in, list(pred_proc_id)::in, list(pred_proc_id)::out) is semidet. get_conditional_closure(ExceptionInfo, PPId, !Conditionals) :- ExceptionInfo ^ elem(PPId) = Status, ( Status = conditional, list.cons(PPId, !Conditionals) ; Status = will_not_throw ). %----------------------------------------------------------------------------% :- pred update_proc_result(exception_status::in, proc_result::in, proc_result::out) is det. update_proc_result(CurrentStatus, !Result) :- OldStatus = !.Result ^ status, NewStatus = combine_exception_status(CurrentStatus, OldStatus), !:Result = !.Result ^ status := NewStatus. :- 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), conditional) = X. combine_exception_status(may_throw(type_exception), Y @ may_throw(_)) = Y. combine_exception_status(conditional, conditional) = conditional. combine_exception_status(conditional, will_not_throw) = conditional. combine_exception_status(conditional, Y @ may_throw(_)) = Y. %----------------------------------------------------------------------------% % % Extra procedures for handling calls. % :- pred check_nonrecursive_call(module_info::in, vartypes::in, pred_proc_id::in, prog_vars::in, proc_result::in, proc_result::out) is det. check_nonrecursive_call(ModuleInfo, VarTypes, PPId, Args, !Result) :- module_info_get_exception_info(ModuleInfo, ExceptionInfo), ( map.search(ExceptionInfo, PPId, CalleeExceptionStatus) -> ( CalleeExceptionStatus = will_not_throw ; CalleeExceptionStatus = may_throw(ExceptionType), update_proc_result(may_throw(ExceptionType), !Result) ; CalleeExceptionStatus = conditional, check_vars(ModuleInfo, VarTypes, Args, !Result) ) ; % If we do not have any information about the callee procedure % then assume that it might throw an exception. update_proc_result(may_throw(user_exception), !Result) ). :- pred check_vars(module_info::in, vartypes::in, prog_vars::in, proc_result::in, proc_result::out) is det. check_vars(ModuleInfo, VarTypes, Vars, !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), !Result) ; TypeStatus = type_conditional, update_proc_result(conditional, !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 -> 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((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, (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, (type)) = type_status. check_type(ModuleInfo, Type) = Status :- ( ( type_util.is_solver_type(ModuleInfo, Type) ; type_util.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 = type_util.classify_type(ModuleInfo, Type), Status = check_type_2(ModuleInfo, Type, TypeCategory) ). :- func check_type_2(module_info, (type), type_category) = type_status. check_type_2(_, _, int_type) = type_will_not_throw. check_type_2(_, _, char_type) = type_will_not_throw. check_type_2(_, _, str_type) = type_will_not_throw. check_type_2(_, _, float_type) = type_will_not_throw. check_type_2(_, _, higher_order_type) = type_will_not_throw. check_type_2(_, _, type_info_type) = type_will_not_throw. check_type_2(_, _, type_ctor_info_type) = type_will_not_throw. check_type_2(_, _, typeclass_info_type) = type_will_not_throw. check_type_2(_, _, base_typeclass_info_type) = type_will_not_throw. check_type_2(_, _, void_type) = type_will_not_throw. check_type_2(_, _, dummy_type) = type_will_not_throw. check_type_2(_, _, variable_type) = type_conditional. check_type_2(ModuleInfo, Type, tuple_type) = check_user_type(ModuleInfo, Type). check_type_2(ModuleInfo, Type, enum_type) = check_user_type(ModuleInfo, Type). check_type_2(ModuleInfo, Type, user_ctor_type) = check_user_type(ModuleInfo, Type). :- func check_user_type(module_info, (type)) = type_status. check_user_type(ModuleInfo, Type) = Status :- ( type_to_ctor_and_args(Type, _TypeCtor, Args) -> ( type_has_user_defined_equality_pred(ModuleInfo, Type, _UnifyCompare) -> % 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. Status = type_may_throw ; Status = check_types(ModuleInfo, Args) ) ; unexpected(this_file, "Unable to get ctor and args.") ). %----------------------------------------------------------------------------% % % Stuff for intermodule optimization. % :- pred exception_analysis.make_opt_int(module_info::in, io::di, io::uo) is det. exception_analysis.make_opt_int(ModuleInfo, !IO) :- module_info_get_name(ModuleInfo, ModuleName), module_name_to_file_name(ModuleName, ".opt.tmp", no, OptFileName, !IO), globals.io_lookup_bool_option(verbose, Verbose, !IO), maybe_write_string(Verbose, "% 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_predids(ModuleInfo, PredIds), 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), pred_info_import_status(PredInfo, ImportStatus), ( ( ImportStatus = exported ; ImportStatus = opt_exported ), not is_unify_or_compare_pred(PredInfo), 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, class_instance_method), not check_marker(Markers, named_class_instance_method) -> ModuleName = pred_info_module(PredInfo), Name = pred_info_name(PredInfo), Arity = pred_info_orig_arity(PredInfo), PredOrFunc = pred_info_is_pred_or_func(PredInfo), ProcIds = pred_info_procids(PredInfo), % % XXX The termination analyser outputs pragmas even if % it doesn't have any information - should we be doing % this? % list.foldl((pred(ProcId::in, !.IO::di, !:IO::uo) is det :- proc_id_to_int(ProcId, ModeNum), ( map.search(ExceptionInfo, proc(PredId, ProcId), Status) -> mercury_output_pragma_exceptions(PredOrFunc, qualified(ModuleName, Name), Arity, ModeNum, Status, !IO) ; true )), ProcIds, !IO) ; true ). %----------------------------------------------------------------------------% :- func this_file = string. this_file = "exception_analysis.m". %----------------------------------------------------------------------------% :- end_module exception_analysis. %----------------------------------------------------------------------------%