[m-rev.] for review: will_not_throw_exception foreign proc attribute
Julien Fischer
juliensf at cs.mu.OZ.AU
Fri Dec 3 17:46:58 AEDT 2004
For review by anyone.
Estimated hours taken: 5
Branches: main
Add the foreign proc. attribute `will_not_throw_exception'.
This allows the user to promise the exception analysis that a
foreign proc. that makes calls back to Mercury will not throw
an exception.
The behaviour for foreign procs that do not make calls back
to Mercury is unchanged; they cannot throw exceptions anyway.
compiler/prog_data.m:
compiler/prog_io_pragma.m:
Handle the new attribute.
compiler/exception_analysis.m:
If the user has provided the `will_not_throw_exception'
attribute on a foreign proc that makes calls back to
Mercury then set then have the exception analysis
take account of this information.
Fix a typo.
doc/reference_manual.texi:
Mention the new foreign proc attribute.
tests/term/Mmakefile:
tests/term/Mercury.options:
tests/term/promise_no_throw_exception.m:
tests/term/promise_no_throw_exception.trans_opt_exp:
Test case for the above.
vim/syntax/mercury.vim:
Highlight the annotation appropriately.
Julien.
Workspace: /home/earth/juliensf/ws47
Index: compiler/exception_analysis.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/exception_analysis.m,v
retrieving revision 1.1
diff -u -r1.1 exception_analysis.m
--- compiler/exception_analysis.m 16 Oct 2004 15:05:49 -0000 1.1
+++ compiler/exception_analysis.m 3 Dec 2004 06:24:28 -0000
@@ -326,15 +326,18 @@
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
+ ( may_call_mercury(Attributes) = may_call_mercury ->
+ may_throw_exception(Attributes) = MayThrowException,
+ ( MayThrowException = depends_on_mercury_calls ->
+ !:Result = !.Result ^ status :=
+ may_throw(user_exception)
+ ;
+ true
+ )
+ ;
+ true
).
check_goal_for_exceptions_2(_, _, _, shorthand(_), _, _) :-
unexpected(this_file,
@@ -445,7 +448,7 @@
% 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
+% 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.
%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.116
diff -u -r1.116 prog_data.m
--- compiler/prog_data.m 16 Oct 2004 15:05:50 -0000 1.116
+++ compiler/prog_data.m 2 Dec 2004 15:27:53 -0000
@@ -908,6 +908,7 @@
:- func foreign_language(pragma_foreign_proc_attributes) = foreign_language.
:- func tabled_for_io(pragma_foreign_proc_attributes) = tabled_for_io.
:- func legacy_purity_behaviour(pragma_foreign_proc_attributes) = bool.
+:- func may_throw_exception(pragma_foreign_proc_attributes) = may_throw_exception.
:- func ordinary_despite_detism(pragma_foreign_proc_attributes) = bool.
:- func extra_attributes(pragma_foreign_proc_attributes)
= pragma_foreign_proc_extra_attributes.
@@ -936,6 +937,10 @@
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
+:- pred set_may_throw_exception(may_throw_exception::in,
+ pragma_foreign_proc_attributes::in,
+ pragma_foreign_proc_attributes::out) is det.
+
:- pred set_legacy_purity_behaviour(bool::in,
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
@@ -991,6 +996,19 @@
% on whether the code makes calls back to Mercury
% (See termination.m for details).
+:- type may_throw_exception
+ ---> will_not_throw_exception
+ % The foreign code makes calls back to Mercury
+ % but none of them will result in an exception
+ % being thrown.
+
+ ; depends_on_mercury_calls.
+ % Whether or not the foreign code throws an
+ % exception depend on whether it makes alls back
+ % to Mercury (all foreign procs that don't make
+ % calls back to Mercury cannot cause an exception
+ % to be thrown).
+
:- type pragma_foreign_proc_extra_attribute
---> max_stack_size(int).
@@ -1654,6 +1672,7 @@
% there is some special case behaviour for
% pragma c_code and pragma import purity
% if legacy_purity_behaviour is `yes'
+ may_throw_exception :: may_throw_exception,
legacy_purity_behaviour :: bool,
ordinary_despite_detism :: bool,
extra_attributes ::
@@ -1663,8 +1682,7 @@
default_attributes(Language) =
attributes(Language, may_call_mercury, not_thread_safe,
not_tabled_for_io, impure, depends_on_mercury_calls,
- no, no, []).
-
+ depends_on_mercury_calls, no, no, []).
set_may_call_mercury(MayCallMercury, Attrs0, Attrs) :-
Attrs = Attrs0 ^ may_call_mercury := MayCallMercury.
@@ -1678,6 +1696,8 @@
Attrs = Attrs0 ^ purity := Purity.
set_terminates(Terminates, Attrs0, Attrs) :-
Attrs = Attrs0 ^ terminates := Terminates.
+set_may_throw_exception(MayThrowException, Attrs0, Attrs) :-
+ Attrs = Attrs0 ^ may_throw_exception := MayThrowException.
set_legacy_purity_behaviour(Legacy, Attrs0, Attrs) :-
Attrs = Attrs0 ^ legacy_purity_behaviour := Legacy.
set_ordinary_despite_detism(OrdinaryDespiteDetism, Attrs0, Attrs) :-
@@ -1688,8 +1708,8 @@
% in the attribute list -- the foreign language specifier string
% is at the start of the pragma.
Attrs = attributes(_Lang, MayCallMercury, ThreadSafe, TabledForIO,
- Purity, Terminates, _LegacyBehaviour, OrdinaryDespiteDetism,
- ExtraAttributes),
+ Purity, Terminates, Exceptions, _LegacyBehaviour,
+ OrdinaryDespiteDetism, ExtraAttributes),
(
MayCallMercury = may_call_mercury,
MayCallMercuryStr = "may_call_mercury"
@@ -1738,6 +1758,13 @@
TerminatesStrList = []
),
(
+ Exceptions = will_not_throw_exception,
+ ExceptionsStrList = ["will_not_throw_exception"]
+ ;
+ Exceptions = depends_on_mercury_calls,
+ ExceptionsStrList = []
+ ),
+ (
OrdinaryDespiteDetism = yes,
OrdinaryDespiteDetismStrList = ["ordinary_despite_detism"]
;
@@ -1746,6 +1773,7 @@
),
StringList = [MayCallMercuryStr, ThreadSafeStr, TabledForIOStr |
PurityStrList] ++ TerminatesStrList ++
+ ExceptionsStrList ++
OrdinaryDespiteDetismStrList ++
list__map(extra_attribute_to_string, ExtraAttributes).
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.74
diff -u -r1.74 prog_io_pragma.m
--- compiler/prog_io_pragma.m 16 Oct 2004 15:05:50 -0000 1.74
+++ compiler/prog_io_pragma.m 3 Dec 2004 05:46:10 -0000
@@ -1385,6 +1385,7 @@
; aliasing
; max_stack_size(int)
; terminates(terminates)
+ ; will_not_throw_exception
; ordinary_despite_detism.
:- pred parse_pragma_foreign_proc_attributes_term(foreign_language::in,
@@ -1466,6 +1467,8 @@
set_purity(Pure, !Attrs).
process_attribute(terminates(Terminates), !Attrs) :-
set_terminates(Terminates, !Attrs).
+process_attribute(will_not_throw_exception, !Attrs) :-
+ set_may_throw_exception(will_not_throw_exception, !Attrs).
process_attribute(max_stack_size(Size), !Attrs) :-
add_extra_attribute(max_stack_size(Size), !Attrs).
process_attribute(ordinary_despite_detism, !Attrs) :-
@@ -1531,12 +1534,15 @@
Flag = purity(Purity)
; parse_terminates(Term, Terminates) ->
Flag = terminates(Terminates)
+ ; parse_no_exception_promise(Term) ->
+ Flag = will_not_throw_exception
; parse_ordinary_despite_detism(Term) ->
Flag = ordinary_despite_detism
;
fail
).
+
:- pred parse_may_call_mercury(term::in, may_call_mercury::out) is semidet.
parse_may_call_mercury(term__functor(term__atom("recursive"), [], _),
@@ -1601,6 +1607,11 @@
terminates).
parse_terminates(term__functor(term__atom("does_not_terminate"), [], _),
does_not_terminate).
+
+:- pred parse_no_exception_promise(term::in) is semidet.
+
+parse_no_exception_promise(term.functor(
+ term.atom("will_not_throw_exception"), [], _)).
:- pred parse_ordinary_despite_detism(term::in) is semidet.
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.298
diff -u -r1.298 reference_manual.texi
--- doc/reference_manual.texi 29 Sep 2004 16:52:16 -0000 1.298
+++ doc/reference_manual.texi 3 Dec 2004 06:16:38 -0000
@@ -5766,7 +5766,21 @@
Currently this attribute is only used (and is in fact required) by the
@samp{IL} foreign language interface, and is measured in units of stack
items.
-
+ at item @samp{will_not_throw_exception}
+This attribute promises that the given predicate or function will not
+make calls back to Mercury that may result in an exception being thrown.
+This attribute only applies to code that makes calls back to Mercury.
+It is ignored for code which is declared as not making calls back
+to Mercury via a @samp{will_not_call_mercury} attribute.
+Note: Predicates or functions that have polymorphic arguments but
+do not explicitly throw an exception, via a call to exception.throw/1
+or require.error/1, may still throw exceptions because they may be
+called with arguments whose types have user-defined equality or
+comparison predicates. If these user-defined equality or comparison
+predicates throw exceptions then unifications or comparisons involving
+these types may also throw exceptions. As such, we recommend that
+only implementors of the Mercury system use this annotation for
+polymorphic predicates and functions.
@end table
Index: tests/term/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/term/Mercury.options,v
retrieving revision 1.5
diff -u -r1.5 Mercury.options
--- tests/term/Mercury.options 16 Oct 2004 15:08:55 -0000 1.5
+++ tests/term/Mercury.options 3 Dec 2004 05:47:41 -0000
@@ -53,6 +53,7 @@
MCFLAGS-pl8_4_2=--term-norm=simple
MCFLAGS-pragma_non_term=--term-norm=simple
MCFLAGS-pragma_term=--term-norm=simple
+MCFLAGS-promise_will_not_thorw=--analyse-exceptions
MCFLAGS-queens=--term-norm=simple
MCFLAGS-quicksort=--term-norm=simple
MCFLAGS-select=--term-norm=simple
Index: tests/term/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/term/Mmakefile,v
retrieving revision 1.25
diff -u -r1.25 Mmakefile
--- tests/term/Mmakefile 16 Oct 2004 15:08:55 -0000 1.25
+++ tests/term/Mmakefile 3 Dec 2004 05:46:58 -0000
@@ -65,6 +65,7 @@
pl8_4_2 \
pragma_non_term \
pragma_term \
+ promise_will_not_throw \
queens \
quicksort \
select \
Index: tests/term/promise_will_not_throw.m
===================================================================
RCS file: tests/term/promise_will_not_throw.m
diff -N tests/term/promise_will_not_throw.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/term/promise_will_not_throw.m 3 Dec 2004 05:46:38 -0000
@@ -0,0 +1,41 @@
+:- module promise_will_not_throw.
+
+:- interface.
+
+:- pred foo(int::in, int::out) is det.
+
+:- pred bar(int::in, int::out) is det.
+
+:- pred baz(int::in, int::out) is det.
+
+:- pred quux(int::in, int::out) is det.
+
+:- implementation.
+
+:- pragma foreign_proc("C",
+ foo(X::in, Y::out),
+ [may_call_mercury, promise_pure, will_not_throw_exception],
+"
+ X = Y;
+").
+
+:- pragma foreign_proc("C",
+ bar(X::in, Y::out),
+ [may_call_mercury, promise_pure],
+"
+ X = Y;
+").
+
+:- pragma foreign_proc("C",
+ baz(X::in, Y::out),
+ [will_not_call_mercury, promise_pure, will_not_throw_exception],
+"
+ X = Y;
+").
+
+:- pragma foreign_proc("C",
+ quux(X::in, Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = Y;
+").
Index: tests/term/promise_will_not_throw.trans_opt_exp
===================================================================
RCS file: tests/term/promise_will_not_throw.trans_opt_exp
diff -N tests/term/promise_will_not_throw.trans_opt_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/term/promise_will_not_throw.trans_opt_exp 3 Dec 2004 05:48:19 -0000
@@ -0,0 +1,9 @@
+:- module promise_will_not_throw.
+:- pragma termination_info(promise_will_not_throw.foo((builtin.in), (builtin.out)), infinite, can_loop).
+:- pragma termination_info(promise_will_not_throw.bar((builtin.in), (builtin.out)), infinite, can_loop).
+:- pragma termination_info(promise_will_not_throw.baz((builtin.in), (builtin.out)), infinite, cannot_loop).
+:- pragma termination_info(promise_will_not_throw.quux((builtin.in), (builtin.out)), infinite, cannot_loop).
+:- pragma exceptions(predicate, (promise_will_not_throw.foo), 2, 0, will_not_throw).
+:- pragma exceptions(predicate, (promise_will_not_throw.bar), 2, 0, may_throw(user_exception)).
+:- pragma exceptions(predicate, (promise_will_not_throw.baz), 2, 0, will_not_throw).
+:- pragma exceptions(predicate, (promise_will_not_throw.quux), 2, 0, will_not_throw).
Index: vim/syntax/mercury.vim
===================================================================
RCS file: /home/mercury1/repository/mercury/vim/syntax/mercury.vim,v
retrieving revision 1.10
diff -u -r1.10 mercury.vim
--- vim/syntax/mercury.vim 22 Sep 2004 05:07:42 -0000 1.10
+++ vim/syntax/mercury.vim 5 Nov 2004 05:42:57 -0000
@@ -52,6 +52,7 @@
syn keyword mercuryCInterface promise_pure promise_semipure
syn keyword mercuryCInterface tabled_for_io
syn keyword mercuryCInterface can_pass_as_mercury_type stable
+syn keyword mercuryCInterface will_not_throw_exception
syn keyword mercuryCInterface export import
syn keyword mercuryImpure impure semipure
syn keyword mercuryToDo XXX TODO NOTE
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------
More information about the reviews
mailing list