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