[m-rev.] for review: exception analysis

[Julien Fischer]

For review by anyone.
(I posted a version of this earlier this year - there are a couple
 of changes since then that are mainly related to the handling of
 existentially quantified types).

Estimated hours taken: 70
Branches: main

Add an analysis that tries to identify those procedures
in a module that will not throw an exception.
(I guess it may be more accurate to call it a non-exception analysis).

For those procedures that might throw exceptions the
analysis further tries to distinguish between those
that throw an exception as a result of a call to throw
and those that throw an exception as a result of a
call to a unification/comparison predicate that may involve
calls to user-defined equality/comparison predicates that throw
exceptions.

This sort of thing used to be done by the termination analysis,
where being able to prove termination was equated with not
throwing an exception.  This no longer works now that
the termination analyser considers exception.throw/1 to
be terminating - and in fact it never quite worked anyway
because the termination analyser was not handling things
like foreign code and user-defined equality and comparison
predicates correctly.

There are currently a few limitations, the main ones being:

* we currently use transitive-intermodule optimization rather
  than the intermodule-analysis framework.  This may causes
  problems when their are cycles in the module dependency graph.

* we currently assume that all calls to higher-order predicates
  may result in an exception being thrown.

* we currently assume that all foreign procs that make calls
  back to Mercury may throw exceptions.

* we currently assume that all solver types and existentially
  quantified types might result in an exception being thrown.

It should be possible to remove these limitations in later
versions.

This diff also modifies the cannot_loop_or_throw family of
predicates in goal_form.m.  There are now two versions of each
predicate; one that can make use of information from the
termination and exception analyses and one that cannot.

compiler/exception_analysis.m:
	The new analysis.

compiler/prog_data.m:
compiler/prog_io_pragma.m:
	Handle `:- pragma exceptions(...' in .opt and .trans_opt files.

compiler/hlds_module.m:
	Attach information to each module about whether each procedure
	in the module may throw an exception.

compiler/goal_form.m:
	Rewrite the predicates in this module so that they can
	optionally use information from the exception analysis.

compiler/constraint.m:
compiler/goal_util.m:
compiler/rl.m:
compiler/simplify.m:
	Use information from exception and termination analyses
	when performing various optimizations.

compiler/type_util.m:
	Add a new predicate type_util.type_is_existq/2 that tests
	whether a type is existentially quantified or not.

compiler/mercury_compile.m:
compiler/mercury_to_mercury.m:
compiler/modules.m:
compiler/options.m:
compiler/module_qual.m:
compiler/make_hlds.m:
compiler/recompilation.version.m:
compiler/trans_opt.m:
compiler/transform_hlds.m:
	Minor changes needed by the above.

NEWS:
compiler/notes/compiler_design.html:
doc/user_guide.texi:
	Mention the new analysis.

tests/README:
	Include a description of the term directory.

tests/term/Mercury.options:
tests/term/Mmakefile:
tests/term/exception_analysis_test.m:
tests/term/exception_analysis_test.trans_opt_exp:
	Add a test for the new analysis.

Julien.


Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.343
diff -u -r1.343 NEWS
--- NEWS	29 Sep 2004 05:37:36 -0000	1.343
+++ NEWS	29 Sep 2004 08:14:46 -0000
@@ -25,6 +25,9 @@
   code.
 * It's now easier to use shared libraries on Linux/x86 systems
   with `mmc --make'.
+* A new analysis: `--analyse-exceptions'.
+  The compiler can use the results of this analysis to try and improve
+  some optimizations.

 Changes to the Mercury standard library:
 * We've added several new modules: cord, for sequences with O(1) consing and
@@ -317,6 +320,10 @@
   location of the standard library (MERCURY_ALL_C_INCL_DIRS,
   MERCURY_ALL_MC_C_INCL_DIRS, MERCURY_INT_DIR, MERCURY_C_LIB_DIR,
   MERCURY_MOD_LIB_MODS, MERCURY_TRACE_LIB_MODS) have been removed.
+
+* There is a new analysis: `--analyse-exceptions'.  This identifies
+  predicates that will not throw an exception.  This information is
+  made available to the optimizing passes of the compiler.

 Portability improvements:

Index: compiler/constraint.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/constraint.m,v
retrieving revision 1.57
diff -u -r1.57 constraint.m
--- compiler/constraint.m	7 Sep 2004 07:42:54 -0000	1.57
+++ compiler/constraint.m	24 Sep 2004 07:24:58 -0000
@@ -413,8 +413,8 @@
 		% Don't propagate impure goals.
 		goal_info_is_pure(GoalInfo),

-		% Don't propagate goals that can loop.
-		goal_cannot_loop_or_throw(Goal)
+		% Don't propagate goals that can loop.
+		goal_cannot_loop_or_throw(ModuleInfo, Goal)
 	->
 		% It's a constraint, add it to the list of constraints
 		% to be attached to goals earlier in the conjunction.
