2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
9 UniqSupply, -- Abstractly
11 uniqFromSupply, uniqsFromSupply, -- basic ops
13 UniqSM, -- type: unique supply monad
15 lazyThenUs, lazyMapUs,
20 splitUniqSupply, listSplitUniqSupply,
23 getUniqueUs, getUs, returnUs, thenUs, mapUs
31 import Control.Monad.Fix
32 #if __GLASGOW_HASKELL__ >= 607
33 import GHC.IOBase (unsafeDupableInterleaveIO)
35 import System.IO.Unsafe ( unsafeInterleaveIO )
36 unsafeDupableInterleaveIO :: IO a -> IO a
37 unsafeDupableInterleaveIO = unsafeInterleaveIO
43 %************************************************************************
45 \subsection{Splittable Unique supply: @UniqSupply@}
47 %************************************************************************
49 A value of type @UniqSupply@ is unique, and it can
50 supply {\em one} distinct @Unique@. Also, from the supply, one can
51 also manufacture an arbitrary number of further @UniqueSupplies@,
52 which will be distinct from the first and from all others.
56 = MkSplitUniqSupply FastInt -- make the Unique with this
58 -- when split => these two supplies
62 mkSplitUniqSupply :: Char -> IO UniqSupply
64 splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
65 listSplitUniqSupply :: UniqSupply -> [UniqSupply] -- Infinite
66 uniqFromSupply :: UniqSupply -> Unique
67 uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
72 = case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of
74 -- here comes THE MAGIC:
76 -- This is one of the most hammered bits in the whole compiler
78 = unsafeDupableInterleaveIO (
79 genSymZh >>= \ u_ -> case iUnbox u_ of { u -> (
82 return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2)
87 foreign import ccall unsafe "genSymZh" genSymZh :: IO Int
89 splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
90 listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
94 uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n)
95 uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2
98 %************************************************************************
100 \subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
102 %************************************************************************
105 newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) }
107 instance Monad UniqSM where
112 instance Functor UniqSM where
113 fmap f (USM x) = USM (\us -> case x us of
114 (r, us') -> (f r, us'))
116 instance Applicative UniqSM where
118 (USM f) <*> (USM x) = USM $ \us -> case f us of
119 (ff, us') -> case x us' of
120 (xx, us'') -> (ff xx, us'')
122 -- the initUs function also returns the final UniqSupply; initUs_ drops it
123 initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply)
124 initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) }
126 initUs_ :: UniqSupply -> UniqSM a -> a
127 initUs_ init_us m = case unUSM m init_us of { (r, _) -> r }
129 {-# INLINE thenUs #-}
130 {-# INLINE lazyThenUs #-}
131 {-# INLINE returnUs #-}
132 {-# INLINE splitUniqSupply #-}
135 @thenUs@ is where we split the @UniqSupply@.
137 instance MonadFix UniqSM where
138 mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us'))
140 thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
141 thenUs (USM expr) cont
142 = USM (\us -> case (expr us) of
143 (result, us') -> unUSM (cont result) us')
145 lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
146 lazyThenUs (USM expr) cont
147 = USM (\us -> let (result, us') = expr us in unUSM (cont result) us')
149 thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
150 thenUs_ (USM expr) (USM cont)
151 = USM (\us -> case (expr us) of { (_, us') -> cont us' })
153 returnUs :: a -> UniqSM a
154 returnUs result = USM (\us -> (result, us))
156 getUs :: UniqSM UniqSupply
157 getUs = USM (\us -> splitUniqSupply us)
159 -- | A monad for generating unique identifiers
160 class Monad m => MonadUnique m where
161 -- | Get a new UniqueSupply
162 getUniqueSupplyM :: m UniqSupply
163 -- | Get a new unique identifier
164 getUniqueM :: m Unique
165 -- | Get an infinite list of new unique identifiers
166 getUniquesM :: m [Unique]
168 getUniqueM = liftM uniqFromSupply getUniqueSupplyM
169 getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
171 instance MonadUnique UniqSM where
172 getUniqueSupplyM = USM (\us -> splitUniqSupply us)
173 getUniqueM = getUniqueUs
174 getUniquesM = getUniquesUs
176 getUniqueUs :: UniqSM Unique
177 getUniqueUs = USM (\us -> case splitUniqSupply us of
178 (us1,us2) -> (uniqFromSupply us1, us2))
180 getUniquesUs :: UniqSM [Unique]
181 getUniquesUs = USM (\us -> case splitUniqSupply us of
182 (us1,us2) -> (uniqsFromSupply us1, us2))
184 mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
185 mapUs _ [] = returnUs []
187 = f x `thenUs` \ r ->
188 mapUs f xs `thenUs` \ rs ->
193 {-# -- SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-}
194 {-# -- SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-}
195 {-# -- SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-}
197 lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
198 lazyMapUs _ [] = returnUs []
200 = f x `lazyThenUs` \ r ->
201 lazyMapUs f xs `lazyThenUs` \ rs ->