ghc/lib/hbc/NameSupply.hs

   1 module NameSupply(NameSupply, initialNameSupply, splitNameSupply, getName, listNameSupply, Name(..)
   2 #if defined(__YALE_HASKELL__)
   3         , Symbol
   4 #endif
   5         ) where
   6
   7 #if defined(__YALE_HASKELL__)
   8 import Symbol
   9 type Name = Symbol
  10
  11 #else
  12 # if defined(__GLASGOW_HASKELL__)
  13 import PreludeGlaST
  14 type Name = Int
  15
  16 # else
  17 import LMLgensym
  18 type Name = Int
  19 # endif
  20 #endif
  21
  22 data NameSupply = NameSupply Name NameSupply NameSupply
  23
  24 splitNameSupply :: NameSupply -> (NameSupply,NameSupply)
  25 getName         :: NameSupply -> Name
  26 listNameSupply  :: NameSupply -> [NameSupply]
  27
  28 #if defined(__YALE_HASKELL__)
  29 initialNameSupply :: IO NameSupply
  30 #else
  31 initialNameSupply :: NameSupply
  32 #endif
  33
  34 #if defined(__GLASGOW_HASKELL__)
  35 initialNameSupply = unsafePerformPrimIO mk_supply# -- GHC-specific
  36   where
  37     mk_supply#
  38       = unsafeInterleavePrimIO (_ccall_ genSymZh)
  39                                             `thenPrimIO` \ u  ->
  40         unsafeInterleavePrimIO mk_supply#   `thenPrimIO` \ s1 ->
  41         unsafeInterleavePrimIO mk_supply#   `thenPrimIO` \ s2 ->
  42         returnPrimIO (NameSupply u s1 s2)
  43 #endif
  44
  45 #if defined(__YALE_HASKELL__)
  46 initialNameSupply :: IO NameSupply
  47 initialNameSupply
  48  = let
  49      mk_supply =
  50           unsafeInterleaveIO (genSymbol "NameSupply")   >>= \ sym ->
  51           unsafeInterleaveIO mk_supply                  >>= \ supply1 ->
  52           unsafeInterleaveIO mk_supply                  >>= \ supply2 ->
  53           return (NameSupply sym supply1 supply2)
  54    in
  55    mk_supply
  56 #endif
  57
  58 #if defined(__HBC__)
  59 initialNameSupply = gen ()
  60         where gen n = NameSupply (__gensym n) (gen n) (gen n)
  61 #endif
  62
  63 splitNameSupply (NameSupply _ s1 s2) = (s1, s2)
  64
  65 getName (NameSupply k _ _) = k
  66
  67 listNameSupply (NameSupply _ s1 s2) = s1 : listNameSupply s2