@@ -470,7 +470,7 @@
 	;
 		% Don't move goals which can fail before a goal which
 		% can loop if `--fully-strict' is set.
-		\+ goal_cannot_loop_or_throw(Goal),
+		\+ goal_cannot_loop_or_throw(ModuleInfo, Goal),
 		module_info_globals(ModuleInfo, Globals),
 		globals__lookup_bool_option(Globals, fully_strict, yes)
 	->
Index: compiler/exception_analysis.m
===================================================================
RCS file: compiler/exception_analysis.m
diff -N compiler/exception_analysis.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/exception_analysis.m	1 Oct 2004 06:12:02 -0000
@@ -0,0 +1,687 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2004 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
+%	- annotations for foreign_procs
+% 	- 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 they 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 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 transform_hlds.dependency_graph.
+
+:- import_module bool, list, map, set, std_util, string, term, term_io, varset.
+
+%----------------------------------------------------------------------------%
+%
+% Perform exception analysis on a module.
+%
+
+exception_analysis.process_module(!Module, !IO) :-
+	module_info_ensure_dependency_info(!Module),
+	module_info_dependency_info(!.Module, DepInfo),
+	hlds_dependency_info_get_dependency_ordering(DepInfo, SCCs),
+	list.foldl(process_scc, SCCs, !Module),
+	globals.io_lookup_bool_option(make_optimization_interface,
+		MakeOptInt, !IO),
+	( if	MakeOptInt = yes
+	  then	exception_analysis.make_opt_int(!.Module, !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, !Module) :-
+	ProcResults = check_procs_for_exceptions(SCC, !.Module),
+	%
+	% 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_exception_info(!.Module, 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, !Module).
+
+	% Check each procedure in the SCC individually.
+	%
+:- func check_procs_for_exceptions(scc, module_info) = proc_results.
+
+check_procs_for_exceptions(SCC, Module) = Result :-
+	list.foldl(check_proc_for_exceptions(SCC, Module), 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, Module, PPId, !Results) :-
+	module_info_pred_proc_info(Module, 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, Module, 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, Module, VarTypes, Goal - GoalInfo,
+		!Result) :-
+	( goal_info_get_determinism(GoalInfo, erroneous) ->
+		!:Result = !.Result ^ status := may_throw(user_exception)
+	;
+		check_goal_for_exceptions_2(SCC, Module, VarTypes, Goal,
+			!Result)
+	).
+
+:- pred check_goal_for_exceptions_2(scc::in, module_info::in, vartypes::in,
+	hlds_goal_expr::in, proc_result::in, proc_result::out) is det.
+
+check_goal_for_exceptions_2(_, _, _, unify(_, _, _, Kind, _), !Result) :-
+	( Kind = complicated_unify(_, _, _) ->
+		unexpected(this_file,
+			"complicated unify during exception analysis.")
+	;
+		true
+	).
+check_goal_for_exceptions_2(SCC, Module, VarTypes,
+		call(CallPredId, CallProcId, CallArgs, _, _, _), !Result) :-
+	CallPPId = proc(CallPredId, CallProcId),
+	module_info_pred_info(Module, CallPredId, CallPredInfo),
+	(
+		% Handle (mutually-)recursive calls.
+		list.member(CallPPId, SCC)
+	->
+		Types = list.map((func(Var) = VarTypes ^ det_elem(Var)),
+			CallArgs),
+		TypeStatus = check_types(Module, 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_arity(CallPredInfo),
+			( SpecialPredId = compare
+			; SpecialPredId = unify ),
+			special_pred_name_arity(SpecialPredId, Name,
+				Arity)
+		;
+			pred_info_get_maybe_special_pred(CallPredInfo,
+				MaybeSpecial),
+			MaybeSpecial = yes(SpecialPredId - _),
+			( SpecialPredId = compare
+			; SpecialPredId = 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(Module, VarTypes, CallArgs, !Result)
+	;
+		check_nonrecursive_call(Module, VarTypes, CallPPId, CallArgs,
+			!Result)
+	).
+check_goal_for_exceptions_2(_, _, _, generic_call(_,_,_,_), !Result) :-
+	!:Result = !.Result ^ status := may_throw(user_exception).
+check_goal_for_exceptions_2(SCC, Module, VarTypes, not(Goal), !Result) :-
+	check_goal_for_exceptions(SCC, Module, VarTypes, Goal, !Result).
+check_goal_for_exceptions_2(SCC, Module, VarTypes, some(_, _, Goal),
+		!Result) :-
+	check_goal_for_exceptions(SCC, Module, VarTypes, Goal, !Result).
+
+	% XXX We could provide  annotations for foreign procs here.
+	% Currently we only consider foreign_procs that do not call Mercury
+	% as not throwing exceptions.
+check_goal_for_exceptions_2(_, _, _,
+		foreign_proc(Attributes, _, _, _, _, _), !Result) :-
+	( if 	may_call_mercury(Attributes) = may_call_mercury
+	  then	!:Result = !.Result ^ status := may_throw(user_exception)
+	  else	true
+	).
+check_goal_for_exceptions_2(_, _, _, shorthand(_), _, _) :-
+	unexpected(this_file,
+		"shorthand goal encountered during exception analysis.").
+check_goal_for_exceptions_2(SCC, Module, VarTypes, switch(_, _, Cases),
+		!Result) :-
+	Goals = list.map((func(case(_, Goal)) = Goal), Cases),
+	check_goals_for_exceptions(SCC, Module, VarTypes, Goals, !Result).
+check_goal_for_exceptions_2(SCC, Module, VarTypes,
+		if_then_else(_, If, Then, Else), !Result) :-
+	check_goals_for_exceptions(SCC, Module, VarTypes, [If, Then, Else],
+		!Result).
+check_goal_for_exceptions_2(SCC, Module, VarTypes, disj(Goals), !Result) :-
+	check_goals_for_exceptions(SCC, Module, VarTypes, Goals, !Result).
+check_goal_for_exceptions_2(SCC, Module, VarTypes, par_conj(Goals), !Result) :-
+	check_goals_for_exceptions(SCC, Module, VarTypes, Goals, !Result).
+check_goal_for_exceptions_2(SCC, Module, VarTypes, conj(Goals), !Result) :-
+	check_goals_for_exceptions(SCC, Module, 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, Module, VarTypes, [ Goal | Goals ], !Result) :-
+	check_goal_for_exceptions(SCC, Module, 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, Module, VarTypes, Goals,
+			!Result)
+	).
+
+%----------------------------------------------------------------------------%
+
+:- 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(Module, VarTypes, PPId, Args, !Result) :-
+	module_info_exception_info(Module, 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(Module, 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(Module, VarTypes, Vars, !Result) :-
+	Types = list.map((func(Var) = VarTypes ^ det_elem(Var)), Vars),
+	TypeStatus = check_types(Module, 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
+% affect 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(Module, Types) = Status :-
+	list.foldl(check_type(Module), Types, type_will_not_throw, Status).
+
+:- pred check_type(module_info::in, (type)::in, type_status::in,
+	type_status::out) is det.
+
+check_type(Module, Type, !Status) :-
+	combine_type_status(check_type(Module, 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(Module, Type) = Status :-
+	(
+		( type_util.is_solver_type(Module, Type)
+	  	; type_util.is_existq_type(Module, 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(Module, Type),
+		Status = check_type_2(Module, 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(_, _, variable_type) = type_conditional.
+
+check_type_2(Module, Type, tuple_type) = check_user_type(Module, Type).
+check_type_2(Module, Type, enum_type)  = check_user_type(Module, Type).
+check_type_2(Module, Type, user_ctor_type) = check_user_type(Module, Type).
+
+:- func check_user_type(module_info, (type)) = type_status.
+
+check_user_type(Module, Type) = Status :-
+	( type_to_ctor_and_args(Type, _TypeCtor, Args) ->
+		(
+			type_has_user_defined_equality_pred(Module, 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(Module, 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(Module, !IO) :-
+	module_info_name(Module, 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_exception_info(Module, ExceptionInfo),
+		module_info_predids(Module, PredIds),
+		list.foldl(write_pragma_exceptions(Module, 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(Module, ExceptionInfo, PredId, !IO) :-
+	module_info_pred_info(Module, PredId, PredInfo),
+	pred_info_import_status(PredInfo, ImportStatus),
+	(
+		( ImportStatus = exported
+		; ImportStatus = opt_exported
+		),
+		not is_unify_or_compare_pred(PredInfo),
+		module_info_type_spec_info(Module, 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_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.
+%----------------------------------------------------------------------------%
Index: compiler/goal_form.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_form.m,v
retrieving revision 1.10
diff -u -r1.10 goal_form.m
--- compiler/goal_form.m	14 Jun 2004 04:16:04 -0000	1.10
+++ compiler/goal_form.m	14 Jun 2004 23:26:57 -0000
@@ -21,16 +21,38 @@

 :- import_module list.

+%
+% The first three versions may be more accurate because they can use
+% results of the termination and exception analyses.
+%
+
 	% Succeeds if the goal cannot loop forever.
 :- pred goal_cannot_loop(module_info::in, hlds_goal::in) is semidet.
-
-	% Succeeds if the goal cannot loop forever or throw an exception.
-:- pred goal_cannot_loop_or_throw(hlds_goal::in) is semidet.
-
+
 	% Succeeds if the goal can loop forever.
 :- pred goal_can_loop(module_info::in, hlds_goal::in) is semidet.

+	% Succeeds if the goal cannot throw an exception.
+:- pred goal_cannot_throw(module_info::in, hlds_goal::in) is semidet.
+
+	% Succeeds if the goal can throw an exception.
+:- pred goal_can_throw(module_info::in, hlds_goal::in) is semidet.
+
+	% Succeeds if the goal cannot loop forever or throw an exception.
+:- pred goal_cannot_loop_or_throw(module_info::in, hlds_goal::in) is semidet.
+
 	% Succeeds if the goal can loop forever or throw an exception.
+:- pred goal_can_loop_or_throw(module_info::in, hlds_goal::in) is semidet.
+
+%
+% These versions do not use the results of the termination or exception
+% analyses.
+%
+
+	% Succeeds if the goal cannot loop forever or throw an exception.
+:- pred goal_cannot_loop_or_throw(hlds_goal::in) is semidet.
+
+	% Succeed if the goal can loop forever or throw an exception.
 :- pred goal_can_loop_or_throw(hlds_goal::in) is semidet.

 	% contains_only_builtins(G) is true if G is a leaf procedure,
@@ -98,22 +120,35 @@
 :- import_module parse_tree__prog_data.
 :- import_module transform_hlds__term_util.

-:- import_module bool, int, std_util, require.
+:- import_module bool, int, map, std_util, require.

 %-----------------------------------------------------------------------------%

+goal_cannot_loop(ModuleInfo, Goal) :-
+	goal_cannot_loop_aux(yes(ModuleInfo), Goal).
+
 goal_can_loop(ModuleInfo, Goal) :-
 	\+ goal_cannot_loop(ModuleInfo, Goal).

-goal_can_loop_or_throw(Goal) :-
-	\+ goal_cannot_loop_or_throw(Goal).
+goal_cannot_throw(ModuleInfo, Goal) :-
+	goal_cannot_throw_aux(yes(ModuleInfo), Goal).

-goal_cannot_loop(ModuleInfo, Goal) :-
-	goal_cannot_loop_aux(yes(ModuleInfo), Goal).
+goal_can_throw(ModuleInfo, Goal) :-
+	not goal_cannot_throw(ModuleInfo, Goal).
+
+goal_cannot_loop_or_throw(ModuleInfo, Goal) :-
+	goal_cannot_loop_aux(yes(ModuleInfo), Goal),
+	goal_cannot_throw_aux(yes(ModuleInfo), Goal).
+
+goal_can_loop_or_throw(ModuleInfo, Goal) :-
+	not goal_cannot_loop_or_throw(ModuleInfo, Goal).

 goal_cannot_loop_or_throw(Goal) :-
 	goal_cannot_loop_aux(no, Goal).

+goal_can_loop_or_throw(Goal) :-
+	\+ goal_cannot_loop_or_throw(Goal).
+
 :- pred goal_cannot_loop_aux(maybe(module_info)::in, hlds_goal::in) is semidet.

 goal_cannot_loop_aux(MaybeModuleInfo, Goal) :-
@@ -151,6 +186,54 @@
 	proc_info_get_maybe_termination_info(ProcInfo, MaybeTermInfo),
 	MaybeTermInfo = yes(cannot_loop).
 goal_cannot_loop_expr(_, unify(_, _, _, Uni, _)) :-
+	(
+		Uni = assign(_, _)
+	;
+		Uni = simple_test(_, _)
+	;
+		Uni = construct(_, _, _, _, _, _, _)
+	;
+		Uni = deconstruct(_, _, _, _, _, _)
+	).
+		% Complicated unifies are _non_builtin_
+
+%-----------------------------------------------------------------------------%
+
+goal_cannot_throw(ModuleInfo, Goal) :-
+	goal_cannot_throw_aux(yes(ModuleInfo), Goal).
+
+:- pred goal_cannot_throw_aux(maybe(module_info)::in,
+		hlds_goal::in) is semidet.
+
+goal_cannot_throw_aux(MaybeModuleInfo, GoalExpr - _) :-
+	goal_cannot_throw_expr(MaybeModuleInfo, GoalExpr).
+
+:- pred goal_cannot_throw_expr(maybe(module_info)::in,
+		hlds_goal_expr::in) is semidet.
+
+goal_cannot_throw_expr(MaybeModuleInfo, conj(Goals)) :-
+	list.member(Goal, Goals) =>
+		goal_cannot_throw_aux(MaybeModuleInfo, Goal).
+goal_cannot_throw_expr(MaybeModuleInfo, disj(Goals)) :-
+	list.member(Goal, Goals) =>
+		goal_cannot_throw_aux(MaybeModuleInfo, Goal).
+goal_cannot_throw_expr(MaybeModuleInfo, switch(_Var, _Category, Cases)) :-
+	list.member(case(_, Goal), Cases) =>
+		goal_cannot_throw_aux(MaybeModuleInfo, Goal).
+goal_cannot_throw_expr(MaybeModuleInfo, not(Goal)) :-
+	goal_cannot_throw_aux(MaybeModuleInfo, Goal).
+goal_cannot_throw_expr(MaybeModuleInfo, some(_Vars, _, Goal)) :-
+	goal_cannot_throw_aux(MaybeModuleInfo, Goal).
+goal_cannot_throw_expr(MaybeModuleInfo, if_then_else(_, Cond, Then, Else)) :-
+	goal_cannot_throw_aux(MaybeModuleInfo, Cond),
+	goal_cannot_throw_aux(MaybeModuleInfo, Then),
+	goal_cannot_throw_aux(MaybeModuleInfo, Else).
+goal_cannot_loop_expr(MaybeModuleInfo,
+		call(PredId, ProcId, _, _, _, _)) :-
+	MaybeModuleInfo = yes(ModuleInfo),
+	module_info_exception_info(ModuleInfo, ExceptionInfo),
+	map.search(ExceptionInfo, proc(PredId, ProcId), will_not_throw).
+goal_cannot_throw_expr(_, unify(_, _, _, Uni, _)) :-
 	(
 		Uni = assign(_, _)
 	;
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.97
diff -u -r1.97 goal_util.m
--- compiler/goal_util.m	20 Jul 2004 04:40:58 -0000	1.97
+++ compiler/goal_util.m	27 Aug 2004 08:47:10 -0000
@@ -1158,7 +1158,7 @@
 		InstmapBeforeLaterGoal, VarTypes, ModuleInfo).


-goal_util__reordering_maintains_termination(_ModuleInfo, FullyStrict,
+goal_util__reordering_maintains_termination(ModuleInfo, FullyStrict,
 		EarlierGoal, LaterGoal) :-
 	EarlierGoal = _ - EarlierGoalInfo,
 	LaterGoal = _ - LaterGoalInfo,
@@ -1182,7 +1182,7 @@
 		% (can_loop, can_fail), since this could worsen
 		% the termination properties of the program.
 	( EarlierCanFail = can_fail ->
-		goal_cannot_loop_or_throw(LaterGoal)
+		goal_cannot_loop_or_throw(ModuleInfo, LaterGoal)
 	;
 		true
 	).
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.102
diff -u -r1.102 hlds_module.m
--- compiler/hlds_module.m	5 Sep 2004 23:52:05 -0000	1.102
+++ compiler/hlds_module.m	24 Sep 2004 07:25:00 -0000
@@ -85,6 +85,10 @@
 	% map from proc to a list of unused argument numbers.
 :- type unused_arg_info == map(pred_proc_id, list(int)).

+	% Map from proc to an indication of whether or not it
+	% might throw an exception.
+:- type exception_info == map(pred_proc_id, exception_status).
+
 	% List of procedures for which there are user-requested type
 	% specializations, and a list of predicates which should be
 	% processed by higher_order.m to ensure the production of those
@@ -297,12 +301,18 @@
 :- pred module_info_unused_arg_info(module_info::in, unused_arg_info::out)
 	is det.

+:- pred module_info_exception_info(module_info::in, exception_info::out)
+	is det.
+
 :- pred module_info_set_proc_requests(proc_requests::in,
 	module_info::in, module_info::out) is det.

 :- pred module_info_set_unused_arg_info(unused_arg_info::in,
 	module_info::in, module_info::out) is det.

+:- pred module_info_set_exception_info(exception_info::in,
+	module_info::in, module_info::out) is det.
+
 :- pred module_info_set_num_errors(int::in, module_info::in, module_info::out)
 	is det.

@@ -523,6 +533,12 @@
 						% module which has been
 						% exported in .opt files.

+		exception_info			:: exception_info,
+						% exception information about
+						% procedures in the current
+						% module (this includes
+						% opt_imported procedures).
+
 		lambda_number_counter		:: counter,

 		model_non_pragma_counter	:: counter,
@@ -578,6 +594,7 @@
 	map__init(Ctors),
 	set__init(StratPreds),
 	map__init(UnusedArgInfo),
+	map__init(ExceptionInfo),

 	set__init(TypeSpecPreds),
 	set__init(TypeSpecForcePreds),
@@ -600,10 +617,10 @@
 	map__init(FieldNameTable),

 	map__init(NoTagTypes),
-	ModuleSubInfo = module_sub(Name, Globals, no, [], [], [], [], no, 0,
-		[], [], StratPreds, UnusedArgInfo, counter__init(1),
-		counter__init(1), ImportedModules, IndirectlyImportedModules,
-		no_aditi_compilation, TypeSpecInfo,
+	ModuleSubInfo = module_sub(Name, Globals, no, [], [], [], [], no, 0,
+		[], [], StratPreds, UnusedArgInfo, ExceptionInfo,
+		counter__init(1), counter__init(1), ImportedModules,
+		IndirectlyImportedModules, no_aditi_compilation, TypeSpecInfo,
 		NoTagTypes, init_analysis_info(mmc)),
 	ModuleInfo = module(ModuleSubInfo, PredicateTable, Requests,
 		UnifyPredMap, QualifierInfo, Types, Insts, Modes, Ctors,
@@ -673,6 +690,7 @@
 module_info_type_ctor_gen_infos(MI, MI ^ sub_info ^ type_ctor_gen_infos).
 module_info_stratified_preds(MI, MI ^ sub_info ^ must_be_stratified_preds).
 module_info_unused_arg_info(MI, MI ^ sub_info ^ unused_arg_info).
+module_info_exception_info(MI, MI ^ sub_info ^ exception_info).
 module_info_get_lambda_counter(MI, MI ^ sub_info ^ lambda_number_counter).
 module_info_get_model_non_pragma_counter(MI,
 	MI ^ sub_info ^ model_non_pragma_counter).
@@ -713,6 +731,8 @@
 	MI ^ sub_info ^ must_be_stratified_preds := NewVal).
 module_info_set_unused_arg_info(NewVal, MI,
 	MI ^ sub_info ^ unused_arg_info := NewVal).
+module_info_set_exception_info(NewVal, MI,
+	MI ^ sub_info ^ exception_info := NewVal).
 module_info_set_lambda_counter(NewVal, MI,
 	MI ^ sub_info ^ lambda_number_counter := NewVal).
 module_info_set_model_non_pragma_counter(NewVal, MI,
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.480
diff -u -r1.480 make_hlds.m
--- compiler/make_hlds.m	10 Sep 2004 03:36:12 -0000	1.480
+++ compiler/make_hlds.m	24 Sep 2004 07:25:02 -0000
@@ -757,6 +757,18 @@
 				ModeNum, UnusedArgs, Context, !Module, !IO)
 		)
 	;
+		Pragma = exceptions(PredOrFunc, SymName, Arity, ModeNum,
+			ThrowStatus),
+		( ImportStatus \= opt_imported ->
+			prog_out.write_context(Context, !IO),
+			io.write_string("Error: illegal use of pragma " ++
+				"`exceptions'.\n", !IO),
+			module_info_incr_errors(!Module)
+		;
+			add_pragma_exceptions(PredOrFunc, SymName, Arity,
+				ModeNum, ThrowStatus, Context, !Module, !IO)
+		)
+	;
 		% Handle pragma type_spec decls later on (when we process
 		% clauses).
 		Pragma = type_spec(_, _, _, _, _, _, _, _)
@@ -1486,6 +1498,36 @@
 		io__write_string("Internal compiler error: " ++
 			"unknown predicate in `pragma unused_args'.\n", !IO),
 		module_info_incr_errors(!Module)
+	).
+
+%-----------------------------------------------------------------------------%
+
+:- pred add_pragma_exceptions(pred_or_func::in, sym_name::in, arity::in,
+	mode_num::in, exception_status::in, prog_context::in,
+	module_info::in, module_info::out, io::di, io::uo) is det.
+
+add_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum, ThrowStatus,
+		_Context, !Module, !IO) :-
+	module_info_get_predicate_table(!.Module, Preds),
+	(
+		predicate_table_search_pf_sym_arity(Preds,
+			is_fully_qualified, PredOrFunc, SymName,
+			Arity, [PredId])
+	->
+		module_info_exception_info(!.Module, ExceptionsInfo0),
+		% convert the mode number to a proc_id
+		proc_id_to_int(ProcId, ModeNum),
+		map__set(ExceptionsInfo0, proc(PredId, ProcId), ThrowStatus,
+			ExceptionsInfo),
+		module_info_set_exception_info(ExceptionsInfo, !Module)
+	;
+		% XXX We'll just ignore this for the time being -
+		% it causes errors with transitive-intermodule optimization.
+		%prog_out__write_context(Context, !IO),
+		%io__write_string("Internal compiler error: " ++
+		%	"unknown predicate in `pragma exceptions'.\n", !IO),
+		%module_info_incr_errors(!Module)
+		true
 	).

 %-----------------------------------------------------------------------------%
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.314
diff -u -r1.314 mercury_compile.m
--- compiler/mercury_compile.m	31 Aug 2004 07:22:06 -0000	1.314
+++ compiler/mercury_compile.m	24 Sep 2004 12:36:18 -0000
@@ -65,6 +65,7 @@
 :- import_module transform_hlds__lambda.
 :- import_module backend_libs__type_ctor_info.
 :- import_module transform_hlds__termination.
+:- import_module transform_hlds__exception_analysis.
 :- import_module transform_hlds__higher_order.
 :- import_module transform_hlds__accumulator.
 :- import_module transform_hlds__inlining.
@@ -2099,6 +2100,8 @@
 	globals__lookup_bool_option(Globals, verbose, Verbose),
 	globals__lookup_bool_option(Globals, statistics, Stats),
 	globals__lookup_bool_option(Globals, termination, Termination),
+	globals__lookup_bool_option(Globals, analyse_exceptions,
+		ExceptionAnalysis),

 	( MakeOptInt = yes ->
 		intermod__write_optfile(!HLDS, !IO),
@@ -2110,11 +2113,18 @@
 		(
 			( IntermodArgs = yes
 			; Termination = yes
+			; ExceptionAnalysis = yes
 			)
 		->
 			mercury_compile__frontend_pass_by_phases(!HLDS,
 				FoundModeError, !IO),
 			( FoundModeError = no ->
+				( ExceptionAnalysis = yes ->
+				    mercury_compile__maybe_exception_analysis(
+				        Verbose, Stats, !HLDS, !IO)
+				;
+				    true
+				),
 				( IntermodArgs = yes ->
 					mercury_compile__maybe_unused_args(
 						Verbose, Stats, !HLDS, !IO)
@@ -2174,7 +2184,11 @@
 mercury_compile__output_trans_opt_file(HLDS0, !IO) :-
 	globals__io_lookup_bool_option(verbose, Verbose, !IO),
 	globals__io_lookup_bool_option(statistics, Stats, !IO),
-	mercury_compile__maybe_termination(Verbose, Stats, HLDS0, HLDS, !IO),
+	mercury_compile__maybe_exception_analysis(Verbose, Stats, HLDS0,
+		HLDS1, !IO),
+	mercury_compile__maybe_dump_hlds(HLDS1, 118, "exception_analysis",
+		!IO),
+	mercury_compile__maybe_termination(Verbose, Stats, HLDS1, HLDS, !IO),
 	mercury_compile__maybe_dump_hlds(HLDS, 120, "termination", !IO),
 	trans_opt__write_optfile(HLDS, !IO).

@@ -2278,6 +2292,14 @@
 	% ;
 	%	true
 	% ),
+
+	% Exception analysis and termination analysis need to come before any
+	% optimization passes that could benefit from the information that
+	% they provide.
+	%
+	mercury_compile__maybe_exception_analysis(Verbose, Stats, !HLDS, !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, 118, "exception_analysis",
+		!IO),

 	mercury_compile__maybe_termination(Verbose, Stats, !HLDS, !IO),
 	mercury_compile__maybe_dump_hlds(!.HLDS, 120, "termination", !IO),
@@ -2750,6 +2772,22 @@
 			"% Program is determinism-correct.\n", !IO)
 	),
 	maybe_report_stats(Stats, !IO).
+
+:- pred mercury_compile.maybe_exception_analysis(bool::in, bool::in,
+	module_info::in, module_info::out, io::di, io::uo) is det.
+
+mercury_compile.maybe_exception_analysis(Verbose, Stats, !HLDS, !IO) :-
+	globals.io_lookup_bool_option(analyse_exceptions, ExceptionAnalysis,
+		!IO),
+	(
+		ExceptionAnalysis = yes,
+		maybe_write_string(Verbose, "% Analysing exceptions...\n", !IO),
+		exception_analysis.process_module(!HLDS, !IO),
+		maybe_write_string(Verbose, "% done.\n", !IO),
+		maybe_report_stats(Stats, !IO)
+	;
+		ExceptionAnalysis = no
+	).

 :- pred mercury_compile__maybe_termination(bool::in, bool::in,
 	module_info::in, module_info::out, io::di, io::uo) is det.
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.247
diff -u -r1.247 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m	5 Sep 2004 23:52:19 -0000	1.247
+++ compiler/mercury_to_mercury.m	29 Sep 2004 07:56:19 -0000
@@ -142,6 +142,9 @@
 :- pred mercury_output_pragma_unused_args(pred_or_func::in, sym_name::in,
 	int::in, mode_num::in, list(int)::in, io::di, io::uo) is det.

+:- pred mercury_output_pragma_exceptions(pred_or_func::in, sym_name::in,
+	int::in, mode_num::in, exception_status::in, io::di, io::uo) is det.
+
 	% Write an Aditi index specifier.
 :- pred mercury_output_index_spec(index_spec::in, io::di, io::uo) is det.

@@ -576,6 +579,11 @@
 		mercury_output_pragma_unused_args(PredOrFunc,
 			PredName, Arity, ModeNum, UnusedArgs)
 	;
+		{ Pragma = exceptions(PredOrFunc, PredName,
+			Arity, ModeNum, ThrowStatus) },
+		mercury_output_pragma_exceptions(PredOrFunc,
+			PredName, Arity, ModeNum, ThrowStatus)
+	;
 		{ Pragma = fact_table(Pred, Arity, FileName) },
 		mercury_format_pragma_fact_table(Pred, Arity, FileName)
 	;
@@ -3101,6 +3109,38 @@
 	add_string(", "),
 	add_int(First),
 	mercury_format_int_list_2(Rest).
+
+%-----------------------------------------------------------------------------%
+
+mercury_output_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum,
+		ThrowStatus, !IO) :-
+	io.write_string(":- pragma exceptions(", !IO),
+	write_pred_or_func(PredOrFunc, !IO),
+	io.write_string(", ", !IO),
+	mercury_output_bracketed_sym_name(SymName, !IO),
+	io.write_string(", ", !IO),
+	io.write_int(Arity, !IO),
+	io.write_string(", ", !IO),
+	io.write_int(ModeNum, !IO),
+	io.write_string(", ", !IO),
+	(
+		ThrowStatus = will_not_throw,
+		io.write_string("will_not_throw", !IO)
+	;
+		ThrowStatus = may_throw(ExceptionType),
+		io.write_string("may_throw(", !IO),
+		(
+			ExceptionType = user_exception,
+			io.write_string("user_exception)", !IO)
+		;
+			ExceptionType = type_exception,
+			io.write_string("type_exception)", !IO)
+		)
+	;
+		ThrowStatus = conditional,
+		io.write_string("conditional", !IO)
+	),
+	io.write_string(").\n", !IO).

 %-----------------------------------------------------------------------------%

Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.93
diff -u -r1.93 module_qual.m
--- compiler/module_qual.m	5 Sep 2004 23:52:32 -0000	1.93
+++ compiler/module_qual.m	24 Sep 2004 07:25:04 -0000
@@ -1019,6 +1019,7 @@
 		export(Name, PredOrFunc, Modes, CFunc), Info0, Info) -->
 	qualify_mode_list(Modes0, Modes, Info0, Info).
 qualify_pragma(X at unused_args(_, _, _, _, _), X, Info, Info) --> [].
