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 :  portable
  10 --
  11 -- $Id: Lazy.hs,v 1.1 2001/06/28 14:15:02 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 import GHC.Prim
  54 #endif
  55
  56 #ifdef __HUGS__
  57 import qualified ST
  58 import Monad
  59 import Ix
  60 import Array
  61 import PrelPrim ( unST
  62                  , mkST
  63                  , PrimMutableArray
  64                  , PrimArray
  65                  , primNewArray
  66                  , primReadArray
  67                  , primWriteArray
  68                  , primUnsafeFreezeArray
  69                  , primSizeMutableArray
  70                  , primSizeArray
  71                  , primIndexArray
  72                  )
  73 #endif
  74
  75
  76 #ifdef __GLASGOW_HASKELL__
  77 newtype ST s a = ST (State s -> (a, State s))
  78 data State s = S# (State# s)
  79 #endif
  80
  81 #ifdef __HUGS__
  82 newtype ST s a = ST (s -> (a,s))
  83 #endif
  84
  85 instance Functor (ST s) where
  86     fmap f m = ST $ \ s ->
  87       let
  88        ST m_a = m
  89        (r,new_s) = m_a s
  90       in
  91       (f r,new_s)
  92
  93 instance Monad (ST s) where
  94
  95         return a = ST $ \ s -> (a,s)
  96         m >> k   =  m >>= \ _ -> k
  97         fail s   = error s
  98
  99         (ST m) >>= k
 100          = ST $ \ s ->
 101            let
 102              (r,new_s) = m s
 103              ST k_a = k r
 104            in
 105            k_a new_s
 106
 107
 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
 112 #endif
 113
 114 #ifdef __HUGS__
 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"
 118 #endif
 119
 120 fixST :: (a -> ST s a) -> ST s a
 121 fixST m = ST (\ s ->
 122                 let
 123                    ST m_r = m r
 124                    (r,s)  = m_r s
 125                 in
 126                    (r,s))
 127
 128 -- ---------------------------------------------------------------------------
 129 -- Variables
 130
 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 ()
 134
 135 newSTRef   = strictToLazyST . STRef.newSTRef
 136 readSTRef  = strictToLazyST . STRef.readSTRef
 137 writeSTRef r a = strictToLazyST (STRef.writeSTRef r a)
 138
 139 -- --------------------------------------------------------------------------
 140 -- Arrays
 141
 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)
 149
 150 #ifdef __GLASGOW_HASKELL__
 151
 152 newSTArray ixs init     = strictToLazyST (STArray.newSTArray ixs init)
 153
 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)
 161 #endif
 162
 163
 164 #ifdef __HUGS__
 165 newSTArray ixs elt = do
 166   { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt)
 167   ; return (STArray ixs arr)
 168   }
 169
 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')
 178   }
 179
 180 unsafeFreezeSTArray (STArray ixs arr)  = do
 181   { arr' <- strictToLazyST (primUnsafeFreezeArray arr)
 182   ; return (Array ixs arr')
 183   }
 184
 185 thawSTArray (Array ixs arr) = do
 186   { arr' <- strictToLazyST (primThawArray arr)
 187   ; return (STArray ixs arr')
 188   }
 189
 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'
 196   }
 197  where
 198   copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
 199   arrEleBottom = error "primFreezeArray: panic"
 200
 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]
 206   ; return arr'
 207   }
 208  where
 209   copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
 210   arrEleBottom = error "primFreezeArray: panic"
 211 #endif
 212
 213 -- ---------------------------------------------------------------------------
 214 -- Strict <--> Lazy
 215
 216 #ifdef __GLASGOW_HASKELL__
 217 strictToLazyST :: ST.ST s a -> ST s a
 218 strictToLazyST m = ST $ \s ->
 219         let
 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# }
 223         in
 224         (r, s')
 225
 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 #)
 229 #endif
 230
 231 #ifdef __HUGS__
 232 strictToLazyST :: ST.ST s a -> ST s a
 233 strictToLazyST m = ST $ \s ->
 234         let
 235            pr = unST m s
 236            r  = fst pr
 237            s' = snd pr
 238         in
 239         (r, s')
 240
 241
 242 lazyToStrictST :: ST s a -> ST.ST s a
 243 lazyToStrictST (ST m) = mkST $ m
 244 #endif
 245
 246 unsafeInterleaveST :: ST s a -> ST s a
 247 unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST