[add continuation based IO errors
John Meacham <john@repetae.net>**20060217054715] hunk ./C/FromGrin.hs 112
+convertExp (Update v@Var {} (NodeV t [])) = do
+    v' <- convertVal v
+    t' <- convertVal (Var t TyTag)
+    let tag = project' anyTag v'
+    return (tag `assign` t',emptyExpression)
hunk ./E/FromHs.hs 184
+        errorCont <- findName v_undefinedIOErrorCont
hunk ./E/FromHs.hs 189
-            be = eAp e vWorld__
+            be = eAp (eAp e (EVar errorCont)) vWorld__
hunk ./E/FromHs.hs 310
+tCont = ELit $ LitCons tc_IOCont [tWorld__,ELit $ LitCons tc_IOError [] eStar] eStar
+tvrCont = tvr { tvrIdent = 0, tvrType = tCont }
+
hunk ./E/FromHs.hs 332
-                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> (,) (ELam tvrWorld) $
+                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
hunk ./E/FromHs.hs 335
-                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> (,) (ELam tvrWorld) $
+                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> (,) (ELam tvrCont . ELam tvrWorld) $
hunk ./Grin/Linear.hs 70
+    h Update {} = return ()
hunk ./Name/Names.hs 76
+tc_IOCont = toName TypeConstructor ("Jhc.JumpPoint","IOCont")
+tc_IOError = toName TypeConstructor ("Prelude.IOError","IOError")
hunk ./Name/Names.hs 112
+v_undefined = toName Val ("Prelude","undefined")
+v_undefinedIOErrorCont = toName Val ("Jhc.IO","undefinedIOErrorCont")
hunk ./data/PrimitiveOperators-in.hs 107
+tCont = ELit $ LitCons tc_IOCont [tWorld__,ELit $ LitCons tc_IOError [] eStar] eStar
+tvrCont = tvr { tvrIdent = 0, tvrType = tCont }
hunk ./data/PrimitiveOperators-in.hs 110
-buildPeek cn t p = ELam tvr $ ELam tvrWorld (unbox' (EVar tvr) dc_Addr tvr' rest)  where
+buildPeek cn t p = ELam tvr $ ELam tvrCont $ ELam tvrWorld (unbox' (EVar tvr) dc_Addr tvr' rest)  where
hunk ./data/PrimitiveOperators-in.hs 138
-createIO t pv = toIO t (ELam tvrWorld $  eCaseTup  (pv tvrWorld) [tvrWorld2,rtVar] (eJustIO (EVar tvrWorld2) (EVar rtVar))) where
+createIO t pv = toIO t (ELam tvrCont $ ELam tvrWorld $  eCaseTup  (pv tvrWorld) [tvrWorld2,rtVar] (eJustIO (EVar tvrWorld2) (EVar rtVar))) where
hunk ./data/PrimitiveOperators-in.hs 142
-createIO_ pv = toIO tUnit (ELam tvrWorld $  eStrictLet tvrWorld2 (pv tvrWorld)  (eJustIO (EVar tvrWorld2) vUnit)) where
+createIO_ pv = toIO tUnit (ELam tvrCont $ ELam tvrWorld $  eStrictLet tvrWorld2 (pv tvrWorld)  (eJustIO (EVar tvrWorld2) vUnit)) where
hunk ./lib/Jhc/Hole.hs 16
-foreign import primitive newHole__  :: World__ -> (s,Hole a)
+foreign import primitive newHole__  :: World__ -> (World__,Hole a)
hunk ./lib/Jhc/Hole.hs 20
-newHole = IO $ \world -> case newHole__ world of
+newHole = IO $ \_ world -> case newHole__ world of
hunk ./lib/Jhc/Hole.hs 24
-fillHole r v = IO $ \world -> case fillHole__ r v world of
+fillHole r v = IO $ \_ world -> case fillHole__ r v world of
hunk ./lib/Jhc/IO.hs 3
+import Jhc.JumpPoint
hunk ./lib/Jhc/IO.hs 9
+type IOErrorCont = IOCont World__ IOError
hunk ./lib/Jhc/IO.hs 11
-data IOResult a = FailIO World__ IOError | JustIO World__ a
-newtype IO a = IO (World__ -> IOResult a)
+--data IOResult a = FailIO World__ IOError | JustIO World__ a
+data IOResult a = JustIO World__ a
+newtype IO a = IO (IOErrorCont -> World__ -> IOResult a)
hunk ./lib/Jhc/IO.hs 16
+undefinedIOErrorCont :: IOErrorCont
+undefinedIOErrorCont = error "Jhc.IO.undefinedIOErrorCont"
+
+showError :: IOError -> IO b
+showError (IOError z) = do
+    putStrLn z
+    c_exit 255
+    return undefined
+
+errorContinuation :: (IOErrorCont -> World__ -> IOResult a) -> IO a
+errorContinuation x = newContinuation__ (\ncont -> IO $ \_ w -> x ncont w) showError
+
hunk ./lib/Jhc/IO.hs 29
-unsafePerformIO (IO x) = case x (newWorld__ x) of
-    FailIO _ z -> error $ case z of IOError z ->  z
-    JustIO _ a -> a
+unsafePerformIO (IO x) = case errorContinuation x of
+    IO y -> case y undefinedIOErrorCont (newWorld__ x) of
+        JustIO _ a -> a
hunk ./lib/Jhc/IO.hs 33
+-- we have to replace the error handler because the context might have quit by the time the value is evaluated.
hunk ./lib/Jhc/IO.hs 35
-unsafeInterleaveIO (IO action) = IO $ \w -> JustIO w $ case action w of
-    FailIO _ z -> error $ case z of IOError z ->  z
+unsafeInterleaveIO (IO action) = IO $ \c w -> JustIO w $ case action' c w of
hunk ./lib/Jhc/IO.hs 37
+    where
+    IO action' = errorContinuation action
hunk ./lib/Jhc/IO.hs 41
-    return x = IO $ \w -> JustIO w x
-    IO x >>= f = IO $ \w -> case x w of
+    return x = IO $ \_ w -> JustIO w x
+    IO x >>= f = IO $ \c w -> case x c w of
hunk ./lib/Jhc/IO.hs 44
-            IO g -> g w
-        FailIO w x -> FailIO w x
-    IO x >> IO y = IO $ \w -> case x w of
-        JustIO w _ -> y w
-        FailIO w x -> FailIO w x
+            IO g -> g c w
+    IO x >> IO y = IO $ \c w -> case x c w of
+        JustIO w _ -> y c w
hunk ./lib/Jhc/IO.hs 63
-fixIO k = IO $ \w -> let
+fixIO k = IO $ \c w -> let
hunk ./lib/Jhc/IO.hs 65
-                    IO z -> z w
+                    IO z -> z c w
hunk ./lib/Jhc/IO.hs 67
-                FailIO _ _ -> error $ "IOError"
hunk ./lib/Jhc/IO.hs 70
+ioError    ::  IOError -> IO a
+ioError e   =  (IO $ \c w -> case callContinuation c e of IO cont -> cont c w)
+
+
+catch ::  IO a -> (IOError -> IO a) -> IO a
+catch (IO x) fn = newContinuation__ (\ncont -> IO $ \_ w -> x ncont w) fn
+
hunk ./lib/Jhc/JumpPoint.hs 1
-module Jhc.JumpPoint(IOCont(),newContinuation,callContinuation) where
+module Jhc.JumpPoint(IOCont(),newContinuation,callContinuation,newContinuation__) where
hunk ./lib/Jhc/JumpPoint.hs 4
+import Jhc.IO
hunk ./lib/Jhc/JumpPoint.hs 14
-newContinuation act cc = do
+newContinuation act cc = newContinuation__ act cc
+
+
+-- | this is unsafe and should only be used internally to the IO library
+newContinuation__ :: (IOCont World__ a -> IO b) -> (a -> IO b) -> IO b
+newContinuation__ act cc = do
hunk ./lib/Jhc/JumpPoint.hs 43
-    p <- mallocBytes jmp_buf_size
+    p <- _malloc jmp_buf_size
hunk ./lib/Jhc/JumpPoint.hs 59
+foreign import ccall "stdlib.h malloc" _malloc :: Int -> IO (Ptr a)
hunk ./lib/Prelude/IO.hs 2
-    IO,
+    IO(),
+    ioError,
+    catch,
hunk ./lib/Prelude/IO.hs 41
-ioError    ::  IOError -> IO a
-ioError e   =  (IO $ \w -> FailIO w e)
-
-
-catch      ::  IO a -> (IOError -> IO a) -> IO a
-catch (IO x) fn  = IO $ \w -> case x w of
-    JustIO w' z  -> JustIO w' z
-    FailIO w' z -> case fn z of
-        IO f -> f w'
-