Control/Monad/ST/Lazy.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Module      :  Control.Monad.ST.Lazy
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/core/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  non-portable (requires universal quantification for runST)
  10 --
  11 -- $Id: Lazy.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $
  12 --
  13 -- This module presents an identical interface to Control.Monad.ST,
  14 -- but the underlying implementation of the state thread is lazy.
  15 --
  16 -----------------------------------------------------------------------------
  17
  18 module Control.Monad.ST.Lazy (
  19         ST,
  20
  21         runST,
  22         unsafeInterleaveST,
  23         fixST,
  24
  25         STRef.STRef,
  26         newSTRef, readSTRef, writeSTRef,
  27
  28         STArray.STArray,
  29         newSTArray, readSTArray, writeSTArray, boundsSTArray,
  30         thawSTArray, freezeSTArray, unsafeFreezeSTArray,
  31 #ifdef __GLASGOW_HASKELL__
  32 -- no 'good' reason, just doesn't support it right now.
  33         unsafeThawSTArray,
  34 #endif
  35
  36         ST.unsafeIOToST, ST.stToIO,
  37
  38         strictToLazyST, lazyToStrictST
  39     ) where
  40
  41 import Prelude
  42
  43 import qualified Data.STRef as STRef
  44 import Data.Array
  45
  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
  51 import Control.Monad
  52 import Data.Ix
  53 #endif
  54
  55 #ifdef __HUGS__
  56 import qualified ST
  57 import Monad
  58 import Ix
  59 import Array
  60 import PrelPrim ( unST
  61                  , mkST
  62                  , PrimMutableArray
  63                  , PrimArray
  64                  , primNewArray
  65                  , primReadArray
  66                  , primWriteArray
  67                  , primUnsafeFreezeArray
  68                  , primSizeMutableArray
  69                  , primSizeArray
  70                  , primIndexArray
  71                  )
  72 #endif
  73
  74
  75 #ifdef __GLASGOW_HASKELL__
  76 newtype ST s a = ST (State s -> (a, State s))
  77 data State s = S# (State# s)
  78 #endif
  79
  80 #ifdef __HUGS__
  81 newtype ST s a = ST (s -> (a,s))
  82 #endif
  83
  84 instance Functor (ST s) where
  85     fmap f m = ST $ \ s ->
  86       let
  87        ST m_a = m
  88        (r,new_s) = m_a s
  89       in
  90       (f r,new_s)
  91
  92 instance Monad (ST s) where
  93
  94         return a = ST $ \ s -> (a,s)
  95         m >> k   =  m >>= \ _ -> k
  96         fail s   = error s
  97
  98         (ST m) >>= k
  99          = ST $ \ s ->
 100            let
 101              (r,new_s) = m s
 102              ST k_a = k r
 103            in
 104            k_a new_s
 105
 106
 107 #ifdef __GLASGOW_HASKELL__
 108 {-# NOINLINE runST #-}
 109 runST :: (forall s. ST s a) -> a
 110 runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
 111 #endif
 112
 113 #ifdef __HUGS__
 114 runST :: (__forall s. ST s a) -> a
 115 runST st = case st of ST the_st -> let (r,_) = the_st realWorld in r
 116         where realWorld = error "runST: entered the RealWorld"
 117 #endif
 118
 119 fixST :: (a -> ST s a) -> ST s a
 120 fixST m = ST (\ s ->
 121                 let
 122                    ST m_r = m r
 123                    (r,s)  = m_r s
 124                 in
 125                    (r,s))
 126
 127 -- ---------------------------------------------------------------------------
 128 -- Variables
 129
 130 newSTRef   :: a -> ST s (STRef.STRef s a)
 131 readSTRef  :: STRef.STRef s a -> ST s a
 132 writeSTRef :: STRef.STRef s a -> a -> ST s ()
 133
 134 newSTRef   = strictToLazyST . STRef.newSTRef
 135 readSTRef  = strictToLazyST . STRef.readSTRef
 136 writeSTRef r a = strictToLazyST (STRef.writeSTRef r a)
 137
 138 -- --------------------------------------------------------------------------
 139 -- Arrays
 140
 141 newSTArray          :: Ix ix => (ix,ix) -> elt -> ST s (STArray.STArray s ix elt)
 142 readSTArray         :: Ix ix => STArray.STArray s ix elt -> ix -> ST s elt
 143 writeSTArray        :: Ix ix => STArray.STArray s ix elt -> ix -> elt -> ST s ()
 144 boundsSTArray       :: Ix ix => STArray.STArray s ix elt -> (ix, ix)
 145 thawSTArray         :: Ix ix => Array ix elt -> ST s (STArray.STArray s ix elt)
 146 freezeSTArray       :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
 147 unsafeFreezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
 148
 149 #ifdef __GLASGOW_HASKELL__
 150
 151 newSTArray ixs init     = strictToLazyST (STArray.newSTArray ixs init)
 152
 153 readSTArray arr ix      = strictToLazyST (STArray.readSTArray arr ix)
 154 writeSTArray arr ix v   = strictToLazyST (STArray.writeSTArray arr ix v)
 155 boundsSTArray arr       = STArray.boundsSTArray arr
 156 thawSTArray arr         = strictToLazyST (STArray.thawSTArray arr)
 157 freezeSTArray arr       = strictToLazyST (STArray.freezeSTArray arr)
 158 unsafeFreezeSTArray arr = strictToLazyST (STArray.unsafeFreezeSTArray arr)
 159 unsafeThawSTArray arr   = strictToLazyST (STArray.unsafeThawSTArray arr)
 160 #endif
 161
 162
 163 #ifdef __HUGS__
 164 newSTArray ixs elt = do
 165   { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt)
 166   ; return (STArray ixs arr)
 167   }
 168
 169 boundsSTArray (STArray ixs arr)        = ixs
 170 readSTArray   (STArray ixs arr) ix
 171         = strictToLazyST (primReadArray arr (index ixs ix))
 172 writeSTArray  (STArray ixs arr) ix elt
 173         = strictToLazyST (primWriteArray arr (index ixs ix) elt)
 174 freezeSTArray (STArray ixs arr)        = do
 175   { arr' <- strictToLazyST (primFreezeArray arr)
 176   ; return (Array ixs arr')
 177   }
 178
 179 unsafeFreezeSTArray (STArray ixs arr)  = do
 180   { arr' <- strictToLazyST (primUnsafeFreezeArray arr)
 181   ; return (Array ixs arr')
 182   }
 183
 184 thawSTArray (Array ixs arr) = do
 185   { arr' <- strictToLazyST (primThawArray arr)
 186   ; return (STArray ixs arr')
 187   }
 188
 189 primFreezeArray :: PrimMutableArray s a -> ST.ST s (PrimArray a)
 190 primFreezeArray arr = do
 191   { let n = primSizeMutableArray arr
 192   ; arr' <- primNewArray n arrEleBottom
 193   ; mapM_ (copy arr arr') [0..n-1]
 194   ; primUnsafeFreezeArray arr'
 195   }
 196  where
 197   copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
 198   arrEleBottom = error "primFreezeArray: panic"
 199
 200 primThawArray :: PrimArray a -> ST.ST s (PrimMutableArray s a)
 201 primThawArray arr = do
 202   { let n = primSizeArray arr
 203   ; arr' <- primNewArray n arrEleBottom
 204   ; mapM_ (copy arr arr') [0..n-1]
 205   ; return arr'
 206   }
 207  where
 208   copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
 209   arrEleBottom = error "primFreezeArray: panic"
 210 #endif
 211
 212 -- ---------------------------------------------------------------------------
 213 -- Strict <--> Lazy
 214
 215 #ifdef __GLASGOW_HASKELL__
 216 strictToLazyST :: ST.ST s a -> ST s a
 217 strictToLazyST m = ST $ \s ->
 218         let
 219            pr = case s of { S# s# -> GHC.ST.liftST m s# }
 220            r  = case pr of { GHC.ST.STret _ v -> v }
 221            s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }
 222         in
 223         (r, s')
 224
 225 lazyToStrictST :: ST s a -> ST.ST s a
 226 lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
 227         case (m (S# s)) of (a, S# s') -> (# s', a #)
 228 #endif
 229
 230 #ifdef __HUGS__
 231 strictToLazyST :: ST.ST s a -> ST s a
 232 strictToLazyST m = ST $ \s ->
 233         let
 234            pr = unST m s
 235            r  = fst pr
 236            s' = snd pr
 237         in
 238         (r, s')
 239
 240
 241 lazyToStrictST :: ST s a -> ST.ST s a
 242 lazyToStrictST (ST m) = mkST $ m
 243 #endif
 244
 245 unsafeInterleaveST :: ST s a -> ST s a
 246 unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST