[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / basicTypes / SplitUniq.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1994-1995
3 %
4 \section[Unique]{The @SplitUniqSupply@ data type (``splittable Unique supply'')}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module SplitUniq (
10         SplitUniqSupply,                -- abstract types
11
12         getSUnique, getSUniques,        -- basic ops
13         getSUniqueAndDepleted, getSUniquesAndDepleted,  -- DEPRECATED!
14
15         SUniqSM(..),            -- type: unique supply monad
16         initSUs, thenSUs, returnSUs,
17         mapSUs, mapAndUnzipSUs,
18
19         mkSplitUniqSupply,
20         splitUniqSupply,
21
22         -- to make interface self-sufficient
23         Unique
24         IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
25
26 #ifndef __GLASGOW_HASKELL__
27         ,TAG_
28 #endif
29     ) where
30
31 import Outputable       -- class for printing, forcing
32 import Pretty           -- pretty-printing utilities
33 import PrimOps          -- ** DIRECTLY **
34 import Unique
35 import Util
36
37 #if defined(__HBC__)
38 {-hide import from mkdependHS-}
39 import
40         Word
41 import
42         NameSupply      renaming ( Name to HBC_Name )
43 #endif
44 #ifdef __GLASGOW_HASKELL__
45 # if __GLASGOW_HASKELL__ >= 26
46 import PreludeGlaST
47 # else
48 import PreludePrimIO
49 import PreludeGlaST     ( unsafeInterleaveST
50                           IF_ATTACK_PRAGMAS(COMMA fixST)
51                         )
52 # endif
53 #endif
54
55 infixr 9 `thenUs`
56
57 #ifdef __GLASGOW_HASKELL__
58 w2i x = word2Int# x
59 i2w x = int2Word# x
60 i2w_s x = (x :: Int#)
61 #endif
62 \end{code}
63
64 %************************************************************************
65 %*                                                                      *
66 \subsection[SplitUniqSupply-type]{@SplitUniqSupply@ type and operations}
67 %*                                                                      *
68 %************************************************************************
69
70 A value of type @SplitUniqSupply@ is unique, and it can
71 supply {\em one} distinct @Unique@.  Also, from the supply, one can
72 also manufacture an arbitrary number of further @UniqueSupplies@,
73 which will be distinct from the first and from all others.
74
75 Common type signatures
76 \begin{code}
77 -- mkSplitUniqSupply :: differs by implementation!
78
79 splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
80 getSUnique :: SplitUniqSupply -> Unique
81 getSUniques :: Int -> SplitUniqSupply -> [Unique]
82 getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply)
83 getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply)
84 \end{code}
85
86 %************************************************************************
87 %*                                                                      *
88 \subsubsection{Chalmers implementation of @SplitUniqSupply@}
89 %*                                                                      *
90 %************************************************************************
91
92 \begin{code}
93 #if defined(__HBC__)
94
95 data SplitUniqSupply = MkSplit NameSupply
96
97 mkSplitUniqSupply :: Char -> SplitUniqSupply -- NB: not the same type
98
99 mkSplitUniqSupply _ = MkSplit initialNameSupply
100
101 splitUniqSupply (MkSplit us)
102   = case (splitNameSupply us) of { (s1, s2) ->
103     (MkSplit s1, MkSplit s2) }
104
105 getSUnique supply = error "getSUnique" -- mkUniqueGrimily (getName supply)
106
107 getSUniques i supply
108   = error "getSUniques" -- [ mkUniqueGrimily (getName s) | s <- take i (listNameSupply supply) ]
109
110 getSUniqueAndDepleted supply
111   = error "getSUniqueAndDepleted"
112 {-
113     let
114         u = mkUniqueGrimily (getName supply)
115         (s1, _) = splitNameSupply supply
116     in
117     (u, s1)
118 -}
119
120 getSUniquesAndDepleted i supply
121   = error "getSUniquesAndDepleted"
122 {-
123   = let
124         supplies = take (i+1) (listNameSupply supply)
125         uniqs    = [ mkUniqueGrimily (getName s) | s <- take i supplies ]
126         last_supply = drop i supplies
127     in
128     (uniqs, last_supply)
129 -}
130
131 #endif {- end of Chalmers implementation -}
132 \end{code}
133
134 %************************************************************************
135 %*                                                                      *
136 \subsubsection{Glasgow implementation of @SplitUniqSupply@}
137 %*                                                                      *
138 %************************************************************************
139
140 Glasgow Haskell implementation:
141 \begin{code}
142 #ifdef __GLASGOW_HASKELL__
143
144 # ifdef IGNORE_REFERENTIAL_TRANSPARENCY
145
146 data SplitUniqSupply = MkSplitUniqSupply {-does nothing-}
147
148 mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
149 mkSplitUniqSupply (MkChar c#) = returnPrimIO MkSplitUniqSupply
150
151 splitUniqSupply _ = (MkSplitUniqSupply, MkSplitUniqSupply)
152
153 getSUnique s = unsafe_mk_unique s
154
155 getSUniques i@(MkInt i#) supply = get_from i# supply
156   where
157     get_from 0# s = []
158     get_from n# s
159       = unsafe_mk_unique s : get_from (n# `minusInt#` 1#) s
160
161 getSUniqueAndDepleted s = (unsafe_mk_unique s, MkSplitUniqSupply)
162
163 getSUniquesAndDepleted i@(MkInt i#) s = get_from [] i# s
164   where
165     get_from acc 0# s = (acc, MkSplitUniqSupply)
166     get_from acc n# s
167       = get_from (unsafe_mk_unique s : acc) (n# `minusInt#` 1#) s
168
169 unsafe_mk_unique supply -- this is the TOTALLY unacceptable bit
170   = unsafePerformPrimIO (
171     _ccall_ genSymZh junk       `thenPrimIO` \ (W# u#) ->
172     returnPrimIO (mkUniqueGrimily (w2i (mask# `or#` u#)))
173     )
174   where
175     mask# = (i2w (ord# 'x'#)) `shiftL#` (i2w_s 24#)
176     junk  = case supply of { MkSplitUniqSupply -> (1::Int) }
177
178 # else {- slight attention to referential transparency -}
179
180 data SplitUniqSupply
181   = MkSplitUniqSupply Int       -- make the Unique with this
182                    SplitUniqSupply SplitUniqSupply
183                                 -- when split => these two supplies
184 \end{code}
185
186 @mkSplitUniqSupply@ is used to get a @SplitUniqSupply@ started.
187 \begin{code}
188
189 mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
190
191 -- ToDo: 64-bit bugs here!!???
192
193 mkSplitUniqSupply (MkChar c#)
194   = let
195         mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
196
197         -- here comes THE MAGIC:
198
199         mk_supply#
200 {- OLD:
201           = unsafe_interleave mk_unique  `thenPrimIO` \ uniq ->
202             unsafe_interleave mk_supply# `thenPrimIO` \ s1 ->
203             unsafe_interleave mk_supply# `thenPrimIO` \ s2 ->
204             returnPrimIO (MkSplitUniqSupply uniq s1 s2)
205 -}
206           = unsafe_interleave (
207                 mk_unique   `thenPrimIO` \ uniq ->
208                 mk_supply#  `thenPrimIO` \ s1 ->
209                 mk_supply#  `thenPrimIO` \ s2 ->
210                 returnPrimIO (MkSplitUniqSupply uniq s1 s2)
211             )
212           where
213             -- inlined copy of unsafeInterleavePrimIO;
214             -- this is the single-most-hammered bit of code
215             -- in the compiler....
216             unsafe_interleave m s
217               = let
218                     (r, new_s) = m s
219                 in
220                 (r, s)
221
222         mk_unique = _ccall_ genSymZh            `thenPrimIO` \ (W# u#) ->
223                     returnPrimIO (MkInt (w2i (mask# `or#` u#)))
224     in
225     mk_supply#
226
227 splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
228 \end{code}
229
230 \begin{code}
231 getSUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
232
233 getSUniques i@(MkInt i#) supply = i# `get_from` supply
234   where
235     get_from 0# _ = []
236     get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
237       = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
238
239 getSUniqueAndDepleted (MkSplitUniqSupply (MkInt n) s1 _) = (mkUniqueGrimily n, s1)
240
241 getSUniquesAndDepleted i@(MkInt i#) supply = get_from [] i# supply
242   where
243     get_from acc 0# s = (acc, s)
244     get_from acc n# (MkSplitUniqSupply (MkInt u#) _ s2)
245       = get_from (mkUniqueGrimily u# : acc) (n# `minusInt#` 1#) s2
246
247 # endif {- slight attention to referential transparency -}
248
249 #endif  {- end of Glasgow implementation -}
250 \end{code}
251
252 %************************************************************************
253 %*                                                                      *
254 \subsection[SplitUniq-monad]{Splittable Unique-supply monad}
255 %*                                                                      *
256 %************************************************************************
257
258 \begin{code}
259 type SUniqSM result = SplitUniqSupply -> result
260
261 -- the initUs function also returns the final SplitUniqSupply
262
263 initSUs :: SplitUniqSupply -> SUniqSM a -> (SplitUniqSupply, a)
264
265 initSUs init_us m
266   = case (splitUniqSupply init_us) of { (s1, s2) ->
267     (s2, m s1) }
268
269 #ifdef __GLASGOW_HASKELL__
270 {-# INLINE thenSUs #-}
271 {-# INLINE returnSUs #-}
272 {-# INLINE splitUniqSupply #-}
273 #endif
274 \end{code}
275
276 @thenSUs@ is where we split the @SplitUniqSupply@.
277 \begin{code}
278 thenSUs :: SUniqSM a -> (a -> SUniqSM b) -> SUniqSM b
279
280 thenSUs expr cont us
281   = case (splitUniqSupply us) of { (s1, s2) ->
282     case (expr s1)            of { result ->
283     cont result s2 }}
284 \end{code}
285
286 \begin{code}
287 returnSUs :: a -> SUniqSM a
288 returnSUs result us = result
289
290 mapSUs :: (a -> SUniqSM b) -> [a] -> SUniqSM [b]
291
292 mapSUs f []     = returnSUs []
293 mapSUs f (x:xs)
294   = f x         `thenSUs` \ r  ->
295     mapSUs f xs  `thenSUs` \ rs ->
296     returnSUs (r:rs)
297
298 mapAndUnzipSUs  :: (a -> SUniqSM (b,c))   -> [a] -> SUniqSM ([b],[c])
299
300 mapAndUnzipSUs f [] = returnSUs ([],[])
301 mapAndUnzipSUs f (x:xs)
302   = f x                 `thenSUs` \ (r1,  r2)  ->
303     mapAndUnzipSUs f xs `thenSUs` \ (rs1, rs2) ->
304     returnSUs (r1:rs1, r2:rs2)
305 \end{code}