+qualify_pragma(X at exceptions(_, _, _, _, _), X, Info, Info) --> [].
 qualify_pragma(type_spec(A, B, C, D, MaybeModes0, Subst0, G, H),
 		type_spec(A, B, C, D, MaybeModes, Subst, G, H),
 		Info0, Info) -->
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.306
diff -u -r1.306 modules.m
--- compiler/modules.m	27 Sep 2004 06:43:59 -0000	1.306
+++ compiler/modules.m	27 Sep 2004 06:46:34 -0000
@@ -1681,6 +1681,7 @@
 pragma_allowed_in_interface(promise_pure(_, _), no).
 pragma_allowed_in_interface(promise_semipure(_, _), no).
 pragma_allowed_in_interface(unused_args(_, _, _, _, _), no).
+pragma_allowed_in_interface(exceptions(_, _, _, _, _), no).
 pragma_allowed_in_interface(type_spec(_, _, _, _, _, _, _, _), yes).
 pragma_allowed_in_interface(termination_info(_, _, _, _, _), yes).
 pragma_allowed_in_interface(terminates(_, _), yes).
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.430
diff -u -r1.430 options.m
--- compiler/options.m	16 Aug 2004 08:51:10 -0000	1.430
+++ compiler/options.m	1 Oct 2004 05:40:14 -0000
@@ -480,6 +480,7 @@
 		;	termination_norm
 		;	termination_error_limit
 		;	termination_path_limit
