ghc/compiler/utils/SST.lhs

   1 \section{SST: the strict state transformer monad}
   2 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   3
   4 \begin{code}
   5 #include "HsVersions.h"
   6
   7 module SST(
   8         SYN_IE(SST), SST_R, SYN_IE(FSST), FSST_R,
   9
  10         runSST, sstToST, stToSST,
  11         thenSST, thenSST_, returnSST, fixSST,
  12         thenFSST, thenFSST_, returnFSST, failFSST,
  13         recoverFSST, recoverSST, fixFSST,
  14         unsafeInterleaveSST,
  15
  16         newMutVarSST, readMutVarSST, writeMutVarSST
  17 #if __GLASGOW_HASKELL__ >= 200
  18         , MutableVar
  19 #else
  20         , MutableVar(..), _MutableArray
  21 #endif
  22   ) where
  23
  24 #if __GLASGOW_HASKELL__ == 201
  25 import GHCbase
  26 #elif __GLASGOW_HASKELL__ >= 202
  27 import GlaExts
  28 import STBase
  29 import ArrBase
  30 import ST
  31 #else
  32 import PreludeGlaST ( MutableVar(..), _MutableArray(..), ST(..) )
  33 #endif
  34
  35 CHK_Ubiq() -- debugging consistency check
  36 \end{code}
  37
  38 \begin{code}
  39 data SST_R s r = SST_R r (State# s)
  40 type SST s r = State# s -> SST_R s r
  41
  42 \end{code}
  43
  44 \begin{code}
  45 -- converting to/from ST
  46
  47 sstToST :: SST s r -> ST s r
  48 stToSST :: ST s r -> SST s r
  49
  50 #if __GLASGOW_HASKELL__ >= 200 && __GLASGOW_HASKELL__ < 209
  51
  52 sstToST sst = ST $ \ (S# s) ->
  53    case sst s of SST_R r s' -> (r, S# s')
  54
  55 stToSST (ST st) = \ s ->
  56    case st (S# s) of (r, S# s') -> SST_R r s'
  57
  58 #elif __GLASGOW_HASKELL__ >= 209
  59
  60 sstToST sst = ST $ \ s ->
  61    case sst s of SST_R r s' -> STret s' r
  62
  63 stToSST (ST st) = \ s ->
  64    case st s of STret s' r -> SST_R r s'
  65
  66 #else
  67 sstToST sst (S# s)
  68   = case sst s of SST_R r s' -> (r, S# s')
  69 stToSST st s
  70   = case st (S# s) of (r, S# s') -> SST_R r s'
  71 #endif
  72
  73 -- Type of runSST should be builtin ...
  74 -- runSST :: forall r. (forall s. SST s r) -> r
  75
  76 #if __GLASGOW_HASKELL__ >= 200
  77 # define REAL_WORLD RealWorld
  78 # define MUT_ARRAY  MutableArray
  79 #else
  80 # define REAL_WORLD _RealWorld
  81 # define MUT_ARRAY  _MutableArray
  82 #endif
  83
  84 runSST :: SST REAL_WORLD r  -> r
  85 runSST m = case m realWorld# of SST_R r s -> r
  86
  87 unsafeInterleaveSST :: SST s r -> SST s r
  88 unsafeInterleaveSST m s = SST_R r s             -- Duplicates the state!
  89                         where
  90                           SST_R r _ = m s
  91
  92 returnSST :: r -> SST s r
  93 thenSST   :: SST s r -> (r -> State# s -> b) -> State# s -> b
  94 thenSST_  :: SST s r -> (State# s -> b) -> State# s -> b
  95 fixSST    :: (r -> SST s r) -> SST s r
  96 {-# INLINE returnSST #-}
  97 {-# INLINE thenSST #-}
  98 {-# INLINE thenSST_ #-}
  99
 100 -- Hence:
 101 --      thenSST :: SST s r -> (r -> SST  s r')     -> SST  s r'
 102 -- and  thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
 103
 104 -- Hence:
 105 --      thenSST_ :: SST s r -> SST  s r'     -> SST  s r'
 106 -- and  thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
 107
 108 thenSST  m k s = case m s of { SST_R r s' -> k r s' }
 109
 110 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
 111
 112 returnSST r s = SST_R r s
 113
 114 fixSST m s = result
 115            where
 116              result       = m loop s
 117              SST_R loop _ = result
 118 \end{code}
 119
 120
 121 \section{FSST: the failable strict state transformer monad}
 122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 123
 124 \begin{code}
 125 data FSST_R s r err
 126   = FSST_R_OK   r   (State# s)
 127   | FSST_R_Fail err (State# s)
 128
 129 type FSST s r err = State# s -> FSST_R s r err
 130 \end{code}
 131
 132 \begin{code}
 133 failFSST    :: err -> FSST s r err
 134 fixFSST     :: (r -> FSST s r err) -> FSST s r err
 135 recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
 136 recoverSST  :: (err -> SST s r) -> FSST s r err -> SST s r
 137 returnFSST  :: r -> FSST s r err
 138 thenFSST    :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
 139 thenFSST_   :: FSST s r err -> FSST s r' err -> FSST s r' err
 140 {-# INLINE failFSST #-}
 141 {-# INLINE returnFSST #-}
 142 {-# INLINE thenFSST #-}
 143 {-# INLINE thenFSST_ #-}
 144
 145 thenFSST m k s = case m s of
 146                    FSST_R_OK r s'     -> k r s'
 147                    FSST_R_Fail err s' -> FSST_R_Fail err s'
 148
 149 thenFSST_ m k s = case m s of
 150                     FSST_R_OK r s'     -> k s'
 151                     FSST_R_Fail err s' -> FSST_R_Fail err s'
 152
 153 returnFSST r s = FSST_R_OK r s
 154
 155 failFSST err s = FSST_R_Fail err s
 156
 157 recoverFSST recovery_fn m s
 158   = case m s of
 159         FSST_R_OK r s'     -> FSST_R_OK r s'
 160         FSST_R_Fail err s' -> recovery_fn err s'
 161
 162 recoverSST recovery_fn m s
 163   = case m s of
 164         FSST_R_OK r s'     -> SST_R r s'
 165         FSST_R_Fail err s' -> recovery_fn err s'
 166
 167 fixFSST m s = result
 168             where
 169               result           = m loop s
 170               FSST_R_OK loop _ = result
 171 \end{code}
 172
 173 Mutables
 174 ~~~~~~~~
 175 Here we implement mutable variables.  ToDo: get rid of the array impl.
 176
 177 \begin{code}
 178 newMutVarSST   :: a -> SST s (MutableVar s a)
 179 readMutVarSST  :: MutableVar s a -> SST s a
 180 writeMutVarSST :: MutableVar s a -> a -> SST s ()
 181
 182 newMutVarSST init s#
 183   = case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
 184     SST_R (MUT_ARRAY vAR_IXS arr#) s2# }
 185   where
 186     vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
 187
 188 readMutVarSST (MUT_ARRAY _ var#) s#
 189   = case readArray# var# 0# s#  of { StateAndPtr# s2# r ->
 190     SST_R r s2# }
 191
 192 writeMutVarSST (MUT_ARRAY _ var#) val s#
 193   = case writeArray# var# 0# val s# of { s2# ->
 194     SST_R () s2# }
 195 \end{code}
 196