ghc/compiler/basicTypes/SplitUniq.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1995
   3 %
   4 \section[Unique]{The @SplitUniqSupply@ data type (``splittable Unique supply'')}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SplitUniq (
  10         SplitUniqSupply,                -- abstract types
  11
  12         getSUnique, getSUniques,        -- basic ops
  13         getSUniqueAndDepleted, getSUniquesAndDepleted,  -- DEPRECATED!
  14
  15         SUniqSM(..),            -- type: unique supply monad
  16         initSUs, thenSUs, returnSUs,
  17         mapSUs, mapAndUnzipSUs,
  18
  19         mkSplitUniqSupply,
  20         splitUniqSupply,
  21
  22         -- to make interface self-sufficient
  23         Unique
  24         IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
  25
  26 #ifndef __GLASGOW_HASKELL__
  27         ,TAG_
  28 #endif
  29     ) where
  30
  31 import Outputable       -- class for printing, forcing
  32 import Pretty           -- pretty-printing utilities
  33 import PrimOps          -- ** DIRECTLY **
  34 import Unique
  35 import Util
  36
  37 #if defined(__HBC__)
  38 {-hide import from mkdependHS-}
  39 import
  40         Word
  41 import
  42         NameSupply      renaming ( Name to HBC_Name )
  43 #endif
  44 #ifdef __GLASGOW_HASKELL__
  45 # if __GLASGOW_HASKELL__ >= 26
  46 import PreludeGlaST
  47 # else
  48 import PreludePrimIO
  49 import PreludeGlaST     ( unsafeInterleaveST
  50                           IF_ATTACK_PRAGMAS(COMMA fixST)
  51                         )
  52 # endif
  53 #endif
  54
  55 infixr 9 `thenUs`
  56
  57 #ifdef __GLASGOW_HASKELL__
  58 w2i x = word2Int# x
  59 i2w x = int2Word# x
  60 i2w_s x = (x :: Int#)
  61 #endif
  62 \end{code}
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection[SplitUniqSupply-type]{@SplitUniqSupply@ type and operations}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 A value of type @SplitUniqSupply@ is unique, and it can
  71 supply {\em one} distinct @Unique@.  Also, from the supply, one can
  72 also manufacture an arbitrary number of further @UniqueSupplies@,
  73 which will be distinct from the first and from all others.
  74
  75 Common type signatures
  76 \begin{code}
  77 -- mkSplitUniqSupply :: differs by implementation!
  78
  79 splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
  80 getSUnique :: SplitUniqSupply -> Unique
  81 getSUniques :: Int -> SplitUniqSupply -> [Unique]
  82 getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply)
  83 getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply)
  84 \end{code}
  85
  86 %************************************************************************
  87 %*                                                                      *
  88 \subsubsection{Chalmers implementation of @SplitUniqSupply@}
  89 %*                                                                      *
  90 %************************************************************************
  91
  92 \begin{code}
  93 #if defined(__HBC__)
  94
  95 data SplitUniqSupply = MkSplit NameSupply
  96
  97 mkSplitUniqSupply :: Char -> SplitUniqSupply -- NB: not the same type
  98
  99 mkSplitUniqSupply _ = MkSplit initialNameSupply
 100
 101 splitUniqSupply (MkSplit us)
 102   = case (splitNameSupply us) of { (s1, s2) ->
 103     (MkSplit s1, MkSplit s2) }
 104
 105 getSUnique supply = error "getSUnique" -- mkUniqueGrimily (getName supply)
 106
 107 getSUniques i supply
 108   = error "getSUniques" -- [ mkUniqueGrimily (getName s) | s <- take i (listNameSupply supply) ]
 109
 110 getSUniqueAndDepleted supply
 111   = error "getSUniqueAndDepleted"
 112 {-
 113     let
 114         u = mkUniqueGrimily (getName supply)
 115         (s1, _) = splitNameSupply supply
 116     in
 117     (u, s1)
 118 -}
 119
 120 getSUniquesAndDepleted i supply
 121   = error "getSUniquesAndDepleted"
 122 {-
 123   = let
 124         supplies = take (i+1) (listNameSupply supply)
 125         uniqs    = [ mkUniqueGrimily (getName s) | s <- take i supplies ]
 126         last_supply = drop i supplies
 127     in
 128     (uniqs, last_supply)
 129 -}
 130
 131 #endif {- end of Chalmers implementation -}
 132 \end{code}
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsubsection{Glasgow implementation of @SplitUniqSupply@}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 Glasgow Haskell implementation:
 141 \begin{code}
 142 #ifdef __GLASGOW_HASKELL__
 143
 144 # ifdef IGNORE_REFERENTIAL_TRANSPARENCY
 145
 146 data SplitUniqSupply = MkSplitUniqSupply {-does nothing-}
 147
 148 mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
 149 mkSplitUniqSupply (MkChar c#) = returnPrimIO MkSplitUniqSupply
 150
 151 splitUniqSupply _ = (MkSplitUniqSupply, MkSplitUniqSupply)
 152
 153 getSUnique s = unsafe_mk_unique s
 154
 155 getSUniques i@(MkInt i#) supply = get_from i# supply
 156   where
 157     get_from 0# s = []
 158     get_from n# s
 159       = unsafe_mk_unique s : get_from (n# `minusInt#` 1#) s
 160
 161 getSUniqueAndDepleted s = (unsafe_mk_unique s, MkSplitUniqSupply)
 162
 163 getSUniquesAndDepleted i@(MkInt i#) s = get_from [] i# s
 164   where
 165     get_from acc 0# s = (acc, MkSplitUniqSupply)
 166     get_from acc n# s
 167       = get_from (unsafe_mk_unique s : acc) (n# `minusInt#` 1#) s
 168
 169 unsafe_mk_unique supply -- this is the TOTALLY unacceptable bit
 170   = unsafePerformPrimIO (
 171     _ccall_ genSymZh junk       `thenPrimIO` \ (W# u#) ->
 172     returnPrimIO (mkUniqueGrimily (w2i (mask# `or#` u#)))
 173     )
 174   where
 175     mask# = (i2w (ord# 'x'#)) `shiftL#` (i2w_s 24#)
 176     junk  = case supply of { MkSplitUniqSupply -> (1::Int) }
 177
 178 # else {- slight attention to referential transparency -}
 179
 180 data SplitUniqSupply
 181   = MkSplitUniqSupply Int       -- make the Unique with this
 182                    SplitUniqSupply SplitUniqSupply
 183                                 -- when split => these two supplies
 184 \end{code}
 185
 186 @mkSplitUniqSupply@ is used to get a @SplitUniqSupply@ started.
 187 \begin{code}
 188
 189 mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
 190
 191 -- ToDo: 64-bit bugs here!!???
 192
 193 mkSplitUniqSupply (MkChar c#)
 194   = let
 195         mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
 196
 197         -- here comes THE MAGIC:
 198
 199         mk_supply#
 200 {- OLD:
 201           = unsafe_interleave mk_unique  `thenPrimIO` \ uniq ->
 202             unsafe_interleave mk_supply# `thenPrimIO` \ s1 ->
 203             unsafe_interleave mk_supply# `thenPrimIO` \ s2 ->
 204             returnPrimIO (MkSplitUniqSupply uniq s1 s2)
 205 -}
 206           = unsafe_interleave (
 207                 mk_unique   `thenPrimIO` \ uniq ->
 208                 mk_supply#  `thenPrimIO` \ s1 ->
 209                 mk_supply#  `thenPrimIO` \ s2 ->
 210                 returnPrimIO (MkSplitUniqSupply uniq s1 s2)
 211             )
 212           where
 213             -- inlined copy of unsafeInterleavePrimIO;
 214             -- this is the single-most-hammered bit of code
 215             -- in the compiler....
 216             unsafe_interleave m s
 217               = let
 218                     (r, new_s) = m s
 219                 in
 220                 (r, s)
 221
 222         mk_unique = _ccall_ genSymZh            `thenPrimIO` \ (W# u#) ->
 223                     returnPrimIO (MkInt (w2i (mask# `or#` u#)))
 224     in
 225     mk_supply#
 226
 227 splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
 228 \end{code}
 229
 230 \begin{code}
 231 getSUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
 232
 233 getSUniques i@(MkInt i#) supply = i# `get_from` supply
 234   where
 235     get_from 0# _ = []
 236     get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
 237       = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
 238
 239 getSUniqueAndDepleted (MkSplitUniqSupply (MkInt n) s1 _) = (mkUniqueGrimily n, s1)
 240
 241 getSUniquesAndDepleted i@(MkInt i#) supply = get_from [] i# supply
 242   where
 243     get_from acc 0# s = (acc, s)
 244     get_from acc n# (MkSplitUniqSupply (MkInt u#) _ s2)
 245       = get_from (mkUniqueGrimily u# : acc) (n# `minusInt#` 1#) s2
 246
 247 # endif {- slight attention to referential transparency -}
 248
 249 #endif  {- end of Glasgow implementation -}
 250 \end{code}
 251
 252 %************************************************************************
 253 %*                                                                      *
 254 \subsection[SplitUniq-monad]{Splittable Unique-supply monad}
 255 %*                                                                      *
 256 %************************************************************************
 257
 258 \begin{code}
 259 type SUniqSM result = SplitUniqSupply -> result
 260
 261 -- the initUs function also returns the final SplitUniqSupply
 262
 263 initSUs :: SplitUniqSupply -> SUniqSM a -> (SplitUniqSupply, a)
 264
 265 initSUs init_us m
 266   = case (splitUniqSupply init_us) of { (s1, s2) ->
 267     (s2, m s1) }
 268
 269 #ifdef __GLASGOW_HASKELL__
 270 {-# INLINE thenSUs #-}
 271 {-# INLINE returnSUs #-}
 272 {-# INLINE splitUniqSupply #-}
 273 #endif
 274 \end{code}
 275
 276 @thenSUs@ is where we split the @SplitUniqSupply@.
 277 \begin{code}
 278 thenSUs :: SUniqSM a -> (a -> SUniqSM b) -> SUniqSM b
 279
 280 thenSUs expr cont us
 281   = case (splitUniqSupply us) of { (s1, s2) ->
 282     case (expr s1)            of { result ->
 283     cont result s2 }}
 284 \end{code}
 285
 286 \begin{code}
 287 returnSUs :: a -> SUniqSM a
 288 returnSUs result us = result
 289
 290 mapSUs :: (a -> SUniqSM b) -> [a] -> SUniqSM [b]
 291
 292 mapSUs f []     = returnSUs []
 293 mapSUs f (x:xs)
 294   = f x         `thenSUs` \ r  ->
 295     mapSUs f xs  `thenSUs` \ rs ->
 296     returnSUs (r:rs)
 297
 298 mapAndUnzipSUs  :: (a -> SUniqSM (b,c))   -> [a] -> SUniqSM ([b],[c])
 299
 300 mapAndUnzipSUs f [] = returnSUs ([],[])
 301 mapAndUnzipSUs f (x:xs)
 302   = f x                 `thenSUs` \ (r1,  r2)  ->
 303     mapAndUnzipSUs f xs `thenSUs` \ (rs1, rs2) ->
 304     returnSUs (r1:rs1, r2:rs2)
 305 \end{code}