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