From: simonmar <unknown>
Date: Thu, 19 Jun 2003 10:42:26 +0000 (+0000)
Subject: [project @ 2003-06-19 10:42:24 by simonmar]
X-Git-Tag: Approx_11550_changesets_converted~763
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d89872a45b581ba3f086c636126a44d97ef45be6

[project @ 2003-06-19 10:42:24 by simonmar]
Add raiseIO# primop.

This is part of ensuring that exceptions are *precise* in the IO monad
(as opposed to imprecise exceptions in the pure world).  If we allow
the strictness analyser to see the definition of throwIO:

  throwIO e = IO $ \s -> throw e

then it might re-order evaluation in the IO monad, with the result
that we get _|_ instead of an exception, or one kind of exception when
we were expecting another.  We therefore must prevent the strictness
analyser from doing these reorderings in the IO monad.  Hiding the
definition of throwIO by making it a primop solves part of the problem
(there's more to come).

See SourceForge bug #752149.
---

diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp
index 8cde1b8..37c6c6f 100644
--- a/ghc/compiler/prelude/primops.txt.pp
+++ b/ghc/compiler/prelude/primops.txt.pp
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.26 2003/03/24 14:46:53 simonmar Exp $
+-- $Id: primops.txt.pp,v 1.27 2003/06/19 10:42:26 simonmar Exp $
 --
 -- Primitive Operations
 --
@@ -1312,6 +1312,15 @@ primop  RaiseOp "raise#" GenPrimOp
    usage       = { mangle RaiseOp [mkM] mkM }
    out_of_line = True
 
+-- raiseIO# needs to be a primop, because exceptions in the IO monad
+-- must be *precise* - we don't want the strictness analyser turning
+-- one kind of bottom into another, as it is allowed to do in pure code.
+
+primop  RaiseIOOp "raiseIO#" GenPrimOp
+   a -> State# RealWorld -> (# State# RealWorld, b #)
+   with
+   out_of_line = True
+
 primop  BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h
index 1331d04..ecc82bc 100644
--- a/ghc/includes/PrimOps.h
+++ b/ghc/includes/PrimOps.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.101 2003/06/09 14:10:04 matthewc Exp $
+ * $Id: PrimOps.h,v 1.102 2003/06/19 10:42:24 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -253,6 +253,7 @@ EXTFUN_RTS(asyncWritezh_fast);
 
 EXTFUN_RTS(catchzh_fast);
 EXTFUN_RTS(raisezh_fast);
+EXTFUN_RTS(raiseIOzh_fast);
 
 extern void stg_exit(int n)  __attribute__ ((noreturn));
 
diff --git a/ghc/rts/Exception.hc b/ghc/rts/Exception.hc
index a62f62e..aa47833 100644
--- a/ghc/rts/Exception.hc
+++ b/ghc/rts/Exception.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.27 2003/05/14 09:13:59 simonmar Exp $
+ * $Id: Exception.hc,v 1.28 2003/06/19 10:42:26 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -350,7 +350,7 @@ FN_(raisezh_fast)
   StgPtr p;
   StgClosure *raise_closure;
   FB_
-    /* args : R1 = exception */
+    /* args : R1.p :: Exception */
 
 
 #if defined(PROFILING)
@@ -459,3 +459,11 @@ FN_(raisezh_fast)
     JMP_(stg_ap_p_ret);
   FE_
 }
+
+FN_(raiseIOzh_fast)
+{
+  FB_
+  /* Args :: R1.p :: Exception */
+  JMP_(raisezh_fast);
+  FE_
+}
\ No newline at end of file