[MLton] cvs commit: improved exception history for Overflow
Stephen Weeks
sweeks@mlton.org
Thu, 19 May 2005 16:34:55 -0700
sweeks 05/05/19 16:34:55
Modified: basis-library/misc primitive.sml
doc changelog
Log:
MAIL improved exception history for Overflow
Put in a hack suggested by Matthew to cause Overflow exceptions to
have their exception history printed just like all other exceptions.
The problem had been that because Overflow is generated in the
compiler internals (during closure conversion's translation to SSA),
it misses the pass (implementExceptions) that inserts the calls to the
hooks (defined in basis-library/mlton/exn.sml) that attach the
exception history to an exception when it is first raised.
So, a program like the following
----------------------------------------------------------------------
fun f n =
case n of
0 => 0
| 1 => raise Fail ""
| n => 1 + f (n + 1)
val _ = f (valOf Int.maxInt - 5)
----------------------------------------------------------------------
when compiled with MLton 20041109 and -const 'Exn.keepHistory true',
will print only
unhandled exception: Overflow
When compiled by the CVS HEAD before this commit, the program prints
the same.
After this commit, the program will print
unhandled exception: Overflow
with history:
f z.sml 1.5
f z.sml 1.5
f z.sml 1.5
f z.sml 1.5
f z.sml 1.5
f z.sml 1.5
The fix was only a few lines changed in
basis-library/misc/primitive.sml. The idea is to treat the Overflow
exception exported by the compiler as "PrimitiveOverflow", declare the
real Overflow exception in the basis sources, and then wrap every
primitive that can raise overflow with a handler that re-raises with
the basis Overflow. It is that reraise that will cause the exception
history to be exported.
Revision Changes Path
1.152 +30 -18 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.151
retrieving revision 1.152
diff -u -r1.151 -r1.152
--- primitive.sml 4 May 2005 23:34:54 -0000 1.151
+++ primitive.sml 19 May 2005 23:34:54 -0000 1.152
@@ -171,9 +171,13 @@
exception Fail of string
exception Match = Match
-exception Overflow = Overflow
+exception PrimitiveOverflow = Overflow
+exception Overflow
exception Size
+val wrapOverflow: ('a -> 'b) -> ('a -> 'b) =
+ fn f => fn a => f a handle PrimitiveOverflow => raise Overflow
+
datatype 'a option = NONE | SOME of 'a
fun not b = if b then false else true
@@ -482,17 +486,17 @@
val *? = _prim "WordS8_mul": int * int -> int;
val * =
if detectOverflow
- then _prim "WordS8_mulCheck": int * int -> int;
+ then wrapOverflow (_prim "WordS8_mulCheck": int * int -> int;)
else *?
val +? = _prim "Word8_add": int * int -> int;
val + =
if detectOverflow
- then _prim "WordS8_addCheck": int * int -> int;
+ then wrapOverflow (_prim "WordS8_addCheck": int * int -> int;)
else +?
val -? = _prim "Word8_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "WordS8_subCheck": int * int -> int;
+ then wrapOverflow (_prim "WordS8_subCheck": int * int -> int;)
else -?
val op < = _prim "WordS8_lt": int * int -> bool;
val quot = _prim "WordS8_quot": int * int -> int;
@@ -503,7 +507,7 @@
val ~? = _prim "Word8_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Word8_negCheck": int -> int;
+ then wrapOverflow (_prim "Word8_negCheck": int -> int;)
else ~?
val andb = _prim "Word8_andb": int * int -> int;
val fromInt = _prim "WordS32_toWord8": Int.int -> int;
@@ -586,17 +590,20 @@
val *? = _prim "WordS16_mul": int * int -> int;
val * =
if detectOverflow
- then _prim "WordS16_mulCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS16_mulCheck": int * int -> int;))
else *?
val +? = _prim "Word16_add": int * int -> int;
val + =
if detectOverflow
- then _prim "WordS16_addCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS16_addCheck": int * int -> int;))
else +?
val -? = _prim "Word16_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "WordS16_subCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS16_subCheck": int * int -> int;))
else -?
val op < = _prim "WordS16_lt": int * int -> bool;
val quot = _prim "WordS16_quot": int * int -> int;
@@ -607,7 +614,7 @@
val ~? = _prim "Word16_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Word16_negCheck": int -> int;
+ then wrapOverflow (_prim "Word16_negCheck": int -> int;)
else ~?
val andb = _prim "Word16_andb": int * int -> int;
val fromInt = _prim "WordS32_toWord16": Int.int -> int;
@@ -754,17 +761,20 @@
val *? = _prim "WordS32_mul": int * int -> int;
val * =
if detectOverflow
- then _prim "WordS32_mulCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS32_mulCheck": int * int -> int;))
else *?
val +? = _prim "Word32_add": int * int -> int;
val + =
if detectOverflow
- then _prim "WordS32_addCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS32_addCheck": int * int -> int;))
else +?
val -? = _prim "Word32_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "WordS32_subCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS32_subCheck": int * int -> int;))
else -?
val op < = _prim "WordS32_lt": int * int -> bool;
val quot = _prim "WordS32_quot": int * int -> int;
@@ -775,7 +785,7 @@
val ~? = _prim "Word32_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Word32_negCheck": int -> int;
+ then wrapOverflow (_prim "Word32_negCheck": int -> int;)
else ~?
val andb = _prim "Word32_andb": int * int -> int;
val fromInt : int -> int = fn x => x
@@ -811,12 +821,14 @@
val +? = _prim "Word64_add": int * int -> int;
val + =
if detectOverflow
- then _prim "WordS64_addCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS64_addCheck": int * int -> int;))
else +?
val -? = _prim "Word64_sub": int * int -> int;
val - =
if detectOverflow
- then _prim "WordS64_subCheck": int * int -> int;
+ then (wrapOverflow
+ (_prim "WordS64_subCheck": int * int -> int;))
else -?
val op < = _prim "WordS64_lt": int * int -> bool;
val << = _prim "Word64_lshift": int * Word.word -> int;
@@ -827,7 +839,7 @@
val ~? = _prim "Word64_neg": int -> int;
val ~ =
if detectOverflow
- then _prim "Word64_negCheck": int -> int;
+ then wrapOverflow (_prim "Word64_negCheck": int -> int;)
else ~?
val andb = _prim "Word64_andb": int * int -> int;
val fromInt = _prim "WordS32_toWord64": Int.int -> int;
@@ -2198,12 +2210,12 @@
val _ =
TopLevel.setHandler
(fn exn =>
- (Stdio.print ("unhandled exception: ")
+ (Stdio.print "unhandled exception: "
; case exn of
Fail msg => (Stdio.print "Fail "
; Stdio.print msg)
| _ => Stdio.print (Exn.name exn)
- ; Stdio.print ("\n")
+ ; Stdio.print "\n"
; bug (NullString.fromString
"unhandled exception in Basis Library\000")))
in
1.156 +3 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.155
retrieving revision 1.156
diff -u -r1.155 -r1.156
--- changelog 20 Apr 2005 12:58:06 -0000 1.155
+++ changelog 19 May 2005 23:34:54 -0000 1.156
@@ -1,5 +1,8 @@
Here are the changes since version 20041109.
+* 2005-05-19
+ - Improved exception history for Overflow exceptions.
+
* 2005-04-20
- Fixed a bug in pass to flatten refs into containing data structure.