[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.