[project @ 1998-01-26 11:04:18 by simonm]

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

diff --git a/ghc/lib/glaExts/LazyST.lhs b/ghc/lib/glaExts/LazyST.lhs
index d6fb8f6..d18b716 100644 (file)
--- a/ghc/lib/glaExts/LazyST.lhs
+++ b/ghc/lib/glaExts/LazyST.lhs
@@ -10,8 +10,9 @@ implementation of the state thread is lazy.
 \begin{code}
 module LazyST (
 
-       STBase.ST,
+       ST,
 
+       runST,
        unsafeInterleaveST,
 
         -- ST is one, so you'll likely need some Monad bits
@@ -20,8 +21,10 @@ module LazyST (
        ST.STRef,
        newSTRef, readSTRef, writeSTRef,
 
-       ST.STArray,
-       newSTArray, readSTArray, writeSTArray, Ix,
+       STArray,
+       newSTArray, readSTArray, writeSTArray, boundsSTArray, 
+       thawSTArray, freezeSTArray, unsafeFreezeSTArray, 
+       Ix,
 
        strictToLazyST, lazyToStrictST
     ) where
@@ -29,10 +32,11 @@ module LazyST (
 import qualified ST
 import qualified STBase
 import ArrBase
-import Unsafe   ( unsafeInterleaveST )
+import qualified UnsafeST   ( unsafeInterleaveST )
 import PrelBase        ( Eq(..), Int, Bool, ($), ()(..) )
 import Monad
 import Ix
+import GHC
 
 newtype ST s a = ST (STBase.State s -> (a,STBase.State s))
 
@@ -48,6 +52,10 @@ instance Monad (ST s) where
              ST k_a = k r
            in
            k_a new_s
+
+-- ToDo: un-inline this, it could cause problems...
+runST :: (All s => ST s a) -> a
+runST st = case st of ST st -> let (r,_) = st (STBase.S# realWorld#) in r
 \end{code}
 
 %*********************************************************
@@ -73,7 +81,7 @@ writeSTRef r a = strictToLazyST (ST.writeSTRef r a)
 %*********************************************************
 
 \begin{code}
-type STArray s ix elt = MutableArray s ix elt
+newtype STArray s ix elt = STArray (MutableArray s ix elt)
 
 newSTArray         :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
 readSTArray        :: Ix ix => STArray s ix elt -> ix -> ST s elt 
@@ -83,22 +91,32 @@ thawSTArray             :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
 freezeSTArray      :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
 unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
 
-newSTArray ixs init    = strictToLazyST (newArray ixs init)
-readSTArray arr ix     = strictToLazyST (readArray arr ix)
-writeSTArray arr ix v  = strictToLazyST (writeArray arr ix v)
-boundsSTArray          = boundsOfArray
-thawSTArray            = strictToLazyST . thawArray
-freezeSTArray          = strictToLazyST . freezeArray
-unsafeFreezeSTArray    = strictToLazyST . unsafeFreezeArray
+newSTArray ixs init    = 
+          strictToLazyST (newArray ixs init) >>= \arr ->
+          return (STArray arr)
+
+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)
+freezeSTArray (STArray arr) = strictToLazyST (freezeArray arr)
+unsafeFreezeSTArray (STArray arr) = strictToLazyST (unsafeFreezeArray arr)
 
 strictToLazyST :: STBase.ST s a -> ST s a
 strictToLazyST (STBase.ST m) = ST $ \s ->
-        let STBase.S# s# = s in
-       case m s# of { STBase.STret s2# r -> (r, STBase.S# s2#) }
+        let 
+           STBase.S# s# = s
+           STBase.STret s2# r = m s# 
+       in
+       (r, STBase.S# s2#)
 
 lazyToStrictST :: ST s a -> STBase.ST s a
 lazyToStrictST (ST m) = STBase.ST $ \s ->
         case (m (STBase.S# s)) of (a, STBase.S# s') -> STBase.STret s' a
 
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
 
 \end{code}