1 -----------------------------------------------------------------------------
3 -- Module : Control.Monad.ST.Lazy
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : provisional
9 -- Portability : non-portable (requires universal quantification for runST)
11 -- $Id: Lazy.hs,v 1.2 2001/07/03 11:37:49 simonmar Exp $
13 -- This module presents an identical interface to Control.Monad.ST,
14 -- but the underlying implementation of the state thread is lazy.
16 -----------------------------------------------------------------------------
18 module Control.Monad.ST.Lazy (
26 newSTRef, readSTRef, writeSTRef,
29 newSTArray, readSTArray, writeSTArray, boundsSTArray,
30 thawSTArray, freezeSTArray, unsafeFreezeSTArray,
31 #ifdef __GLASGOW_HASKELL__
32 -- no 'good' reason, just doesn't support it right now.
36 ST.unsafeIOToST, ST.stToIO,
38 strictToLazyST, lazyToStrictST
43 import qualified Data.STRef as STRef
46 #ifdef __GLASGOW_HASKELL__
47 import qualified Control.Monad.ST as ST
48 import qualified GHC.Arr as STArray
49 import qualified GHC.ST
50 import GHC.Base ( ($), ()(..) )
61 import PrelPrim ( unST
68 , primUnsafeFreezeArray
69 , primSizeMutableArray
76 #ifdef __GLASGOW_HASKELL__
77 newtype ST s a = ST (State s -> (a, State s))
78 data State s = S# (State# s)
82 newtype ST s a = ST (s -> (a,s))
85 instance Functor (ST s) where
86 fmap f m = ST $ \ s ->
93 instance Monad (ST s) where
95 return a = ST $ \ s -> (a,s)
96 m >> k = m >>= \ _ -> k
108 #ifdef __GLASGOW_HASKELL__
109 {-# NOINLINE runST #-}
110 runST :: (forall s. ST s a) -> a
111 runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
115 runST :: (__forall s. ST s a) -> a
116 runST st = case st of ST the_st -> let (r,_) = the_st realWorld in r
117 where realWorld = error "runST: entered the RealWorld"
120 fixST :: (a -> ST s a) -> ST s a
128 -- ---------------------------------------------------------------------------
131 newSTRef :: a -> ST s (STRef.STRef s a)
132 readSTRef :: STRef.STRef s a -> ST s a
133 writeSTRef :: STRef.STRef s a -> a -> ST s ()
135 newSTRef = strictToLazyST . STRef.newSTRef
136 readSTRef = strictToLazyST . STRef.readSTRef
137 writeSTRef r a = strictToLazyST (STRef.writeSTRef r a)
139 -- --------------------------------------------------------------------------
142 newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray.STArray s ix elt)
143 readSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> ST s elt
144 writeSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> elt -> ST s ()
145 boundsSTArray :: Ix ix => STArray.STArray s ix elt -> (ix, ix)
146 thawSTArray :: Ix ix => Array ix elt -> ST s (STArray.STArray s ix elt)
147 freezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
148 unsafeFreezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
150 #ifdef __GLASGOW_HASKELL__
152 newSTArray ixs init = strictToLazyST (STArray.newSTArray ixs init)
154 readSTArray arr ix = strictToLazyST (STArray.readSTArray arr ix)
155 writeSTArray arr ix v = strictToLazyST (STArray.writeSTArray arr ix v)
156 boundsSTArray arr = STArray.boundsSTArray arr
157 thawSTArray arr = strictToLazyST (STArray.thawSTArray arr)
158 freezeSTArray arr = strictToLazyST (STArray.freezeSTArray arr)
159 unsafeFreezeSTArray arr = strictToLazyST (STArray.unsafeFreezeSTArray arr)
160 unsafeThawSTArray arr = strictToLazyST (STArray.unsafeThawSTArray arr)
165 newSTArray ixs elt = do
166 { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt)
167 ; return (STArray ixs arr)
170 boundsSTArray (STArray ixs arr) = ixs
171 readSTArray (STArray ixs arr) ix
172 = strictToLazyST (primReadArray arr (index ixs ix))
173 writeSTArray (STArray ixs arr) ix elt
174 = strictToLazyST (primWriteArray arr (index ixs ix) elt)
175 freezeSTArray (STArray ixs arr) = do
176 { arr' <- strictToLazyST (primFreezeArray arr)
177 ; return (Array ixs arr')
180 unsafeFreezeSTArray (STArray ixs arr) = do
181 { arr' <- strictToLazyST (primUnsafeFreezeArray arr)
182 ; return (Array ixs arr')
185 thawSTArray (Array ixs arr) = do
186 { arr' <- strictToLazyST (primThawArray arr)
187 ; return (STArray ixs arr')
190 primFreezeArray :: PrimMutableArray s a -> ST.ST s (PrimArray a)
191 primFreezeArray arr = do
192 { let n = primSizeMutableArray arr
193 ; arr' <- primNewArray n arrEleBottom
194 ; mapM_ (copy arr arr') [0..n-1]
195 ; primUnsafeFreezeArray arr'
198 copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
199 arrEleBottom = error "primFreezeArray: panic"
201 primThawArray :: PrimArray a -> ST.ST s (PrimMutableArray s a)
202 primThawArray arr = do
203 { let n = primSizeArray arr
204 ; arr' <- primNewArray n arrEleBottom
205 ; mapM_ (copy arr arr') [0..n-1]
209 copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
210 arrEleBottom = error "primFreezeArray: panic"
213 -- ---------------------------------------------------------------------------
216 #ifdef __GLASGOW_HASKELL__
217 strictToLazyST :: ST.ST s a -> ST s a
218 strictToLazyST m = ST $ \s ->
220 pr = case s of { S# s# -> GHC.ST.liftST m s# }
221 r = case pr of { GHC.ST.STret _ v -> v }
222 s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }
226 lazyToStrictST :: ST s a -> ST.ST s a
227 lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
228 case (m (S# s)) of (a, S# s') -> (# s', a #)
232 strictToLazyST :: ST.ST s a -> ST s a
233 strictToLazyST m = ST $ \s ->
242 lazyToStrictST :: ST s a -> ST.ST s a
243 lazyToStrictST (ST m) = mkST $ m
246 unsafeInterleaveST :: ST s a -> ST s a
247 unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST