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 #else
  28 import PrelST           ( ST(..), STret(..), StateAndPtr#(..) )
  29 import PrelArr          ( StateAndMutableArray#(..) )
  30 import PrelIOBase       ( IO(..), IOResult(..) )
  31 #endif
  32
  33 \end{code}
  34
  35 @SST@ is very like the standard @ST@ monad, but it comes with its
  36 friend @FSST@.  Because we want the monadic bind operator to work
  37 for mixtures of @SST@ and @FSST@, we can't use @ST@ at all.
  38
  39 For simplicity we don't even dress them up in newtypes.
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection{The data types}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 \begin{code}
  48 type SST  s r     = State# s -> SST_R s r
  49 type FSST s r err = State# s -> FSST_R s r err
  50
  51 data SST_R s r = SST_R r (State# s)
  52
  53 data FSST_R s r err
  54   = FSST_R_OK   r   (State# s)
  55   | FSST_R_Fail err (State# s)
  56 \end{code}
  57
  58 Converting to/from ST
  59
  60 \begin{code}
  61 sstToST :: SST s r -> ST s r
  62 stToSST :: ST s r -> SST s r
  63
  64 sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
  65
  66 stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s'
  67 \end{code}
  68
  69 ...and IO
  70
  71 \begin{code}
  72 ioToSST :: IO a -> SST RealWorld (Either IOError a)
  73 ioToSST (IO io)
  74   = \s -> case io s of
  75             IOok   s' r   -> SST_R (Right r) s'
  76             IOfail s' err -> SST_R (Left err) s'
  77 \end{code}
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection{The @SST@ operations}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 -- Type of runSST should be builtin ...
  87 -- runSST :: forall r. (forall s. SST s r) -> r
  88
  89 runSST :: SST RealWorld r  -> r
  90 runSST m = case m realWorld# of SST_R r s -> r
  91
  92 unsafeInterleaveSST :: SST s r -> SST s r
  93 unsafeInterleaveSST m s = SST_R r s             -- Duplicates the state!
  94                         where
  95                           SST_R r _ = m s
  96
  97 returnSST :: r -> SST s r
  98 fixSST    :: (r -> SST s r) -> SST s r
  99 {-# INLINE returnSST #-}
 100 {-# INLINE thenSST #-}
 101 {-# INLINE thenSST_ #-}
 102
 103 returnSST r s = SST_R r s
 104
 105 fixSST m s = result
 106            where
 107              result       = m loop s
 108              SST_R loop _ = result
 109 \end{code}
 110
 111 OK, here comes the clever bind operator.
 112
 113 \begin{code}
 114 thenSST   :: SST s r -> (r -> State# s -> b) -> State# s -> b
 115 thenSST_  :: SST s r -> (State# s -> b) -> State# s -> b
 116 -- Hence:
 117 --      thenSST :: SST s r -> (r -> SST  s r')     -> SST  s r'
 118 -- and  thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
 119
 120 -- Hence:
 121 --      thenSST_ :: SST s r -> SST  s r'     -> SST  s r'
 122 -- and  thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
 123
 124 thenSST  m k s = case m s of { SST_R r s' -> k r s' }
 125
 126 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
 127 \end{code}
 128
 129
 130 %************************************************************************
 131 %*                                                                      *
 132 \subsection{FSST: the failable strict state transformer monad}
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 \begin{code}
 137 failFSST    :: err -> FSST s r err
 138 fixFSST     :: (r -> FSST s r err) -> FSST s r err
 139 recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
 140 recoverSST  :: (err -> SST s r) -> FSST s r err -> SST s r
 141 returnFSST  :: r -> FSST s r err
 142 thenFSST    :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
 143 thenFSST_   :: FSST s r err -> FSST s r' err -> FSST s r' err
 144 {-# INLINE failFSST #-}
 145 {-# INLINE returnFSST #-}
 146 {-# INLINE thenFSST #-}
 147 {-# INLINE thenFSST_ #-}
 148
 149 thenFSST m k s = case m s of
 150                    FSST_R_OK r s'     -> k r s'
 151                    FSST_R_Fail err s' -> FSST_R_Fail err s'
 152
 153 thenFSST_ m k s = case m s of
 154                     FSST_R_OK r s'     -> k s'
 155                     FSST_R_Fail err s' -> FSST_R_Fail err s'
 156
 157 returnFSST r s = FSST_R_OK r s
 158
 159 failFSST err s = FSST_R_Fail err s
 160
 161 recoverFSST recovery_fn m s
 162   = case m s of
 163         FSST_R_OK r s'     -> FSST_R_OK r s'
 164         FSST_R_Fail err s' -> recovery_fn err s'
 165
 166 recoverSST recovery_fn m s
 167   = case m s of
 168         FSST_R_OK r s'     -> SST_R r s'
 169         FSST_R_Fail err s' -> recovery_fn err s'
 170
 171 fixFSST m s = result
 172             where
 173               result           = m loop s
 174               FSST_R_OK loop _ = result
 175 \end{code}
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection{Mutables}
 180 %*                                                                      *
 181 %************************************************************************
 182
 183 Here we implement mutable variables.  ToDo: get rid of the array impl.
 184
 185 \begin{code}
 186 type SSTRef s a = MutableArray s Int a
 187
 188 newMutVarSST   :: a -> SST s (SSTRef s a)
 189 readMutVarSST  :: SSTRef s a -> SST s a
 190 writeMutVarSST :: SSTRef s a -> a -> SST s ()
 191
 192 newMutVarSST init s#
 193   = case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
 194     SST_R (MutableArray vAR_IXS arr#) s2# }
 195   where
 196     vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
 197
 198 readMutVarSST (MutableArray _ var#) s#
 199   = case readArray# var# 0# s#  of { StateAndPtr# s2# r ->
 200     SST_R r s2# }
 201
 202 writeMutVarSST (MutableArray _ var#) val s#
 203   = case writeArray# var# 0# val s# of { s2# ->
 204     SST_R () s2# }
 205 \end{code}
 206