ghc/compiler/utils/SST.lhs

   1 \section{SST: the strict state transformer monad}
   2 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   3
   4 \begin{code}
   5 module SST(
   6         SST, SST_R, FSST, FSST_R,
   7
   8         runSST, sstToST, stToSST, ioToSST,
   9         thenSST, thenSST_, returnSST, fixSST,
  10         thenFSST, thenFSST_, returnFSST, failFSST,
  11         recoverFSST, recoverSST, fixFSST,
  12         unsafeInterleaveSST,
  13
  14         newMutVarSST, readMutVarSST, writeMutVarSST,
  15         SSTRef
  16   ) where
  17
  18 #include "HsVersions.h"
  19
  20 import GlaExts
  21 import ST
  22
  23 #if __GLASGOW_HASKELL__ < 301
  24 import STBase           ( ST(..), STret(..), StateAndPtr#(..) )
  25 import ArrBase          ( StateAndMutableArray#(..) )
  26 import IOBase           ( IO(..), IOResult(..) )
  27 #elif __GLASGOW_HASKELL__ < 400
  28 import PrelST           ( ST(..), STret(..), StateAndPtr#(..) )
  29 import PrelArr          ( StateAndMutableArray#(..) )
  30 import PrelIOBase       ( IO(..), IOResult(..) )
  31 #else
  32 import PrelST           ( ST(..), STret(..) )
  33 import PrelArr          ( MutableVar(..) )
  34 import PrelIOBase       ( IO(..) )
  35 #endif
  36
  37 \end{code}
  38
  39 @SST@ is very like the standard @ST@ monad, but it comes with its
  40 friend @FSST@.  Because we want the monadic bind operator to work
  41 for mixtures of @SST@ and @FSST@, we can't use @ST@ at all.
  42
  43 For simplicity we don't even dress them up in newtypes.
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{The data types}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 \begin{code}
  52 type SST  s r     = State# s -> SST_R s r
  53 type FSST s r err = State# s -> FSST_R s r err
  54
  55 data SST_R s r = SST_R r (State# s)
  56
  57 data FSST_R s r err
  58   = FSST_R_OK   r   (State# s)
  59   | FSST_R_Fail err (State# s)
  60 \end{code}
  61
  62 Converting to/from ST
  63
  64 \begin{code}
  65 sstToST :: SST s r -> ST s r
  66 stToSST :: ST s r -> SST s r
  67
  68
  69 #if __GLASGOW_HASKELL__ < 400
  70 stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s'
  71 sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
  72 #else
  73 stToSST (ST st) = \ s -> case st s of (# s', r #) -> SST_R r s'
  74 sstToST sst = ST (\ s -> case sst s of SST_R r s' -> (# s', r #))
  75 #endif
  76 \end{code}
  77
  78 ...and IO
  79
  80 \begin{code}
  81 ioToSST :: IO a -> SST RealWorld (Either IOError a)
  82
  83 #if __GLASGOW_HASKELL__ < 400
  84 ioToSST (IO io)
  85   = \s -> case io s of
  86             IOok   s' r   -> SST_R (Right r) s'
  87             IOfail s' err -> SST_R (Left err) s'
  88 #else
  89
  90 -- We should probably be using ST and exceptions instead of SST here, now
  91 -- that GHC has exceptions and ST is strict.
  92
  93 ioToSST io
  94   = \s -> case catch (io >>= return . Right) (return . Left) of { IO m ->
  95           case m s of {
  96                 (# s', r #) -> SST_R r s'
  97           } }
  98 #endif
  99
 100 \end{code}
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsection{The @SST@ operations}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108 \begin{code}
 109 -- Type of runSST should be builtin ...
 110 -- runSST :: forall r. (forall s. SST s r) -> r
 111
 112 runSST :: SST RealWorld r  -> r
 113 runSST m = case m realWorld# of SST_R r s -> r
 114
 115 unsafeInterleaveSST :: SST s r -> SST s r
 116 unsafeInterleaveSST m s = SST_R r s             -- Duplicates the state!
 117                         where
 118                           SST_R r _ = m s
 119
 120 returnSST :: r -> SST s r
 121 fixSST    :: (r -> SST s r) -> SST s r
 122 {-# INLINE returnSST #-}
 123 {-# INLINE thenSST #-}
 124 {-# INLINE thenSST_ #-}
 125
 126 returnSST r s = SST_R r s
 127
 128 fixSST m s = result
 129            where
 130              result       = m loop s
 131              SST_R loop _ = result
 132 \end{code}
 133
 134 OK, here comes the clever bind operator.
 135
 136 \begin{code}
 137 thenSST   :: SST s r -> (r -> State# s -> b) -> State# s -> b
 138 thenSST_  :: SST s r -> (State# s -> b) -> State# s -> b
 139 -- Hence:
 140 --      thenSST :: SST s r -> (r -> SST  s r')     -> SST  s r'
 141 -- and  thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
 142
 143 -- Hence:
 144 --      thenSST_ :: SST s r -> SST  s r'     -> SST  s r'
 145 -- and  thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
 146
 147 thenSST  m k s = case m s of { SST_R r s' -> k r s' }
 148
 149 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
 150 \end{code}
 151
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection{FSST: the failable strict state transformer monad}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 \begin{code}
 160 failFSST    :: err -> FSST s r err
 161 fixFSST     :: (r -> FSST s r err) -> FSST s r err
 162 recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
 163 recoverSST  :: (err -> SST s r) -> FSST s r err -> SST s r
 164 returnFSST  :: r -> FSST s r err
 165 thenFSST    :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
 166 thenFSST_   :: FSST s r err -> FSST s r' err -> FSST s r' err
 167 {-# INLINE failFSST #-}
 168 {-# INLINE returnFSST #-}
 169 {-# INLINE thenFSST #-}
 170 {-# INLINE thenFSST_ #-}
 171
 172 thenFSST m k s = case m s of
 173                    FSST_R_OK r s'     -> k r s'
 174                    FSST_R_Fail err s' -> FSST_R_Fail err s'
 175
 176 thenFSST_ m k s = case m s of
 177                     FSST_R_OK r s'     -> k s'
 178                     FSST_R_Fail err s' -> FSST_R_Fail err s'
 179
 180 returnFSST r s = FSST_R_OK r s
 181
 182 failFSST err s = FSST_R_Fail err s
 183
 184 recoverFSST recovery_fn m s
 185   = case m s of
 186         FSST_R_OK r s'     -> FSST_R_OK r s'
 187         FSST_R_Fail err s' -> recovery_fn err s'
 188
 189 recoverSST recovery_fn m s
 190   = case m s of
 191         FSST_R_OK r s'     -> SST_R r s'
 192         FSST_R_Fail err s' -> recovery_fn err s'
 193
 194 fixFSST m s = result
 195             where
 196               result           = m loop s
 197               FSST_R_OK loop _ = result
 198 \end{code}
 199
 200 %************************************************************************
 201 %*                                                                      *
 202 \subsection{Mutables}
 203 %*                                                                      *
 204 %************************************************************************
 205
 206 Here we implement mutable variables.
 207
 208 \begin{code}
 209 #if __GLASGOW_HASKELL__ < 400
 210 type SSTRef s a = MutableArray s Int a
 211 #else
 212 type SSTRef s a = MutableVar s a
 213 #endif
 214
 215 newMutVarSST   :: a -> SST s (SSTRef s a)
 216 readMutVarSST  :: SSTRef s a -> SST s a
 217 writeMutVarSST :: SSTRef s a -> a -> SST s ()
 218
 219 #if __GLASGOW_HASKELL__ < 400
 220
 221 newMutVarSST init s#
 222   = case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
 223     SST_R (MutableArray vAR_IXS arr#) s2# }
 224   where
 225     vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
 226
 227 readMutVarSST (MutableArray _ var#) s#
 228   = case readArray# var# 0# s#  of { StateAndPtr# s2# r ->
 229     SST_R r s2# }
 230
 231 writeMutVarSST (MutableArray _ var#) val s#
 232   = case writeArray# var# 0# val s# of { s2# ->
 233     SST_R () s2# }
 234
 235 #else
 236
 237 newMutVarSST init s#
 238   = case (newMutVar# init s#) of { (# s2#, var# #) ->
 239     SST_R (MutableVar var#) s2# }
 240
 241 readMutVarSST (MutableVar var#) s#
 242   = case readMutVar# var# s#    of { (# s2#, r #) ->
 243     SST_R r s2# }
 244
 245 writeMutVarSST (MutableVar var#) val s#
 246   = case writeMutVar# var# val s# of { s2# ->
 247     SST_R () s2# }
 248
 249 #endif
 250 \end{code}
 251