ghc/compiler/basicTypes/Unique.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Unique]{The @Unique@ data type and a (monadic) supply thereof}
   5
   6 @Uniques@ are used to distinguish entities in the compiler (@Ids@,
   7 @Classes@, etc.) from each other.  Thus, @Uniques@ are the basic
   8 comparison key in the compiler.
   9
  10 If there is any single operation that needs to be fast, it is @Unique@
  11 comparison.  Unsurprisingly, there is quite a bit of huff-and-puff
  12 directed to that end.
  13
  14 Some of the other hair in this code is to be able to use a
  15 ``splittable @UniqueSupply@'' if requested/possible (not standard
  16 Haskell).
  17
  18 \begin{code}
  19 #include "HsVersions.h"
  20
  21 module Unique (
  22         Unique,
  23         UniqueSupply,                   -- abstract types
  24         u2i,                            -- hack: used in UniqFM
  25         getUnique, getUniques,          -- basic ops
  26         eqUnique, cmpUnique,            -- comparison is everything!
  27
  28 --not exported: mkUnique, unpkUnique,
  29         mkUniqueGrimily,                -- use in SplitUniq only!
  30         mkUniqueSupplyGrimily,          -- ditto! (but FALSE: WDP 95/01)
  31         mkUnifiableTyVarUnique,
  32         unpkUnifiableTyVarUnique,
  33         showUnique, pprUnique, pprUnique10,
  34
  35         UniqSM(..),             -- type: unique supply monad
  36         initUs, thenUs, returnUs,
  37         mapUs, mapAndUnzipUs,
  38
  39         -- the pre-defined unique supplies:
  40 {- NOT exported:
  41         uniqSupply_r, uniqSupply_t, uniqSupply_d,
  42         uniqSupply_s, uniqSupply_c, uniqSupply_T,
  43         uniqSupply_f,
  44         uniqSupply_P,
  45 -}
  46         uniqSupply_u,
  47 #ifdef DPH
  48         -- otherwise, not exported
  49         uniqSupply_p, uniqSupply_S, uniqSupply_L,
  50 #endif
  51
  52         -- and the access functions for the `builtin' UniqueSupply
  53         getBuiltinUniques, mkBuiltinUnique, runBuiltinUs,
  54         mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
  55
  56         -- now all the built-in Uniques (and functions to make them)
  57         -- [the Oh-So-Wonderful Haskell module system wins again...]
  58         mkPrimOpIdUnique,
  59         mkTupleDataConUnique,
  60
  61         absentErrorIdKey,
  62         runSTIdKey, realWorldPrimIdKey,
  63         arrayPrimTyConKey,
  64         byteArrayPrimTyConKey, --UNUSED: byteArrayDataConKey, byteArrayTyConKey,
  65         binaryClassKey,
  66         boolTyConKey, buildDataConKey, buildIdKey, charDataConKey,
  67         charPrimTyConKey, charTyConKey, cmpTagTyConKey,
  68         consDataConKey,
  69         dialogueTyConKey,
  70         doubleDataConKey,
  71         doublePrimTyConKey,
  72         doubleTyConKey,
  73         enumClassKey, eqClassKey,
  74         eqTagDataConKey, errorIdKey,
  75         falseDataConKey, floatDataConKey,
  76         floatPrimTyConKey, floatTyConKey, floatingClassKey,
  77         foldlIdKey, foldrIdKey,
  78         forkIdKey,
  79         fractionalClassKey,
  80         gtTagDataConKey, --UNUSED: iOErrorTyConKey,
  81 --UNUSED:       iOIntPrimTyConKey, -- UNUSED: int2IntegerIdKey,
  82         iOTyConKey,
  83         intDataConKey,
  84         wordPrimTyConKey, wordTyConKey, wordDataConKey,
  85         addrPrimTyConKey, addrTyConKey, addrDataConKey,
  86         intPrimTyConKey, intTyConKey,
  87         integerDataConKey, integerTyConKey, integralClassKey,
  88         ixClassKey,
  89 --UNUSED:       lexIdKey,
  90         liftDataConKey, liftTyConKey, listTyConKey,
  91         ltTagDataConKey,
  92         mutableArrayPrimTyConKey, -- UNUSED: mutableArrayDataConKey, mutableArrayTyConKey,
  93         mutableByteArrayPrimTyConKey, -- UNUSED: mutableByteArrayDataConKey,
  94 --UNUSED:       mutableByteArrayTyConKey,
  95         synchVarPrimTyConKey,
  96         nilDataConKey, numClassKey, ordClassKey,
  97         parIdKey, parErrorIdKey,
  98 #ifdef GRAN
  99         parGlobalIdKey, parLocalIdKey, copyableIdKey, noFollowIdKey,
 100 #endif
 101         patErrorIdKey,
 102         ratioDataConKey, ratioTyConKey,
 103         rationalTyConKey,
 104 --UNUSED:       readParenIdKey,
 105         realClassKey, realFloatClassKey,
 106         realFracClassKey,
 107 --UNUSED:       requestTyConKey, responseTyConKey,
 108         return2GMPsDataConKey, return2GMPsTyConKey,
 109         returnIntAndGMPDataConKey, returnIntAndGMPTyConKey,
 110         seqIdKey, -- UNUSED: seqIntPrimTyConKey,
 111 --UNUSED:       seqTyConKey,
 112 --UNUSED:       showParenIdKey,
 113 --UNUSED:       showSpaceIdKey,
 114         statePrimTyConKey, stateTyConKey, stateDataConKey,
 115         voidPrimTyConKey,
 116         realWorldTyConKey,
 117         stablePtrPrimTyConKey, stablePtrTyConKey, stablePtrDataConKey,
 118         mallocPtrPrimTyConKey, mallocPtrTyConKey, mallocPtrDataConKey,
 119         stateAndPtrPrimTyConKey,
 120         stateAndPtrPrimDataConKey,
 121         stateAndCharPrimTyConKey,
 122         stateAndCharPrimDataConKey,
 123         stateAndIntPrimTyConKey,
 124         stateAndIntPrimDataConKey,
 125         stateAndWordPrimTyConKey,
 126         stateAndWordPrimDataConKey,
 127         stateAndAddrPrimTyConKey,
 128         stateAndAddrPrimDataConKey,
 129         stateAndStablePtrPrimTyConKey,
 130         stateAndStablePtrPrimDataConKey,
 131         stateAndMallocPtrPrimTyConKey,
 132         stateAndMallocPtrPrimDataConKey,
 133         stateAndFloatPrimTyConKey,
 134         stateAndFloatPrimDataConKey,
 135         stateAndDoublePrimTyConKey,
 136         stateAndDoublePrimDataConKey,
 137         stateAndArrayPrimTyConKey,
 138         stateAndArrayPrimDataConKey,
 139         stateAndMutableArrayPrimTyConKey,
 140         stateAndMutableArrayPrimDataConKey,
 141         stateAndByteArrayPrimTyConKey,
 142         stateAndByteArrayPrimDataConKey,
 143         stateAndMutableByteArrayPrimTyConKey,
 144         stateAndMutableByteArrayPrimDataConKey,
 145         stateAndSynchVarPrimTyConKey,
 146         stateAndSynchVarPrimDataConKey,
 147         stringTyConKey,
 148         stTyConKey, primIoTyConKey,
 149 --UNUSED:       ioResultTyConKey,
 150         textClassKey,
 151         traceIdKey,
 152         trueDataConKey,
 153         unpackCString2IdKey,
 154         unpackCStringAppendIdKey,
 155         unpackCStringFoldrIdKey,
 156         unpackCStringIdKey,
 157         augmentIdKey,
 158         appendIdKey,
 159 --NO:   rangeComplaintIdKey,
 160         packCStringIdKey,
 161         integerZeroIdKey, integerPlusOneIdKey,
 162         integerPlusTwoIdKey, integerMinusOneIdKey,
 163         voidPrimIdKey,
 164         cCallableClassKey,
 165         cReturnableClassKey,
 166 --UNUSED:       packedStringTyConKey, psDataConKey, cpsDataConKey,
 167
 168         -- to make interface self-sufficient
 169         PrimOp, SplitUniqSupply, CSeq
 170
 171 #ifndef __GLASGOW_HASKELL__
 172         , TAG_
 173 #endif
 174     ) where
 175
 176 import Outputable       -- class for printing, forcing
 177 import Pretty
 178 import PrimOps          -- ** DIRECTLY **
 179 import SplitUniq
 180 import Util
 181
 182 #ifndef __GLASGOW_HASKELL__
 183 {-hide import from mkdependHS-}
 184 import
 185         Word
 186 #endif
 187 #ifdef __GLASGOW_HASKELL__
 188 import PreludeGlaST
 189 #endif
 190
 191 infixr 9 `thenUs`
 192 \end{code}
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection[Unique-type]{@Unique@ type and operations}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.
 201 Fast comparison is everything on @Uniques@:
 202
 203 \begin{code}
 204 u2i :: Unique -> FAST_INT
 205
 206 #ifdef __GLASGOW_HASKELL__
 207
 208 data Unique = MkUnique Int#
 209 u2i (MkUnique i) = i
 210
 211 #else
 212
 213 data Unique = MkUnique Word{-#STRICT#-}
 214 u2i (MkUnique w) = wordToInt w
 215
 216 #endif
 217 \end{code}
 218
 219 Now come the functions which construct uniques from their pieces, and vice versa.
 220 The stuff about unique *supplies* is handled further down this module.
 221
 222 \begin{code}
 223 mkUnique                 :: Char -> Int -> Unique       -- Builds a unique from pieces
 224 unpkUnique               :: Unique -> (Char, Int)       -- The reverse
 225
 226 mkUnifiableTyVarUnique   :: Int -> Unique       -- Injects a subst-array index into the Unique type
 227 unpkUnifiableTyVarUnique :: Unique -> Int       -- The reverse process
 228
 229 #ifdef __GLASGOW_HASKELL__
 230 mkUniqueGrimily :: Int# -> Unique               -- A trap-door for SplitUniq
 231 #else
 232 mkUniqueGrimily :: Int -> Unique
 233 #endif
 234 \end{code}
 235
 236
 237 \begin{code}
 238 #ifdef __GLASGOW_HASKELL__
 239 mkUniqueGrimily x = MkUnique x
 240 #else
 241 mkUniqueGrimily x = MkUnique (fromInteger (toInteger x))
 242 #endif
 243
 244 mkUnifiableTyVarUnique i = mkUnique '_'{-MAGIC CHAR-} i
 245
 246 unpkUnifiableTyVarUnique uniq
 247   = case (unpkUnique uniq) of { (tag, i) ->
 248     ASSERT(tag == '_'{-MAGIC CHAR-})
 249     i }
 250
 251 -- pop the Char in the top 8 bits of the Unique(Supply)
 252
 253 #ifdef __GLASGOW_HASKELL__
 254
 255 -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
 256
 257 w2i x = word2Int# x
 258 i2w x = int2Word# x
 259 i2w_s x = (x::Int#)
 260
 261 mkUnique (MkChar c#) (MkInt i#)
 262   = MkUnique (w2i (((i2w (ord# c#)) `shiftL#` (i2w_s 24#)) `or#` (i2w i#)))
 263
 264 unpkUnique (MkUnique u)
 265   = let
 266         tag = MkChar (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
 267         i   = MkInt  (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
 268     in
 269     (tag, i)
 270 # if __GLASGOW_HASKELL__ >= 23
 271   where
 272     shiftr x y = shiftRA# x y
 273 # else
 274     shiftr x y = shiftR#  x y
 275 # endif
 276
 277 #else {-probably HBC-}
 278
 279 mkUnique c i
 280   = MkUnique (((fromInt (ord c)) `bitLsh` 24) `bitOr` (fromInt i))
 281
 282 unpkUnique (MkUnique u)
 283   = let
 284         tag = chr (wordToInt (u `bitRsh` 24))
 285         i   = wordToInt (u `bitAnd` 16777215 {-0x00ffffff-})
 286     in
 287     (tag, i)
 288
 289 #endif  {-probably HBC-}
 290 \end{code}
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection[Unique-instances]{Instance declarations for @Unique@}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 And the whole point (besides uniqueness) is fast equality.  We don't
 299 use `deriving' because we want {\em precise} control of ordering
 300 (equality on @Uniques@ is v common).
 301
 302 \begin{code}
 303 #ifdef __GLASGOW_HASKELL__
 304
 305 {-# INLINE eqUnique  #-} -- this is Hammered City here...
 306 {-# INLINE cmpUnique #-}
 307
 308 eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2
 309 ltUnique (MkUnique u1) (MkUnique u2) = u1 <#  u2
 310 leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2
 311
 312 cmpUnique (MkUnique u1) (MkUnique u2)
 313   = if u1 ==# u2 then EQ_ else if u1 <# u2 then LT_ else GT_
 314
 315 #else
 316 eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2
 317 ltUnique (MkUnique u1) (MkUnique u2) = u1 <  u2
 318 leUnique (MkUnique u1) (MkUnique u2) = u1 <= u2
 319
 320 cmpUnique (MkUnique u1) (MkUnique u2)
 321   = if u1 == u2 then EQ_ else if u1 < u2 then LT_ else GT_
 322 #endif
 323
 324 instance Eq Unique where
 325     a == b = eqUnique a b
 326     a /= b = not (eqUnique a b)
 327
 328 instance Ord Unique where
 329     a  < b = ltUnique a b
 330     a <= b = leUnique a b
 331     a  > b = not (leUnique a b)
 332     a >= b = not (ltUnique a b)
 333 #ifdef __GLASGOW_HASKELL__
 334     _tagCmp a b = case cmpUnique a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 335 #endif
 336 \end{code}
 337
 338 And for output:
 339 \begin{code}
 340 {- OLD:
 341 instance Outputable Unique where
 342    ppr any_style uniq
 343      = case unpkUnique uniq of
 344          (tag, u) -> ppStr (tag : iToBase62 u)
 345 -}
 346 \end{code}
 347
 348 We do sometimes make strings with @Uniques@ in them:
 349 \begin{code}
 350 pprUnique, pprUnique10 :: Unique -> Pretty
 351
 352 pprUnique uniq
 353   = case unpkUnique uniq of
 354       (tag, u) -> ppBeside (ppChar tag) (iToBase62 u)
 355
 356 pprUnique10 uniq        -- in base-10, dudes
 357   = case unpkUnique uniq of
 358       (tag, u) -> ppBeside (ppChar tag) (ppInt u)
 359
 360 showUnique :: Unique -> FAST_STRING
 361 showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq))
 362
 363 instance Text Unique where
 364     showsPrec p uniq rest = _UNPK_ (showUnique uniq)
 365     readsPrec p = panic "no readsPrec for Unique"
 366 \end{code}
 367
 368 %************************************************************************
 369 %*                                                                      *
 370 \subsection[Utils-base62]{Base-62 numbers}
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 A character-stingy way to read/write numbers (notably Uniques).
 375 The ``62-its'' are \tr{[0-9a-zA-Z]}.  We don't handle negative Ints.
 376 Code stolen from Lennart.
 377 \begin{code}
 378 iToBase62 :: Int -> Pretty
 379
 380 #ifdef __GLASGOW_HASKELL__
 381 iToBase62 n@(I# n#)
 382   = ASSERT(n >= 0)
 383     let
 384         bytes = case chars62 of { _ByteArray bounds_who_needs_'em bytes -> bytes }
 385     in
 386     if n# <# 62# then
 387         case (indexCharArray# bytes n#) of { c ->
 388         ppChar (C# c) }
 389     else
 390         case (quotRem n 62)             of { (q, I# r#) ->
 391         case (indexCharArray# bytes r#) of { c  ->
 392         ppBeside (iToBase62 q) (ppChar (C# c)) }}
 393
 394 -- keep this at top level! (bug on 94/10/24 WDP)
 395 chars62 :: _ByteArray Int
 396 chars62
 397   = _runST (
 398         newCharArray (0, 61)    `thenStrictlyST` \ ch_array ->
 399         fill_in ch_array 0 62 "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
 400                                 `seqStrictlyST`
 401         unsafeFreezeByteArray ch_array
 402     )
 403   where
 404     fill_in ch_array i lim str
 405       | i == lim
 406       = returnStrictlyST ()
 407       | otherwise
 408       = writeCharArray ch_array i (str !! i)    `seqStrictlyST`
 409         fill_in ch_array (i+1) lim str
 410
 411 #else {- not GHC -}
 412 iToBase62 n
 413   = ASSERT(n >= 0)
 414     if n < 62 then
 415         ppChar (chars62 ! n)
 416     else
 417         case (quotRem n 62) of { (q, r) ->
 418         ppBeside (iToBase62 q) (ppChar (chars62 ! r)) }
 419
 420 -- keep this at top level! (bug on 94/10/24 WDP)
 421 chars62 :: Array Int Char
 422 chars62
 423   = array (0,61) (zipWith (:=) [0..] "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
 424 #endif {- not GHC -}
 425 \end{code}
 426
 427 %************************************************************************
 428 %*                                                                      *
 429 \subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things}
 430 %*                                                                      *
 431 %************************************************************************
 432
 433 \begin{code}
 434 mkPreludeClassUnique i          = mkUnique '1' i
 435 mkPreludeTyConUnique i          = mkUnique '2' i
 436 mkPreludeDataConUnique i        = mkUnique 'Y' i -- must be alphabetic
 437 mkTupleDataConUnique i          = mkUnique 'Z' i -- ditto (*may* be used in C labels)
 438 -- mkPrimOpIdUnique op: see below (uses '5')
 439 mkPreludeMiscIdUnique i         = mkUnique '7' i
 440 \end{code}
 441
 442 %************************************************************************
 443 %*                                                                      *
 444 \subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}
 445 %*                                                                      *
 446 %************************************************************************
 447
 448 \begin{code}
 449 eqClassKey              = mkPreludeClassUnique 1
 450 ordClassKey             = mkPreludeClassUnique 2
 451 numClassKey             = mkPreludeClassUnique 3
 452 integralClassKey        = mkPreludeClassUnique 4
 453 fractionalClassKey      = mkPreludeClassUnique 5
 454 floatingClassKey        = mkPreludeClassUnique 6
 455 realClassKey            = mkPreludeClassUnique 7
 456 realFracClassKey        = mkPreludeClassUnique 8
 457 realFloatClassKey       = mkPreludeClassUnique 9
 458 ixClassKey              = mkPreludeClassUnique 10
 459 enumClassKey            = mkPreludeClassUnique 11
 460 textClassKey            = mkPreludeClassUnique 12
 461 binaryClassKey          = mkPreludeClassUnique 13
 462 cCallableClassKey       = mkPreludeClassUnique 14
 463 cReturnableClassKey     = mkPreludeClassUnique 15
 464 #ifdef DPH
 465 pidClassKey             = mkPreludeClassUnique 16
 466 processorClassKey       = mkPreludeClassUnique 17
 467 #endif {- Data Parallel Haskell -}
 468 \end{code}
 469
 470 %************************************************************************
 471 %*                                                                      *
 472 \subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}
 473 %*                                                                      *
 474 %************************************************************************
 475
 476 \begin{code}
 477 addrPrimTyConKey                        = mkPreludeTyConUnique  1
 478 addrTyConKey                            = mkPreludeTyConUnique  2
 479 arrayPrimTyConKey                       = mkPreludeTyConUnique  3
 480 boolTyConKey                            = mkPreludeTyConUnique  4
 481 byteArrayPrimTyConKey                   = mkPreludeTyConUnique  5
 482 --UNUSED:byteArrayTyConKey                      = mkPreludeTyConUnique  6
 483 charPrimTyConKey                        = mkPreludeTyConUnique  7
 484 charTyConKey                            = mkPreludeTyConUnique  8
 485 cmpTagTyConKey                          = mkPreludeTyConUnique  9
 486 dialogueTyConKey                        = mkPreludeTyConUnique 10
 487 doublePrimTyConKey                      = mkPreludeTyConUnique 11
 488 doubleTyConKey                          = mkPreludeTyConUnique 12
 489 floatPrimTyConKey                       = mkPreludeTyConUnique 13
 490 floatTyConKey                           = mkPreludeTyConUnique 14
 491 --UNUSED:iOErrorTyConKey                                = mkPreludeTyConUnique 14
 492 --UNUSED:iOIntPrimTyConKey                      = mkPreludeTyConUnique 15
 493 iOTyConKey                              = mkPreludeTyConUnique 16
 494 intPrimTyConKey                         = mkPreludeTyConUnique 17
 495 intTyConKey                             = mkPreludeTyConUnique 18
 496 integerTyConKey                         = mkPreludeTyConUnique 19
 497 liftTyConKey                            = mkPreludeTyConUnique 20
 498 listTyConKey                            = mkPreludeTyConUnique 21
 499 mallocPtrPrimTyConKey                   = mkPreludeTyConUnique 22
 500 mallocPtrTyConKey                       = mkPreludeTyConUnique 23
 501 mutableArrayPrimTyConKey                = mkPreludeTyConUnique 24
 502 --UNUSED:mutableArrayTyConKey                   = mkPreludeTyConUnique 25
 503 mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 26
 504 --UNUSED:mutableByteArrayTyConKey               = mkPreludeTyConUnique 27
 505 --UNUSED:packedStringTyConKey                   = mkPreludeTyConUnique 28
 506 synchVarPrimTyConKey                    = mkPreludeTyConUnique 29
 507 ratioTyConKey                           = mkPreludeTyConUnique 30
 508 rationalTyConKey                        = mkPreludeTyConUnique 31
 509 realWorldTyConKey                       = mkPreludeTyConUnique 32
 510 --UNUSED:requestTyConKey                                = mkPreludeTyConUnique 33
 511 --UNUSED:responseTyConKey                       = mkPreludeTyConUnique 34
 512 return2GMPsTyConKey                     = mkPreludeTyConUnique 35
 513 returnIntAndGMPTyConKey                 = mkPreludeTyConUnique 36
 514 --UNUSED:seqIntPrimTyConKey                     = mkPreludeTyConUnique 37
 515 --UNUSED:seqTyConKey                            = mkPreludeTyConUnique 38
 516 stablePtrPrimTyConKey                   = mkPreludeTyConUnique 39
 517 stablePtrTyConKey                       = mkPreludeTyConUnique 40
 518 stateAndAddrPrimTyConKey                = mkPreludeTyConUnique 41
 519 stateAndArrayPrimTyConKey               = mkPreludeTyConUnique 42
 520 stateAndByteArrayPrimTyConKey           = mkPreludeTyConUnique 43
 521 stateAndCharPrimTyConKey                = mkPreludeTyConUnique 44
 522 stateAndDoublePrimTyConKey              = mkPreludeTyConUnique 45
 523 stateAndFloatPrimTyConKey               = mkPreludeTyConUnique 46
 524 stateAndIntPrimTyConKey                 = mkPreludeTyConUnique 47
 525 stateAndMallocPtrPrimTyConKey           = mkPreludeTyConUnique 48
 526 stateAndMutableArrayPrimTyConKey        = mkPreludeTyConUnique 49
 527 stateAndMutableByteArrayPrimTyConKey    = mkPreludeTyConUnique 50
 528 stateAndSynchVarPrimTyConKey            = mkPreludeTyConUnique 51
 529 stateAndPtrPrimTyConKey                 = mkPreludeTyConUnique 52
 530 stateAndStablePtrPrimTyConKey           = mkPreludeTyConUnique 53
 531 stateAndWordPrimTyConKey                = mkPreludeTyConUnique 54
 532 statePrimTyConKey                       = mkPreludeTyConUnique 55
 533 stateTyConKey                           = mkPreludeTyConUnique 56
 534 stringTyConKey                          = mkPreludeTyConUnique 57
 535 stTyConKey                              = mkPreludeTyConUnique 58
 536 primIoTyConKey                          = mkPreludeTyConUnique 59
 537 --UNUSED:ioResultTyConKey                       = mkPreludeTyConUnique 60
 538 voidPrimTyConKey                        = mkPreludeTyConUnique 61
 539 wordPrimTyConKey                        = mkPreludeTyConUnique 62
 540 wordTyConKey                            = mkPreludeTyConUnique 63
 541
 542 #ifdef DPH
 543 podTyConKey                             = mkPreludeTyConUnique 64
 544 interfacePodTyConKey                    = mkPreludeTyConUnique 65
 545
 546 podizedPodTyConKey _ = panic "ToDo:DPH:podizedPodTyConKey"
 547 #endif {- Data Parallel Haskell -}
 548 \end{code}
 549
 550 %************************************************************************
 551 %*                                                                      *
 552 \subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}
 553 %*                                                                      *
 554 %************************************************************************
 555
 556 \begin{code}
 557 addrDataConKey                          = mkPreludeDataConUnique  1
 558 buildDataConKey                         = mkPreludeDataConUnique  2
 559 --UNUSED:byteArrayDataConKey                    = mkPreludeDataConUnique  3
 560 charDataConKey                          = mkPreludeDataConUnique  4
 561 consDataConKey                          = mkPreludeDataConUnique  5
 562 doubleDataConKey                        = mkPreludeDataConUnique  6
 563 eqTagDataConKey                         = mkPreludeDataConUnique  7
 564 falseDataConKey                         = mkPreludeDataConUnique  8
 565 floatDataConKey                         = mkPreludeDataConUnique  9
 566 gtTagDataConKey                         = mkPreludeDataConUnique 10
 567 intDataConKey                           = mkPreludeDataConUnique 11
 568 integerDataConKey                       = mkPreludeDataConUnique 12
 569 liftDataConKey                          = mkPreludeDataConUnique 13
 570 ltTagDataConKey                         = mkPreludeDataConUnique 14
 571 mallocPtrDataConKey                     = mkPreludeDataConUnique 15
 572 --UNUSED:mutableArrayDataConKey                 = mkPreludeDataConUnique 16
 573 --UNUSED:mutableByteArrayDataConKey             = mkPreludeDataConUnique 17
 574 nilDataConKey                           = mkPreludeDataConUnique 18
 575 --UNUSED:psDataConKey                           = mkPreludeDataConUnique 19
 576 --UNUSED:cpsDataConKey                          = mkPreludeDataConUnique 20
 577 ratioDataConKey                         = mkPreludeDataConUnique 21
 578 return2GMPsDataConKey                   = mkPreludeDataConUnique 22
 579 returnIntAndGMPDataConKey               = mkPreludeDataConUnique 23
 580 stablePtrDataConKey                     = mkPreludeDataConUnique 24
 581 stateAndAddrPrimDataConKey              = mkPreludeDataConUnique 25
 582 stateAndArrayPrimDataConKey             = mkPreludeDataConUnique 26
 583 stateAndByteArrayPrimDataConKey         = mkPreludeDataConUnique 27
 584 stateAndCharPrimDataConKey              = mkPreludeDataConUnique 28
 585 stateAndDoublePrimDataConKey            = mkPreludeDataConUnique 29
 586 stateAndFloatPrimDataConKey             = mkPreludeDataConUnique 30
 587 stateAndIntPrimDataConKey               = mkPreludeDataConUnique 31
 588 stateAndMallocPtrPrimDataConKey         = mkPreludeDataConUnique 32
 589 stateAndMutableArrayPrimDataConKey      = mkPreludeDataConUnique 33
 590 stateAndMutableByteArrayPrimDataConKey  = mkPreludeDataConUnique 34
 591 stateAndSynchVarPrimDataConKey          = mkPreludeDataConUnique 35
 592 stateAndPtrPrimDataConKey               = mkPreludeDataConUnique 36
 593 stateAndStablePtrPrimDataConKey         = mkPreludeDataConUnique 37
 594 stateAndWordPrimDataConKey              = mkPreludeDataConUnique 38
 595 stateDataConKey                         = mkPreludeDataConUnique 39
 596 trueDataConKey                          = mkPreludeDataConUnique 40
 597 wordDataConKey                          = mkPreludeDataConUnique 41
 598
 599 #ifdef DPH
 600 interfacePodDataConKey                  = mkPreludeDataConUnique 42
 601 #endif {- Data Parallel Haskell -}
 602 \end{code}
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 First, for raw @PrimOps@ and their boxed versions:
 611 \begin{code}
 612 mkPrimOpIdUnique :: PrimOp -> Unique
 613
 614 mkPrimOpIdUnique op = mkUnique '5' IBOX((tagOf_PrimOp op))
 615 \end{code}
 616
 617 Now for other non-@DataCon@ @Ids@:
 618 \begin{code}
 619 absentErrorIdKey        = mkPreludeMiscIdUnique  1
 620 appendIdKey             = mkPreludeMiscIdUnique  2
 621 augmentIdKey            = mkPreludeMiscIdUnique  3
 622 buildIdKey              = mkPreludeMiscIdUnique  4
 623 errorIdKey              = mkPreludeMiscIdUnique  5
 624 foldlIdKey              = mkPreludeMiscIdUnique  6
 625 foldrIdKey              = mkPreludeMiscIdUnique  7
 626 forkIdKey               = mkPreludeMiscIdUnique  8
 627 int2IntegerIdKey        = mkPreludeMiscIdUnique  9
 628 integerMinusOneIdKey    = mkPreludeMiscIdUnique 10
 629 integerPlusOneIdKey     = mkPreludeMiscIdUnique 11
 630 integerPlusTwoIdKey     = mkPreludeMiscIdUnique 12
 631 integerZeroIdKey        = mkPreludeMiscIdUnique 13
 632 packCStringIdKey        = mkPreludeMiscIdUnique 14
 633 parErrorIdKey           = mkPreludeMiscIdUnique 15
 634 parIdKey                = mkPreludeMiscIdUnique 16
 635 patErrorIdKey           = mkPreludeMiscIdUnique 25
 636 --NO:rangeComplaintIdKey        = mkPreludeMiscIdUnique 17
 637 realWorldPrimIdKey      = mkPreludeMiscIdUnique 18
 638 runSTIdKey              = mkPreludeMiscIdUnique 19
 639 seqIdKey                = mkPreludeMiscIdUnique 20
 640 traceIdKey              = mkPreludeMiscIdUnique 21
 641 unpackCString2IdKey     = mkPreludeMiscIdUnique 22
 642 unpackCStringAppendIdKey= mkPreludeMiscIdUnique 23
 643 unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
 644 unpackCStringIdKey      = mkPreludeMiscIdUnique 25
 645 voidPrimIdKey           = mkPreludeMiscIdUnique 26
 646
 647 #ifdef GRAN
 648 parLocalIdKey           = mkPreludeMiscIdUnique 27
 649 parGlobalIdKey          = mkPreludeMiscIdUnique 28
 650 noFollowIdKey           = mkPreludeMiscIdUnique 29
 651 copyableIdKey           = mkPreludeMiscIdUnique 30
 652 #endif
 653
 654 #ifdef DPH
 655 podSelectorIdKey        = mkPreludeMiscIdUnique 31
 656 #endif {- Data Parallel Haskell -}
 657 \end{code}
 658
 659 %************************************************************************
 660 %*                                                                      *
 661 \subsection[UniqueSupply-type]{@UniqueSupply@ type and operations}
 662 %*                                                                      *
 663 %************************************************************************
 664
 665 \begin{code}
 666 #ifdef __GLASGOW_HASKELL__
 667 data UniqueSupply
 668   = MkUniqueSupply  Int#
 669   | MkNewSupply     SplitUniqSupply
 670
 671 #else
 672 data UniqueSupply
 673   = MkUniqueSupply  Word{-#STRICT#-}
 674   | MkNewSupply     SplitUniqSupply
 675 #endif
 676 \end{code}
 677
 678 @mkUniqueSupply@ is used to get a @UniqueSupply@ started.
 679 \begin{code}
 680 mkUniqueSupply :: Char -> UniqueSupply
 681
 682 #ifdef __GLASGOW_HASKELL__
 683
 684 mkUniqueSupply (MkChar c#)
 685   = MkUniqueSupply (w2i ((i2w (ord# c#)) `shiftL#` (i2w_s 24#)))
 686
 687 #else
 688
 689 mkUniqueSupply c
 690   = MkUniqueSupply ((fromInt (ord c)) `bitLsh` 24)
 691
 692 #endif
 693
 694 mkUniqueSupplyGrimily s = MkNewSupply s
 695 \end{code}
 696
 697 The basic operation on a @UniqueSupply@ is to get a @Unique@ (or a
 698 few).  It's just plain different when splittable vs.~not...
 699 \begin{code}
 700 getUnique :: UniqueSupply -> (UniqueSupply, Unique)
 701
 702 getUnique (MkUniqueSupply n)
 703 #ifdef __GLASGOW_HASKELL__
 704   = (MkUniqueSupply (n +# 1#), MkUnique n)
 705 #else
 706   = (MkUniqueSupply (n + 1), MkUnique n)
 707 #endif
 708 getUnique (MkNewSupply s)
 709   = let
 710         (u, s1) = getSUniqueAndDepleted s
 711     in
 712     (MkNewSupply s1, u)
 713
 714 getUniques :: Int               -- how many you want
 715            -> UniqueSupply
 716            -> (UniqueSupply, [Unique])
 717
 718 #ifdef __GLASGOW_HASKELL__
 719 getUniques i@(MkInt i#) (MkUniqueSupply n)
 720   = (MkUniqueSupply (n +# i#),
 721      [ case x of { MkInt x# ->
 722          MkUnique (n +# x#) } | x <- [0 .. i-1] ])
 723 #else
 724 getUniques i (MkUniqueSupply n)
 725   = (MkUniqueSupply (n + fromInt i), [ MkUnique (n + fromInt x) | x <- [0 .. i-1] ])
 726 #endif
 727 getUniques i (MkNewSupply s)
 728   = let
 729         (us, s1) = getSUniquesAndDepleted i s
 730     in
 731     (MkNewSupply s1, us)
 732 \end{code}
 733
 734 [OLD-ish NOTE] Simon says: The last line is preferable over @(n+i,
 735 <mumble> [n .. (n+i-1)])@, because it is a little lazier.  If n=bot
 736 you get ([bot, bot, bot], bot) back instead of (bot,bot).  This is
 737 sometimes important for knot-tying.
 738
 739 Alternatively, if you hate the inefficiency:
 740 \begin{pseudocode}
 741 (range 0, n+i)  where range m | m=i = []
 742                       range m       = n+m : range (m+1)
 743 \end{pseudocode}
 744
 745 %************************************************************************
 746 %*                                                                      *
 747 \subsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
 748 %*                                                                      *
 749 %************************************************************************
 750
 751 Different parts of the compiler have their own @UniqueSupplies@, each
 752 identified by their ``tag letter:''
 753 \begin{verbatim}
 754     B           builtin; for when the compiler conjures @Uniques@ out of
 755                 thin air
 756     b           a second builtin; we need two in mkWrapperUnfolding (False)
 757     r           renamer
 758     t           typechecker
 759     d           desugarer
 760     p           ``podizer'' (DPH only)
 761     s           core-to-core simplifier
 762     S           ``pod'' simplifier (DPH only)
 763     c           core-to-stg
 764     T           stg-to-stg simplifier
 765     f           flattener (of abstract~C)
 766     L           Assembly labels (for native-code generators)
 767     u           Printing out unfoldings (so don't have constant renaming)
 768     P           profiling (finalCCstg)
 769
 770     v           used in specialised TyVarUniques (see TyVar.lhs)
 771
 772     1-9         used for ``prelude Uniques'' (wired-in things; see below)
 773                 1 = classes
 774                 2 = tycons
 775                 3 = data cons
 776                 4 = tuple datacons
 777                 5 = unboxed-primop ids
 778                 6 = boxed-primop ids
 779                 7 = misc ids
 780 \end{verbatim}
 781
 782 \begin{code}
 783 uniqSupply_r = mkUniqueSupply 'r'
 784 uniqSupply_t = mkUniqueSupply 't'
 785 uniqSupply_d = mkUniqueSupply 'd'
 786 uniqSupply_p = mkUniqueSupply 'p'
 787 uniqSupply_s = mkUniqueSupply 's'
 788 uniqSupply_S = mkUniqueSupply 'S'
 789 uniqSupply_c = mkUniqueSupply 'c'
 790 uniqSupply_T = mkUniqueSupply 'T'
 791 uniqSupply_f = mkUniqueSupply 'f'
 792 uniqSupply_L = mkUniqueSupply 'L'
 793 uniqSupply_u = mkUniqueSupply 'u'
 794 uniqSupply_P = mkUniqueSupply 'P'
 795 \end{code}
 796
 797 The ``builtin UniqueSupplies'' are more magical.  You don't use the
 798 supply, you ask for @Uniques@ directly from it.  (They probably aren't
 799 unique, but you know that!)
 800
 801 \begin{code}
 802 uniqSupply_B = mkUniqueSupply 'B' -- not exported!
 803 uniqSupply_b = mkUniqueSupply 'b' -- not exported!
 804 \end{code}
 805
 806 \begin{code}
 807 mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
 808  mkBuiltinUnique :: Int -> Unique
 809
 810 mkBuiltinUnique i = mkUnique 'B' i
 811 mkPseudoUnique1 i = mkUnique 'C' i -- used for getTheUnique on Regs
 812 mkPseudoUnique2 i = mkUnique 'D' i -- ditto
 813 mkPseudoUnique3 i = mkUnique 'E' i -- ditto
 814
 815 getBuiltinUniques :: Int -> [Unique]
 816 getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
 817 \end{code}
 818
 819 The following runs a uniq monad expression, using builtin uniq values:
 820 \begin{code}
 821 runBuiltinUs :: UniqSM a -> a
 822 runBuiltinUs m = snd (initUs uniqSupply_B m)
 823 \end{code}
 824
 825 %************************************************************************
 826 %*                                                                      *
 827 \subsection[Unique-monad]{Unique supply monad}
 828 %*                                                                      *
 829 %************************************************************************
 830
 831 A very plain unique-supply monad.
 832
 833 \begin{code}
 834 type UniqSM result = UniqueSupply -> (UniqueSupply, result)
 835
 836 -- the initUs function also returns the final UniqueSupply
 837
 838 initUs :: UniqueSupply -> UniqSM a -> (UniqueSupply, a)
 839
 840 initUs init_us m = m init_us
 841
 842 #ifdef __GLASGOW_HASKELL__
 843 {-# INLINE thenUs #-}
 844 {-# INLINE returnUs #-}
 845 #endif
 846 \end{code}
 847
 848 @thenUs@ is are where we split the @UniqueSupply@.
 849 \begin{code}
 850 thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
 851
 852 thenUs expr cont us
 853   = case (expr us) of
 854       (us1, result) -> cont result us1
 855 \end{code}
 856
 857 \begin{code}
 858 returnUs :: a -> UniqSM a
 859 returnUs result us = (us, result)
 860
 861 mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
 862
 863 mapUs f []     = returnUs []
 864 mapUs f (x:xs)
 865   = f x         `thenUs` \ r  ->
 866     mapUs f xs  `thenUs` \ rs ->
 867     returnUs (r:rs)
 868
 869 mapAndUnzipUs  :: (a -> UniqSM (b,c))   -> [a] -> UniqSM ([b],[c])
 870
 871 mapAndUnzipUs f [] = returnUs ([],[])
 872 mapAndUnzipUs f (x:xs)
 873   = f x                 `thenUs` \ (r1,  r2)  ->
 874     mapAndUnzipUs f xs  `thenUs` \ (rs1, rs2) ->
 875     returnUs (r1:rs1, r2:rs2)
 876 \end{code}