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