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