[m-rev.] diff: throw_if_near_stack_limits

[Zoltan Somogyi]

library/exception.m:
	Add a new predicate, throw_if_near_stack_limits, that throws an
	exception if execution is near stack limits, after a request on
	the mercury-users mailing list.

NEWS:
	Mention the new predicate.

Zoltan.

cvs diff: Diffing .
Index: NEWS
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/NEWS,v
retrieving revision 1.334
diff -u -b -r1.334 NEWS
--- NEWS	23 May 2004 22:16:39 -0000	1.334
+++ NEWS	21 Jun 2004 08:09:06 -0000
@@ -159,6 +159,9 @@
   ensure that resources are released whether a called closure exits
   normally or throws an exception.
 
+* exception.m now contains a predicate throw_if_near_stack_limits which
+  can be used to prevent an application running out of stack space.
+
 * We've added predicates multi_map.to_flat_assoc_list/2 and
   multi_map.from_flat_assoc_list/2. 
 
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/exception.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/exception.m,v
retrieving revision 1.89
diff -u -b -r1.89 exception.m
--- library/exception.m	31 May 2004 04:13:00 -0000	1.89
+++ library/exception.m	7 Jun 2004 10:39:49 -0000
@@ -21,10 +21,9 @@
 :- interface.
 :- import_module std_util, list, io, store.
 
-%
-% throw(Exception):
-%	Throw the specified exception.
-%
+	% throw(Exception):
+	%	Throw the specified exception.
+
 :- pred throw(T).
 :- mode throw(in) is erroneous.
 
@@ -42,40 +41,44 @@
 	--->	succeeded(ground)
 	;	exception(ground).
 
-%
-% try(Goal, Result):
-%    Operational semantics:
-%	Call Goal(R).
-%	If Goal(R) fails, succeed with Result = failed.
-%	If Goal(R) succeeds, succeed with Result = succeeded(R).
-%	If Goal(R) throws an exception E, succeed with Result = exception(E).
-%    Declarative semantics:
-%       try(Goal, Result) <=>
-%               ( Goal(R), Result = succeeded(R)
-%               ; not Goal(_), Result = failed
-%               ; Result = exception(_)
-%		).
-%
+	% try(Goal, Result):
+	%
+	% Operational semantics:
+	%	Call Goal(R).
+	%	If Goal(R) fails, succeed with Result = failed.
+	%	If Goal(R) succeeds, succeed with Result = succeeded(R).
+	%	If Goal(R) throws an exception E, succeed with
+	%		Result = exception(E).
+	%
+	% Declarative semantics:
+	%       try(Goal, Result) <=>
+	%               ( Goal(R), Result = succeeded(R)
+	%               ; not Goal(_), Result = failed
+	%               ; Result = exception(_)
+	%		).
+
 :- pred try(pred(T),		    exception_result(T)).
 :- mode try(pred(out) is det,       out(cannot_fail)) is cc_multi.
 :- mode try(pred(out) is semidet,   out)              is cc_multi.
 :- mode try(pred(out) is cc_multi,  out(cannot_fail)) is cc_multi.
 :- mode try(pred(out) is cc_nondet, out)              is cc_multi.
 
