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