+		;	analyse_exceptions
 	%	- HLDS->LLDS
 		;	smart_indexing
 		;	  dense_switch_req_density
@@ -1014,7 +1015,8 @@
 	termination_norm	-	string("total"),
 	termination_error_limit	-	int(3),
 	termination_path_limit	-	int(256),
-	split_c_files		-	bool(no)
+	split_c_files		-	bool(no),
+	analyse_exceptions 	-	bool(no)
 ]).
 option_defaults_2(optimization_option, [
 		% Optimization options
@@ -1735,6 +1737,7 @@
 long_option("term-err-limit",		termination_error_limit).
 long_option("termination-path-limit",	termination_path_limit).
 long_option("term-path-limit",		termination_path_limit).
+long_option("analyse-exceptions", 	analyse_exceptions).

 % HLDS->LLDS optimizations
 long_option("smart-indexing",		smart_indexing).
@@ -3640,7 +3643,11 @@
 		"--deforestation-size-threshold <threshold>",
 		"\tSpecify a rough limit on the size of a goal",
 		"\tto be optimized by deforestation.",
-		"\tA value of -1 specifies no limit. The default is 15."
+		"\tA value of -1 specifies no limit. The default is 15.",
+		"--analyse-exceptions",
+		"\tEnable exception analysis.  Identify those",
+		"\tprocedures that will not throw an exception.",
+		"\tSome optimizations can make use of this information."
 	]).

 :- pred options_help_hlds_llds_optimization(io::di, io::uo) is det.
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.115
diff -u -r1.115 prog_data.m
--- compiler/prog_data.m	29 Sep 2004 04:36:27 -0000	1.115
+++ compiler/prog_data.m	29 Sep 2004 07:33:52 -0000
@@ -328,7 +328,16 @@
 			% Used for inter-module unused argument
 			% removal, should only appear in .opt files.
 		)
-
+	;
+		exceptions(
+			exceptions_p_or_f :: pred_or_func,
+			exceptions_name	  :: sym_name,
+			exceptions_arity  :: arity,
+			exceptions_mode	  :: mode_num,
+			exceptions_status :: exception_status
+			% PredName, Arity, Mode number, Exception status.
+			% Should only appear in `.opt' or `.trans_opt' files.
+		)
 	%
 	% Diagnostics pragmas (pragmas related to compiler warnings/errors)
 	%
@@ -638,6 +647,38 @@
 :- type mode_num == int.

 %
+% Stuff for the `exceptions' pragma.
+%
+
+:- type exception_status
+		---> 	will_not_throw
+				% This procedure will not throw an
+				% exception.
+
+		;	may_throw(exception_type)
+				% This procedure may throw an exception
+				% The exception is classified by the
+				% `exception_type' type.
+		;	conditional.
+				% Whether the procedure will not throw an
+				% exception depends upon the value of one
+				% or more polymorpyhic arguments.
+				% XXX This needs to be extended for ho
+				% preds.  (See exception_analysis.m for
+				% more details).
+:- type exception_type
+		--->	user_exception
+				% The exception that might be thrown is of
+				% a result of some code calling
+				% exception.throw/1.
+		;	type_exception.
+				% The exception is a result of a compiler
+				% introduced unification/comparison maybe
+				% throwing an exception (in the case of
+				% user-defined equality or comparison) or
+				% propagating an exception from them.
+
+%
 % Stuff for the `type_spec' pragma.
 %

@@ -1718,4 +1759,6 @@
 extra_attribute_to_string(max_stack_size(Size)) =
 	"max_stack_size(" ++ string__int_to_string(Size) ++ ")".

+%-----------------------------------------------------------------------------%
+:- end_module prog_data.
 %-----------------------------------------------------------------------------%
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.72
diff -u -r1.72 prog_io_pragma.m
--- compiler/prog_io_pragma.m	5 Sep 2004 23:52:41 -0000	1.72
+++ compiler/prog_io_pragma.m	29 Sep 2004 07:07:19 -0000
@@ -1213,6 +1213,59 @@
 			Pragma = does_not_terminate(Name, Arity)),
 		PragmaTerms, ErrorTerm, Result).

+parse_pragma_type(ModuleName, "exceptions", PragmaTerms,
+		ErrorTerm, _VarSet, Result) :-
+	(
+		PragmaTerms = [
+			PredOrFuncTerm,
+			PredNameTerm,
+			term.functor(term.integer(Arity), [], _),
+			term.functor(term.integer(ModeNum), [], _),
+			ThrowStatusTerm
+		],
+		(
+			PredOrFuncTerm = term.functor(
+				term.atom("predicate"), [], _),
+			PredOrFunc = predicate
+		;
+			PredOrFuncTerm = term.functor(
+				term.atom("function"), [], _),
+			PredOrFunc = function
+		),
+		parse_implicitly_qualified_term(ModuleName, PredNameTerm,
+			ErrorTerm, "`:- pragma exceptions' declaration",
+			PredNameResult),
+		PredNameResult = ok(PredName, []),
+		(
+			ThrowStatusTerm = term.functor(
+				term.atom("will_not_throw"), [], _),
+			ThrowStatus = will_not_throw
+		;
+			ThrowStatusTerm = term.functor(
+				term.atom("may_throw"),
+				[ExceptionTypeTerm], _),
+			(
+				ExceptionTypeTerm = term.functor(
+					term.atom("user_exception"), [], _),
+				ExceptionType = user_exception
+			;
+				ExceptionTypeTerm = term.functor(
+					term.atom("type_exception"), [], _),
+				ExceptionType = type_exception
+			),
+			ThrowStatus = may_throw(ExceptionType)
+		;
+			ThrowStatusTerm = term.functor(
+				term.atom("conditional"), [], _),
+			ThrowStatus = conditional
+		)
+	->
+		Result = ok(pragma(exceptions(PredOrFunc, PredName,
+			Arity, ModeNum, ThrowStatus)))
+	;
+		Result = error("error in `:- pragma exceptions'", ErrorTerm)
+	).
+
 parse_pragma_type(ModuleName, "check_termination", PragmaTerms,
 				ErrorTerm, _VarSet, Result) :-
 	parse_simple_pragma(ModuleName, "check_termination",
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.11
diff -u -r1.11 recompilation.version.m
--- compiler/recompilation.version.m	5 Sep 2004 23:52:45 -0000	1.11
+++ compiler/recompilation.version.m	24 Sep 2004 07:25:07 -0000
@@ -585,6 +585,8 @@
 is_pred_pragma(source_file(_), no).
 is_pred_pragma(unused_args(PredOrFunc, Name, Arity, _, _),
 		yes(yes(PredOrFunc) - Name / Arity)).
+is_pred_pragma(exceptions(PredOrFunc, Name, Arity, _, _),
+		yes(yes(PredOrFunc) - Name / Arity)).
 is_pred_pragma(fact_table(Name, Arity, _), yes(no - Name / Arity)).
 is_pred_pragma(reserve_tag(_TypeName, _TypeArity), no).
 is_pred_pragma(aditi(Name, Arity), yes(no - Name / Arity)).
Index: compiler/rl.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl.m,v
retrieving revision 1.28
diff -u -r1.28 rl.m
--- compiler/rl.m	14 Jun 2004 04:16:33 -0000	1.28
+++ compiler/rl.m	14 Jun 2004 23:27:11 -0000
@@ -948,7 +948,7 @@
 		all [Goal] (
 			list__member(Goal, Goals)
 		=>
-			goal_cannot_loop_or_throw(Goal)
+			goal_cannot_loop_or_throw(ModuleInfo, Goal)
 		)
 	).

Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.133
diff -u -r1.133 simplify.m
--- compiler/simplify.m	20 Jul 2004 04:41:06 -0000	1.133
+++ compiler/simplify.m	27 Aug 2004 08:47:42 -0000
@@ -333,6 +333,7 @@
 simplify__goal(Goal0, Goal - GoalInfo, !Info) :-
 	Goal0 = _ - GoalInfo0,
 	goal_info_get_determinism(GoalInfo0, Detism),
+	simplify_info_get_module_info(!.Info, ModuleInfo),
 	simplify_info_get_det_info(!.Info, DetInfo),
 	(
 		%
@@ -343,7 +344,7 @@
 		% ensure goal is pure or semipure
 		\+ goal_info_is_impure(GoalInfo0),
 		( det_info_get_fully_strict(DetInfo, no)
-		; goal_cannot_loop_or_throw(Goal0)
+		; goal_cannot_loop_or_throw(ModuleInfo, Goal0)
 		)
 	->
 		% warn about this, unless the goal was an explicit
@@ -393,7 +394,7 @@
 		% ensure goal is pure or semipure
 		\+ goal_info_is_impure(GoalInfo0),
 		( det_info_get_fully_strict(DetInfo, no)
-		; goal_cannot_loop_or_throw(Goal0)
+		; goal_cannot_loop_or_throw(ModuleInfo, Goal0)
 		)
 	->
 % The following warning is disabled, because it often results in spurious
Index: compiler/trans_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/trans_opt.m,v
retrieving revision 1.23
diff -u -r1.23 trans_opt.m
--- compiler/trans_opt.m	7 Jun 2004 09:07:10 -0000	1.23
+++ compiler/trans_opt.m	24 Sep 2004 08:18:07 -0000
@@ -30,14 +30,16 @@
 %
 % This module writes out the interface for transitive intermodule optimization.
 % The .trans_opt file includes:
-%	- pragma termination_info declarations for all exported preds
+%	:- pragma termination_info declarations for all exported preds
+%	:- pragma exceptions declartions for all exported preds
 % All these items should be module qualified.
 % Constructors should be explicitly type qualified.
 %
 % Note that the .trans_opt file does not (yet) include clauses,
 % `pragma c_code' declarations, or any of the other information
 % that would be needed for inlining or other optimizations;
-% currently it is used *only* for termination analysis.
+% currently it is only used for termination analysis and
+% exception analysis.
 %
 % This module also contains predicates to read in the .trans_opt files.
 %
@@ -47,8 +49,6 @@

 :- module transform_hlds__trans_opt.

-%-----------------------------------------------------------------------------%
-
 :- interface.

 :- import_module hlds__hlds_module.
@@ -80,6 +80,7 @@
 :- import_module parse_tree__prog_out.
 :- import_module transform_hlds__intermod.
 :- import_module transform_hlds__termination.
+:- import_module transform_hlds__exception_analysis.

 :- import_module set, string, list, map, varset, term, std_util.

@@ -121,7 +122,13 @@
 		module_info_predids(Module, PredIds),
 		list__foldl(termination__write_pred_termination_info(Module),
 			PredIds, !IO),
-
+
+		module_info_exception_info(Module, ExceptionInfo),
+		list__foldl(
+			exception_analysis__write_pragma_exceptions(Module,
+				ExceptionInfo),
+			PredIds, !IO),
+
 		io__set_output_stream(OldStream, _, !IO),
 		io__close_output(Stream, !IO),

@@ -132,8 +139,9 @@
 	).

 %-----------------------------------------------------------------------------%
-
-	% Read in and process the transitive optimization interfaces.
+%
+% Read and process the transitive optimization interfaces.
+%

 trans_opt__grab_optfiles(TransOptDeps, !Module, FoundError, !IO) :-
 	globals__io_lookup_bool_option(verbose, Verbose, !IO),
@@ -172,6 +180,9 @@

 	intermod__update_error_status(trans_opt, FileName, ModuleError,
 		Messages, !Error, !IO),
-
 	list__append(!.Items, NewItems, !:Items),
 	read_trans_opt_files(Imports, !Items, !Error, !IO).
+
+%-----------------------------------------------------------------------------%
+:- end_module trans_opt.
+%-----------------------------------------------------------------------------%
Index: compiler/transform_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/transform_hlds.m,v
retrieving revision 1.10
diff -u -r1.10 transform_hlds.m
--- compiler/transform_hlds.m	14 Jun 2004 04:16:40 -0000	1.10
+++ compiler/transform_hlds.m	14 Jun 2004 23:27:14 -0000
@@ -37,6 +37,8 @@
    :- include_module term_util.
    :- include_module lp. % this could alternatively go in the `libs' module

+:- include_module exception_analysis.
+
 % Optimizations (HLDS -> HLDS)
 :- include_module higher_order.
 :- include_module inlining.
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.143
diff -u -r1.143 type_util.m
--- compiler/type_util.m	10 Sep 2004 03:50:28 -0000	1.143
+++ compiler/type_util.m	24 Sep 2004 12:40:47 -0000
@@ -111,6 +111,11 @@
 :- pred type_body_is_solver_type(module_info::in, hlds_type_body::in)
 		is semidet.

+	% Succeeds iff one or more of the type constructors for a given
+	% type is existentially quantified.
+	%
+:- pred type_util__is_existq_type(module_info::in, (type)::in) is semidet.
+
 	% Certain types, e.g. io__state and store__store(S),
 	% are just dummy types used to ensure logical semantics;
 	% there is no need to actually pass them, and so when
@@ -892,6 +897,14 @@
 	;
 		TypeBody = eqv_type(Type),
 		type_util__is_solver_type(ModuleInfo, Type)
+	).
+
+type_util__is_existq_type(Module, Type) :-
+	type_constructors(Type, Module, Constructors),
+	some [Constructor]
+	(
+		list.member(Constructor, Constructors),
+		Constructor ^ cons_exist \= []
 	).

 	% Certain types, e.g. io__state and store__store(S),
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.92
diff -u -r1.92 compiler_design.html
--- compiler/notes/compiler_design.html	14 Jun 2004 04:17:03 -0000	1.92
+++ compiler/notes/compiler_design.html	14 Jun 2004 23:27:16 -0000
@@ -725,6 +725,16 @@

 <p>

