[project @ 1999-11-26 16:26:32 by simonmar]

[ghc-hetmet.git] / ghc / lib / exts / LazyST.lhs

diff --git a/ghc/lib/exts/LazyST.lhs b/ghc/lib/exts/LazyST.lhs
index 7ba3074..9b9baab 100644 (file)
--- a/ghc/lib/exts/LazyST.lhs
+++ b/ghc/lib/exts/LazyST.lhs
@@ -15,16 +15,15 @@ module LazyST (
        runST,
        unsafeInterleaveST,
 
-        -- ST is one, so you'll likely need some Monad bits
-        module Monad,
-
        ST.STRef,
        newSTRef, readSTRef, writeSTRef,
 
        STArray,
        newSTArray, readSTArray, writeSTArray, boundsSTArray, 
        thawSTArray, freezeSTArray, unsafeFreezeSTArray, 
-       Ix,
+       unsafeThawSTArray,
+
+       ST.unsafeIOToST, ST.stToIO,
 
        strictToLazyST, lazyToStrictST
     ) where
@@ -37,10 +36,12 @@ import Monad
 import Ix
 import PrelGHC
 
-newtype ST s a = ST (PrelST.State s -> (a,PrelST.State s))
+newtype ST s a = ST (State s -> (a, State s))
+
+data State s = S# (State# s)
 
 instance Functor (ST s) where
-    map f m = ST $ \ s ->
+    fmap f m = ST $ \ s ->
       let 
        ST m_a = m
        (r,new_s) = m_a s
@@ -51,6 +52,7 @@ instance Monad (ST s) where
 
         return a = ST $ \ s -> (a,s)
         m >> k   =  m >>= \ _ -> k
+       fail s   = error s
 
         (ST m) >>= k
          = ST $ \ s ->
@@ -61,8 +63,8 @@ instance Monad (ST s) where
            k_a new_s
 
 {-# NOINLINE runST #-}
-runST :: (All s => ST s a) -> a
-runST st = case st of ST st -> let (r,_) = st (PrelST.S# realWorld#) in r
+runST :: (forall s. ST s a) -> a
+runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
 \end{code}
 
 %*********************************************************
@@ -79,6 +81,7 @@ writeSTRef :: ST.STRef s a -> a -> ST s ()
 newSTRef   = strictToLazyST . ST.newSTRef
 readSTRef  = strictToLazyST . ST.readSTRef
 writeSTRef r a = strictToLazyST (ST.writeSTRef r a)
+
 \end{code}
 
 %*********************************************************
@@ -106,23 +109,27 @@ readSTArray (STArray arr) ix = strictToLazyST (readArray arr ix)
 writeSTArray (STArray arr) ix v = strictToLazyST (writeArray arr ix v)
 boundsSTArray (STArray arr) = boundsOfArray arr
 thawSTArray arr        = 
-           strictToLazyST (thawArray arr) >>= \arr -> 
-           return (STArray arr)
+           strictToLazyST (thawArray arr) >>= \ marr -> 
+           return (STArray marr)
+
 freezeSTArray (STArray arr) = strictToLazyST (freezeArray arr)
 unsafeFreezeSTArray (STArray arr) = strictToLazyST (unsafeFreezeArray arr)
+unsafeThawSTArray arr =
+           strictToLazyST (unsafeThawArray arr) >>= \ marr -> 
+           return (STArray marr)
 
 strictToLazyST :: PrelST.ST s a -> ST s a
-strictToLazyST (PrelST.ST m) = ST $ \s ->
+strictToLazyST m = ST $ \s ->
         let 
-          pr = case s of { PrelST.S# s# -> m s# }
-          r  = case pr of { PrelST.STret s2# r -> r }
-          s' = case pr of { PrelST.STret s2# r -> PrelST.S# s2# }
+          pr = case s of { S# s# -> PrelST.liftST m s# }
+          r  = case pr of { PrelST.STret _ v -> v }
+          s' = case pr of { PrelST.STret s2# _ -> S# s2# }
        in
        (r, s')
 
 lazyToStrictST :: ST s a -> PrelST.ST s a
 lazyToStrictST (ST m) = PrelST.ST $ \s ->
-        case (m (PrelST.S# s)) of (a, PrelST.S# s') -> PrelST.STret s' a
+        case (m (S# s)) of (a, S# s') -> (# s', a #)
 
 unsafeInterleaveST :: ST s a -> ST s a
 unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST