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