+Exception analysis. (exception_analysis.m)
+
+<ul>
+<li>
+	This pass annotates each module with information about whether
+	the procedures in the module may throw an exception or not.
+</ul>
+
+<p>
+
 The next pass is termination analysis. The various modules involved are:

 <ul>
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.391
diff -u -r1.391 user_guide.texi
--- doc/user_guide.texi	20 Sep 2004 04:50:23 -0000	1.391
+++ doc/user_guide.texi	24 Sep 2004 07:25:12 -0000
@@ -6266,6 +6266,13 @@
 to be optimized by deforestation.
 A value of -1 specifies no limit. The default is 15.

+ at sp 1
+ at item --analyse-exceptions
+ at findex --analyse-exceptions
+Try to identify those procedures that cannot throw an
+exception.  This information can be used by some
+optimization passes.
+
 @end table

 @node MLDS backend (MLDS -> MLDS) optimization options
Index: tests/README
===================================================================
RCS file: /home/mercury1/repository/tests/README,v
retrieving revision 1.7
diff -u -r1.7 README
--- tests/README	17 Aug 2002 13:51:54 -0000	1.7
+++ tests/README	19 Mar 2004 05:51:11 -0000
@@ -67,3 +67,8 @@
 	comparing the warnings emitted by the compiler with those given
 	in the hand-written `.exp' file.

+term
+	This directory tests the compiler's termination analyser.  These
+	tests work by comparing the contents of the .trans_opt file emitted
+	by the compiler with the hand-written `.trans_opt_exp' file.
+	This directory is also used for testing the compiler's exception analysis.
Index: tests/term/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/term/Mercury.options,v
retrieving revision 1.4
diff -u -r1.4 Mercury.options
--- tests/term/Mercury.options	15 Dec 2003 07:11:06 -0000	1.4
+++ tests/term/Mercury.options	20 Mar 2004 13:20:38 -0000
@@ -8,6 +8,7 @@
 MCFLAGS-dds3_15=--term-norm=simple
 MCFLAGS-dds3_17=--term-norm=simple
 MCFLAGS-dds3_8=--term-norm=simple
+MCFLAGS-exception_analysis_test=--analyse-exceptions --no-warn-inferred-erroneous --no-warn-simple-code
 MCFLAGS-existential_error1=--term-norm=num-data-elems
 MCFLAGS-existential_error2=--term-norm=num-data-elems
 MCFLAGS-existential_error3=--term-norm=num-data-elems
Index: tests/term/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/term/Mmakefile,v
retrieving revision 1.24
diff -u -r1.24 Mmakefile
--- tests/term/Mmakefile	12 Feb 2004 03:36:17 -0000	1.24
+++ tests/term/Mmakefile	19 Mar 2004 00:47:04 -0000
@@ -19,6 +19,7 @@
 	dds3_15 \
 	dds3_17 \
 	dds3_8 \
+	exception_analysis_test \
 	existential_error1 \
 	existential_error2 \
 	existential_error3 \
Index: tests/term/exception_analysis_test.m
===================================================================
RCS file: tests/term/exception_analysis_test.m
diff -N tests/term/exception_analysis_test.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/term/exception_analysis_test.m	19 Mar 2004 00:33:11 -0000
@@ -0,0 +1,81 @@
+	% This module performs a basic test of the compiler's
+	% exception analysis.
+	%
+:- module exception_analysis_test.
+
+:- interface.
+
+	% Uses user-defined equality that may throw an exception
+	% but will not throw an exception itself.
+:- pred test1(T::in) is det.
+
+	% Uses user-defined equality that throws an exception
+	% and throws a (type) exception.
+:- pred test2(T::in, T::in) is semidet.
+
+	% Conditional.
+	%
+:- pred test3(T::in, T::in) is semidet.
+
+	% Throws a user exception.
+	%
+:- pred test4(T::in, T::in) is semidet.
+
+	%  This will be conditional...if we had
+	% a more precise analysis we could work out
+	% that it is only conditional if you enter
+	% the SCC via the predicate mutual_test1.
+	% If we enter via mutual_test2 then an
+	% exception will never be thrown.
+:- pred mutual_test1(T::in, T::in) is semidet.
+
+:- pred mutual_test2(int::in, int::in) is semidet.
+
+:- implementation.
+
+:- import_module require.
+
+:- type wrap(T) ---> wrap(T) where equality is wrap_equals.
+
+:- pred wrap_equals(wrap(T)::in, wrap(T)::in) is semidet.
+
+wrap_equals(_, _) :- error("Type exception.").
+
+test1(T) :- test1(wrap(T)).
+
+test2(X, Y) :-
+	( X = Y ->
+		true
+	;
+		test2(wrap(X), wrap(Y))
+	).
+
+test3(X, Y) :-
+	( X = Y ->
+		true
+	;
+		test3(X, Y)
+	).
+
+test4(X, Y) :-
+	( X = Y ->
+		error("User exception.")
+	;
+		test4(X, Y)
+	).
+
+mutual_test1(X::in, Y::in) :-
+	( X = Y ->
+		mutual_test2(3, 4)
+	;
+		mutual_test1("hello", "world")
+	).
+
+mutual_test2(X::in, Y::in) :-
+	( X = Y ->
+		mutual_test1(500, 400)
+	;
+		mutual_test2(60, 20)
+	).
+
+:- end_module exception_analysis_test.
Index: tests/term/exception_analysis_test.trans_opt_exp
===================================================================
RCS file: tests/term/exception_analysis_test.trans_opt_exp
diff -N tests/term/exception_analysis_test.trans_opt_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/term/exception_analysis_test.trans_opt_exp	20 Mar 2004 13:22:44 -0000
@@ -0,0 +1,15 @@
+:- module exception_analysis_test.
+:- pragma termination_info(exception_analysis_test.test1((builtin.in)), finite(0, [no, no]), can_loop).
+:- pragma termination_info(exception_analysis_test.test2((builtin.in), (builtin.in)), finite(0, [no, no, no]), can_loop).
+:- pragma termination_info(exception_analysis_test.test3((builtin.in), (builtin.in)), finite(0, [no, no, no]), can_loop).
+:- pragma termination_info(exception_analysis_test.test4((builtin.in), (builtin.in)), finite(0, [no, no, no]), can_loop).
+:- pragma termination_info(exception_analysis_test.mutual_test1((builtin.in), (builtin.in)), finite(0, [no, no, no]), can_loop).
+:- pragma termination_info(exception_analysis_test.mutual_test2((builtin.in), (builtin.in)), finite(0, [no, no]), can_loop).
+:- pragma termination_info(exception_analysis_test.wrap_equals((builtin.in), (builtin.in)), infinite, cannot_loop).
+:- pragma exceptions(predicate, (exception_analysis_test.test1), 1, 0, will_not_throw).
+:- pragma exceptions(predicate, (exception_analysis_test.test2), 2, 0, may_throw(type_exception)).
+:- pragma exceptions(predicate, (exception_analysis_test.test3), 2, 0, conditional).
+:- pragma exceptions(predicate, (exception_analysis_test.test4), 2, 0, may_throw(user_exception)).
+:- pragma exceptions(predicate, (exception_analysis_test.mutual_test1), 2, 0, conditional).
+:- pragma exceptions(predicate, (exception_analysis_test.mutual_test2), 2, 0, conditional).
+:- pragma exceptions(predicate, (exception_analysis_test.wrap_equals), 2, 0, may_throw(user_exception)).

--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------