-%
-% try_io(Goal, Result, IO_0, IO):
-%    Operational semantics:
-%	Call Goal(R, IO_0, IO_1).
-%	If it succeeds, succeed with Result = succeeded(R) and IO = IO_1.
-%	If it throws an exception E, succeed with Result = exception(E)
-%	and with the final IO state being whatever state resulted
-%	from the partial computation from IO_0.
-%    Declarative semantics:
-%	try_io(Goal, Result, IO_0, IO) <=>
-%		( Goal(R, IO_0, IO), Result = succeeded(R)
-%		; Result = exception(_)
-%		).
-%
+	% try_io(Goal, Result, IO_0, IO):
+	%
+	% Operational semantics:
+	%	Call Goal(R, IO_0, IO_1).
+	%	If it succeeds, succeed with Result = succeeded(R)
+	%		and IO = IO_1.
+	%	If it throws an exception E, succeed with Result = exception(E)
+	%		and with the final IO state being whatever state
+	%		resulted from the partial computation from IO_0.
+	%
+	% Declarative semantics:
+	%	try_io(Goal, Result, IO_0, IO) <=>
+	%		( Goal(R, IO_0, IO), Result = succeeded(R)
+	%		; Result = exception(_)
+	%		).
+
 :- pred try_io(pred(T, io, io),
 	exception_result(T), io, io).
 :- mode try_io(pred(out, di, uo) is det,
@@ -83,10 +86,10 @@
 :- mode try_io(pred(out, di, uo) is cc_multi,
 	out(cannot_fail), di, uo) is cc_multi.
 
-%
-% try_store(Goal, Result, Store_0, Store):
-%    Just like try_io, but for stores rather than io__states.
-%
+	% try_store(Goal, Result, Store_0, Store):
+	%
+	% Just like try_io, but for stores rather than io__states.
+
 :- pred try_store(pred(T, store(S), store(S)),
 	exception_result(T), store(S), store(S)).
 :- mode try_store(pred(out, di, uo) is det,
@@ -94,28 +97,31 @@
 :- mode try_store(pred(out, di, uo) is cc_multi,
 	out(cannot_fail), di, uo) is cc_multi.
 
-%
-% try_all(Goal, ResultList):
-%    Operational semantics:
-%	Try to find all solutions to Goal(R), using backtracking.
-%	Collect the solutions found in the ResultList, until
-%	the goal either throws an exception or fails.
-%	If it throws an exception, put that exception at the end of
-%	the ResultList.
-%    Declaratively:
-%       try_all(Goal, ResultList) <=>
-%		(if
-%			list__reverse(ResultList, [Last | AllButLast]),
-%			Last = exception(_)
-%		then
-%			all [M] (list__member(M, AllButLast) =>
-%				(M = succeeded(R), Goal(R))),
-%		else
-%			all [M] (list__member(M, ResultList) =>
-%				(M = succeeded(R), Goal(R))),
-%			all [R] (Goal(R) =>
-%				list__member(succeeded(R), ResultList)),
-%		).
+	% try_all(Goal, ResultList):
+	%
+	% Operational semantics:
+	%	Try to find all solutions to Goal(R), using backtracking.
+	%	Collect the solutions found in the ResultList, until
+	%	the goal either throws an exception or fails.
+	%	If it throws an exception, put that exception at the end of
+	%	the ResultList.
+	%
+	% Declaratively:
+	%       try_all(Goal, ResultList) <=>
+	%		(if
+	%			list__reverse(ResultList,
+	%				[Last | AllButLast]),
+	%			Last = exception(_)
+	%		then
+	%			all [M] (list__member(M, AllButLast) =>
+	%				(M = succeeded(R), Goal(R))),
+	%		else
+	%			all [M] (list__member(M, ResultList) =>
+	%				(M = succeeded(R), Goal(R))),
+	%			all [R] (Goal(R) =>
+	%				list__member(succeeded(R),
+	%					ResultList)),
+	%		).
 
 :- pred try_all(pred(T), list(exception_result(T))).
 :- mode try_all(pred(out) is det,     out(try_all_det))     is cc_multi.
@@ -129,13 +135,14 @@
 :- inst try_all_multi ---> [cannot_fail | try_all_nondet].
 :- inst try_all_nondet == list_skel(cannot_fail).
 
-%
-% incremental_try_all(Goal, AccumulatorPred, Acc0, Acc):
-%    Same as
-%	try_all(Goal, Results),
-%	std_util__unsorted_aggregate(Results, AccumulatorPred, Acc0, Acc)
-%    except that operationally, the execution of try_all
-%    and std_util__unsorted_aggregate is interleaved.
+	% incremental_try_all(Goal, AccumulatorPred, Acc0, Acc):
+	%
+	% Same as
+	%	try_all(Goal, Results),
+	%	std_util__unsorted_aggregate(Results, AccumulatorPred,
+	%		Acc0, Acc)
+	% except that operationally, the execution of try_all
+	% and std_util__unsorted_aggregate is interleaved.
 
 :- pred incremental_try_all(pred(T), pred(exception_result(T), A, A), A, A).
 :- mode incremental_try_all(pred(out) is nondet,
@@ -143,34 +150,47 @@
 :- mode incremental_try_all(pred(out) is nondet,
 	pred(in, in, out) is det, in, out) is cc_multi.
 
-%
-% rethrow(ExceptionResult):
-%	Rethrows the specified exception result
-%	(which should be of the form `exception(_)',
-%	not `succeeded(_)' or `failed'.).
-%
+	% rethrow(ExceptionResult):
+	% Rethrows the specified exception result (which should be
+	% of the form `exception(_)', not `succeeded(_)' or `failed'.).
+
 :- pred rethrow(exception_result(T)).
 :- mode rethrow(in(bound(exception(ground)))) is erroneous.
 
 :- func rethrow(exception_result(T)) = _.
 :- mode rethrow(in(bound(exception(ground)))) = out is erroneous.
 
-%
-% finally(P, PRes, Cleanup, CleanupRes, IO0, IO).
-%	Call P and ensure that Cleanup is called afterwards,
-%	no matter whether P succeeds or throws an exception.
-%	PRes is bound to the output of P.
-%	CleanupRes is bound to the output of Cleanup.
-%	A exception thrown by P will be rethrown after Cleanup
-%	is called, unless Cleanup throws an exception.
-%	This predicate performs the same function as the `finally'
-%	clause (`try {...} finally {...}') in languages such as Java.
+	% finally(P, PRes, Cleanup, CleanupRes, IO0, IO).
+	% Call P and ensure that Cleanup is called afterwards,
+	% no matter whether P succeeds or throws an exception.
+	% PRes is bound to the output of P.
+	% CleanupRes is bound to the output of Cleanup.
+	% A exception thrown by P will be rethrown after Cleanup
+	% is called, unless Cleanup throws an exception.
+	% This predicate performs the same function as the `finally'
+	% clause (`try {...} finally {...}') in languages such as Java.
+
 :- pred finally(pred(T, io, io), T, pred(io__res, io, io), io__res, io, io).
 :- mode finally(pred(out, di, uo) is det, out,
 	pred(out, di, uo) is det, out, di, uo) is det.
 :- mode finally(pred(out, di, uo) is cc_multi, out,
 	pred(out, di, uo) is cc_multi, out, di, uo) is cc_multi.
 
+	% throw_if_near_stack_limits checks if the program is near
+	% the limits of the Mercury stacks, and throws an exception
+	% (near_stack_limits) if this is the case.
+	%
+	% This predicate works only in low level C grades; in other grades,
+	% it never throws an exception.
+	%
+	% The predicate is impure instead of semipure because its effect
+	% depends not only on the execution of other impure predicates,
+	% but all calls.
+
+:- type near_stack_limits ---> near_stack_limits.
+
+:- impure pred throw_if_near_stack_limits is det.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
@@ -2422,5 +2442,45 @@
 		io__nl(StdErr, !IO)
 	),
 	io__flush_output(StdErr, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pragma no_inline(throw_if_near_stack_limits/0).
+
+throw_if_near_stack_limits :-
+	( impure now_near_stack_limits ->
+		throw(near_stack_limits)
+	;
+		true
+	).
+
+:- impure pred now_near_stack_limits is semidet.
+:- pragma no_inline(now_near_stack_limits/0).
+
+:- pragma foreign_proc("C",
+	now_near_stack_limits,
+	[will_not_call_mercury],
+"
+#ifdef	MR_HIGHLEVEL_CODE
+	/*
+	** In high level code grades, I don't know of any portable way
+	** to check whether we are near the limits of the C stack.
+	*/
+	SUCCESS_INDICATOR = MR_FALSE;
+#else
+	int	slack = 1024;
+
+	if (((MR_maxfr + slack) < MR_CONTEXT(MR_ctxt_nondetstack_zone)->top)
+		&& ((MR_sp + slack) < MR_CONTEXT(MR_ctxt_detstack_zone)->top))
+	{
+		SUCCESS_INDICATOR = MR_FALSE;
+	} else {
+		SUCCESS_INDICATOR = MR_TRUE;
+	}
+#endif
+").
+
+now_near_stack_limits :-
+	fail.
 
 %-----------------------------------------------------------------------------%
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: [18:09:22] waiting for juliensf's lock in /home/mercury/mercury1/repository/tests/warnings
cvs diff: [18:09:52] obtained lock in /home/mercury/mercury1/repository/tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  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
--------------------------------------------------------------------------