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