[make IO a newtype of ST
John Meacham <john@repetae.net>**20120131214951
 Ignore-this: edb87ba731c5f6146e7e349a709dd7b8
] hunk ./lib/base/Data/Array/IO.hs 4
-import Jhc.Basics
+import Data.Array
hunk ./lib/base/Data/Array/IO.hs 7
+import Jhc.Basics
hunk ./lib/base/Data/Array/IO.hs 10
-import Data.Array
hunk ./lib/base/Data/Array/IO.hs 14
-newIOArray rng fill = IO (newIOArray_ rng fill)
+newIOArray rng fill = fromUIO (newIOArray_ rng fill)
hunk ./lib/base/Data/Array/IO.hs 28
-      i' -> IO (readArray__ arr i')
+      i' -> fromUIO (readArray__ arr i')
hunk ./lib/base/Data/Array/IO.hs 33
-      i' -> IO (\w1 -> case writeArray__ arr i' x w1 of
+      i' -> fromUIO (\w1 -> case writeArray__ arr i' x w1 of
hunk ./lib/base/Data/Array/IO.hs 37
-unsafeReadIOArray (IOA l h arr) i = case unboxInt i of i' -> IO (readArray__ arr i')
+unsafeReadIOArray (IOA l h arr) i = case unboxInt i of i' -> fromUIO (readArray__ arr i')
hunk ./lib/base/Data/Array/IO.hs 41
-    case unboxInt i of i' -> IO (\w1 -> case writeArray__ arr i' x w1 of
+    case unboxInt i of i' -> fromUIO (\w1 -> case writeArray__ arr i' x w1 of
hunk ./lib/base/Data/IORef.hs 19
-
hunk ./lib/base/Data/IORef.hs 25
-newIORef v = IO $ \w -> case newRef__ v w of (# w', r #) -> (# w', IORef r #)
-
+newIORef v = fromUIO $ \w -> case newRef__ v w of (# w', r #) -> (# w', IORef r #)
hunk ./lib/base/Data/IORef.hs 29
-readIORef (IORef r) = IO $ \w -> readRef__ r w
+readIORef (IORef r) = fromUIO $ \w -> readRef__ r w
hunk ./lib/base/Data/IORef.hs 33
-writeIORef (IORef r) v = IO $ \w -> case writeRef__ r v w of w' -> (# w', () #)
+writeIORef (IORef r) v = fromUIO $ \w -> case writeRef__ r v w of w' -> (# w', () #)
hunk ./lib/base/Data/IORef.hs 40
-
hunk ./lib/base/Data/IORef.hs 42
-modifyIORef (IORef ref) f = IO $ \w -> case readRef__ ref w of
+modifyIORef (IORef ref) f = fromUIO $ \w -> case readRef__ ref w of
hunk ./lib/base/Data/IORef.hs 48
-atomicModifyIORef (IORef r) f = IO $ \w -> case readRef__ r w of
+atomicModifyIORef (IORef r) f = fromUIO $ \w -> case readRef__ r w of
hunk ./lib/jhc-prim/Jhc/Prim/IO.hs 1
+{-# LANGUAGE UnboxedTuples #-}
hunk ./lib/jhc-prim/Jhc/Prim/IO.hs 9
+-- Aliases for common State_ related types. Useful in foreign imports.
hunk ./lib/jhc-prim/Jhc/Prim/IO.hs 12
+-- Aliases specialized for the world.
hunk ./lib/jhc-prim/Jhc/Prim/IO.hs 14
-type UIO_ = World__ -> World__
+type UIO_ = UST_ RealWorld
hunk ./lib/jhc-prim/Jhc/Prim/IO.hs 16
-newtype IO a = IO (UST RealWorld a)
hunk ./lib/jhc-prim/Jhc/Prim/IO.hs 17
+newtype IO a = IO (ST RealWorld a)
hunk ./lib/jhc-prim/Jhc/Prim/IO.hs 20
--- | note the implicit unsafeCoerce__ here!
+-- Note the implicit unsafeCoerce__ here!
+-- We currently don't allow exeptions in general ST monads as a design choice.
hunk ./lib/jhc-prim/Jhc/Prim/Wrapper.hs 7
-runNoWrapper (IO run) w = case run w of (# w, _ #) -> w
+runNoWrapper (IO (ST run)) w = case run w of (# w, _ #) -> w
hunk ./lib/jhc/Foreign/Storable.hs 23
-    peekElemOff addr idx = IO $ \w -> unIO (peek $! (addr `plusPtr` (idx `times` sizeOf (_f addr)))) w
-    pokeElemOff addr idx x = IO $ \w -> unIO (let adr = (addr `plusPtr` (idx `times` sizeOf x)) in adr `seq` poke adr x) w
-    peekByteOff addr off = IO $ \w -> unIO (peek $! (castPtr $ addr `plusPtr` off)) w
-    pokeByteOff addr off x = IO $ \w -> unIO (let adr = castPtr (addr `plusPtr` off) in adr `seq` poke adr x) w
+    peekElemOff addr idx = fromUIO $ \w -> unIO (peek $! (addr `plusPtr` (idx `times` sizeOf (_f addr)))) w
+    pokeElemOff addr idx x = fromUIO $ \w -> unIO (let adr = (addr `plusPtr` (idx `times` sizeOf x)) in adr `seq` poke adr x) w
+    peekByteOff addr off = fromUIO $ \w -> unIO (peek $! (castPtr $ addr `plusPtr` off)) w
+    pokeByteOff addr off x = fromUIO $ \w -> unIO (let adr = castPtr (addr `plusPtr` off) in adr `seq` poke adr x) w
hunk ./lib/jhc/Foreign/Storable.m4 5
-    peek (Ptr addr) = IO $ \w -> case peek$2 addr w of
+    peek (Ptr addr) = fromUIO $ \w -> case peek$2 addr w of
hunk ./lib/jhc/Foreign/Storable.m4 7
-    poke (Ptr addr) ($2 v) = IO $ \w -> case poke$2 addr v w of
+    poke (Ptr addr) ($2 v) = fromUIO $ \w -> case poke$2 addr v w of
hunk ./lib/jhc/Foreign/Storable.m4 21
-    peek (Ptr addr) = IO $ \w -> case peek$2 addr w of
+    peek (Ptr addr) = fromUIO $ \w -> case peek$2 addr w of
hunk ./lib/jhc/Foreign/Storable.m4 23
-    poke (Ptr addr) v = IO $ \w -> case poke$2 addr (unbox$2 v) w of
+    poke (Ptr addr) v = fromUIO $ \w -> case poke$2 addr (unbox$2 v) w of
hunk ./lib/jhc/Jhc/IO.hs 8
+    fromUIO,
+    fromUIO_,
hunk ./lib/jhc/Jhc/IO.hs 42
-unIO (IO x) = x
+unIO (IO (ST x)) = x
hunk ./lib/jhc/Jhc/IO.hs 45
-fromUIO x = IO x
+fromUIO x = IO (ST x)
hunk ./lib/jhc/Jhc/IO.hs 48
-fromUIO_ f = IO $ \w -> (# f w, () #)
+fromUIO_ f = IO $ ST (\w -> (# f w, () #))
hunk ./lib/jhc/Jhc/IO.hs 53
-etaIO x = IO $ \w -> unIO x w
+etaIO x = fromUIO (\w -> unIO x w)
hunk ./lib/jhc/Jhc/IO.hs 59
-    world -> case errorContinuation x of
-        IO y -> case y world of
+    world -> case unIO (errorContinuation x) world of
hunk ./lib/jhc/Jhc/IO.hs 70
-unsafeInterleaveIO action = IO $ \w -> (# w , case action' w of (# _,  a #) -> a #)
-    where IO action' = errorContinuation action
+unsafeInterleaveIO action = fromUIO $ \w -> (# w , case action' w of (# _,  a #) -> a #)
+    where action' = unIO $ errorContinuation action
hunk ./lib/jhc/Jhc/IO.hs 84
-    Jhc.Options.GhcHs -> IO $
+    Jhc.Options.GhcHs -> fromUIO $
hunk ./lib/jhc/Jhc/IO.hs 89
-catch (IO m) k =  case Jhc.Options.target of
-    Jhc.Options.GhcHs -> IO $ \s -> catch__ m (\ex -> unIO (k ex)) s
-    _ -> IO m  -- no catching on other targets just yet
+catch a k =  case Jhc.Options.target of
+    Jhc.Options.GhcHs -> fromUIO $ \s -> catch__ (unIO a) (\ex -> unIO (k ex)) s
+    _ -> a  -- no catching on other targets just yet
hunk ./lib/jhc/Jhc/IO.hs 98
-fixIO k = IO $ \w -> let r = case k ans of
-                               IO z -> case z w of
+fixIO k = fromUIO $ \w -> let r = case k ans of
+                               IO (ST z) -> case z w of
hunk ./lib/jhc/Jhc/IO.hs 101
-                         ans = case r of
+                              ans = case r of
hunk ./lib/jhc/Jhc/IO.hs 114
-strictReturn a = IO $ \w -> (# w, worldDep__ a w #)
+strictReturn a = IO $ ST $ \w -> (# w, worldDep__ a w #)
hunk ./lib/jhc/Jhc/IO.hs 122
-    IO run = catch main $ \e ->
+    IO (ST run) = catch main $ \e ->
hunk ./lib/jhc/Jhc/IO.hs 128
-exitFailure = IO $ \w -> exitFailure__ w
+exitFailure = IO $ ST $ \w -> exitFailure__ w
hunk ./lib/jhc/Jhc/IO.hs 133
-IO a `thenIO_` IO b = IO $ \w -> case a w of
+IO (ST a) `thenIO_` IO (ST b) = IO $ ST $ \w -> case a w of
hunk ./lib/jhc/Jhc/IO.hs 136
-IO a `thenIO` b = IO $ \w -> case a w of
+IO (ST a) `thenIO` b = IO $ ST $ \w -> case a w of
hunk ./lib/jhc/Jhc/IO.hs 140
-returnIO x = IO $ \w -> (# w, x #)
+returnIO x = IO $ ST (\w -> (# w, x #))
hunk ./lib/jhc/Jhc/Monad.hs 6
+import Jhc.Prim.IO
hunk ./lib/jhc/Jhc/Monad.hs 80
-instance Monad IO where
-    return x = IO $ \w -> (# w, x #)
-    IO x >>= f = IO $ \w -> case x w of
+instance Monad (ST s) where
+    return x = ST $ \w -> (# w, x #)
+    ST x >>= f = ST $ \w -> case x w of
hunk ./lib/jhc/Jhc/Monad.hs 84
-            IO g -> g w
-    IO x >> IO y = IO $ \w -> case x w of
+            ST g -> g w
+    ST x >> ST y = ST $ \w -> case x w of
hunk ./lib/jhc/Jhc/Monad.hs 87
+--    fail s = ioError $ userError s
+
+instance Monad IO where
+    return x = fromUIO $ \w -> (# w, x #)
+    x >> y =  x `thenIO_` y
hunk ./lib/jhc/Jhc/Monad.hs 93
+    x >>= f = fromUIO $ \w -> case unIO x w of
+        (# w, v #) -> unIO (f v) w
hunk ./lib/jhc/Jhc/Prim.hs 9
---data Int
---data Char = Char Char_
-
---type Bool__ = Bits16_ -- Change to Bits1_ when the time comes
---type Int__  = Bits32_
---type Char__ = Bits32_
---type Enum__ = Bits16_
-
--- | when no exception wrapper is wanted
-runNoWrapper :: IO a -> World__ -> World__
-runNoWrapper (IO run) w = case run w of (# w, _ #) -> w
-
hunk ./regress/regress.prl 155
-my @libs = $opt_l ? ("-L-", "-L$jhc_dir", "-pjhc") : ("--noauto", "-i$jhc_dir/lib/jhc", "-i$jhc_dir/lib/base","-i$jhc_dir/lib/haskell98");
+my @libs = $opt_l ? ("-L-", "-L$jhc_dir", "-pjhc") : ("--noauto", "-i$jhc_dir/lib/jhc", "-i$jhc_dir/lib/base",
+        "-i$jhc_dir/lib/haskell98", "-i$jhc_dir/lib/jhc-prim", "-XUnboxedTuples", "-XForeignFunctionInterface", "-XUnboxedValues");