Make derived names deterministic
[ghc.git] / compiler / basicTypes / UniqSupply.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 -}
5
6 {-# LANGUAGE UnboxedTuples #-}
7
8 module UniqSupply (
9 -- * Main data type
10 UniqSupply, -- Abstractly
11
12 -- ** Operations on supplies
13 uniqFromSupply, uniqsFromSupply, -- basic ops
14 takeUniqFromSupply,
15
16 mkSplitUniqSupply,
17 splitUniqSupply, listSplitUniqSupply,
18
19 -- * Unique supply monad and its abstraction
20 UniqSM, MonadUnique(..),
21
22 -- ** Operations on the monad
23 initUs, initUs_,
24 lazyThenUs, lazyMapUs,
25 ) where
26
27 import Unique
28
29 import GHC.IO
30
31 import MonadUtils
32 import Control.Monad
33 import Data.Bits
34 import Data.Char
35
36 {-
37 ************************************************************************
38 * *
39 \subsection{Splittable Unique supply: @UniqSupply@}
40 * *
41 ************************************************************************
42 -}
43
44 -- | A value of type 'UniqSupply' is unique, and it can
45 -- supply /one/ distinct 'Unique'. Also, from the supply, one can
46 -- also manufacture an arbitrary number of further 'UniqueSupply' values,
47 -- which will be distinct from the first and from all others.
48 data UniqSupply
49 = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this
50 UniqSupply UniqSupply
51 -- when split => these two supplies
52
53 mkSplitUniqSupply :: Char -> IO UniqSupply
54 -- ^ Create a unique supply out of thin air. The character given must
55 -- be distinct from those of all calls to this function in the compiler
56 -- for the values generated to be truly unique.
57
58 splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
59 -- ^ Build two 'UniqSupply' from a single one, each of which
60 -- can supply its own 'Unique'.
61 listSplitUniqSupply :: UniqSupply -> [UniqSupply]
62 -- ^ Create an infinite list of 'UniqSupply' from a single one
63 uniqFromSupply :: UniqSupply -> Unique
64 -- ^ Obtain the 'Unique' from this particular 'UniqSupply'
65 uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
66 -- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply
67 takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
68 -- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply
69
70 mkSplitUniqSupply c
71 = case ord c `shiftL` 24 of
72 mask -> let
73 -- here comes THE MAGIC:
74
75 -- This is one of the most hammered bits in the whole compiler
76 mk_supply
77 -- NB: Use unsafeInterleaveIO for thread-safety.
78 = unsafeInterleaveIO (
79 genSym >>= \ u ->
80 mk_supply >>= \ s1 ->
81 mk_supply >>= \ s2 ->
82 return (MkSplitUniqSupply (mask .|. u) s1 s2)
83 )
84 in
85 mk_supply
86
87 foreign import ccall unsafe "genSym" genSym :: IO Int
88
89 splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
90 listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
91
92 uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
93 uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
94 takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
95
96 {-
97 ************************************************************************
98 * *
99 \subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
100 * *
101 ************************************************************************
102 -}
103
104 -- | A monad which just gives the ability to obtain 'Unique's
105 newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }
106
107 instance Monad UniqSM where
108 return = returnUs
109 (>>=) = thenUs
110 (>>) = thenUs_
111
112 instance Functor UniqSM where
113 fmap f (USM x) = USM (\us -> case x us of
114 (# r, us' #) -> (# f r, us' #))
115
116 instance Applicative UniqSM where
117 pure = returnUs
118 (USM f) <*> (USM x) = USM $ \us -> case f us of
119 (# ff, us' #) -> case x us' of
120 (# xx, us'' #) -> (# ff xx, us'' #)
121 (*>) = thenUs_
122
123 -- | Run the 'UniqSM' action, returning the final 'UniqSupply'
124 initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
125 initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
126
127 -- | Run the 'UniqSM' action, discarding the final 'UniqSupply'
128 initUs_ :: UniqSupply -> UniqSM a -> a
129 initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r }
130
131 {-# INLINE thenUs #-}
132 {-# INLINE lazyThenUs #-}
133 {-# INLINE returnUs #-}
134 {-# INLINE splitUniqSupply #-}
135
136 -- @thenUs@ is where we split the @UniqSupply@.
137
138 liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
139 liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us')
140
141 instance MonadFix UniqSM where
142 mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #))
143
144 thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
145 thenUs (USM expr) cont
146 = USM (\us -> case (expr us) of
147 (# result, us' #) -> unUSM (cont result) us')
148
149 lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
150 lazyThenUs expr cont
151 = USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us')
152
153 thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
154 thenUs_ (USM expr) (USM cont)
155 = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' })
156
157 returnUs :: a -> UniqSM a
158 returnUs result = USM (\us -> (# result, us #))
159
160 getUs :: UniqSM UniqSupply
161 getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #))
162
163 -- | A monad for generating unique identifiers
164 class Monad m => MonadUnique m where
165 -- | Get a new UniqueSupply
166 getUniqueSupplyM :: m UniqSupply
167 -- | Get a new unique identifier
168 getUniqueM :: m Unique
169 -- | Get an infinite list of new unique identifiers
170 getUniquesM :: m [Unique]
171
172 -- This default definition of getUniqueM, while correct, is not as
173 -- efficient as it could be since it needlessly generates and throws away
174 -- an extra Unique. For your instances consider providing an explicit
175 -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.
176 getUniqueM = liftM uniqFromSupply getUniqueSupplyM
177 getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
178
179 instance MonadUnique UniqSM where
180 getUniqueSupplyM = getUs
181 getUniqueM = getUniqueUs
182 getUniquesM = getUniquesUs
183
184 getUniqueUs :: UniqSM Unique
185 getUniqueUs = USM (\us -> case takeUniqFromSupply us of
186 (u,us') -> (# u, us' #))
187
188 getUniquesUs :: UniqSM [Unique]
189 getUniquesUs = USM (\us -> case splitUniqSupply us of
190 (us1,us2) -> (# uniqsFromSupply us1, us2 #))
191
192 -- {-# SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-}
193 -- {-# SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-}
194 -- {-# SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-}
195
196 lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
197 lazyMapUs _ [] = returnUs []
198 lazyMapUs f (x:xs)
199 = f x `lazyThenUs` \ r ->
200 lazyMapUs f xs `lazyThenUs` \ rs ->
201 returnUs (r:rs)