2 % (c) The AQUA Project, Glasgow University, 1994-1995
4 \section[Unique]{The @SplitUniqSupply@ data type (``splittable Unique supply'')}
7 #include "HsVersions.h"
10 SplitUniqSupply, -- abstract types
12 getSUnique, getSUniques, -- basic ops
13 getSUniqueAndDepleted, getSUniquesAndDepleted, -- DEPRECATED!
15 SUniqSM(..), -- type: unique supply monad
16 initSUs, thenSUs, returnSUs,
17 mapSUs, mapAndUnzipSUs,
22 -- to make interface self-sufficient
24 IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
26 #ifndef __GLASGOW_HASKELL__
31 import Outputable -- class for printing, forcing
32 import Pretty -- pretty-printing utilities
33 import PrimOps -- ** DIRECTLY **
38 {-hide import from mkdependHS-}
42 NameSupply renaming ( Name to HBC_Name )
44 #ifdef __GLASGOW_HASKELL__
45 # if __GLASGOW_HASKELL__ >= 26
49 import PreludeGlaST ( unsafeInterleaveST
50 IF_ATTACK_PRAGMAS(COMMA fixST)
57 #ifdef __GLASGOW_HASKELL__
64 %************************************************************************
66 \subsection[SplitUniqSupply-type]{@SplitUniqSupply@ type and operations}
68 %************************************************************************
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.
75 Common type signatures
77 -- mkSplitUniqSupply :: differs by implementation!
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)
86 %************************************************************************
88 \subsubsection{Chalmers implementation of @SplitUniqSupply@}
90 %************************************************************************
95 data SplitUniqSupply = MkSplit NameSupply
97 mkSplitUniqSupply :: Char -> SplitUniqSupply -- NB: not the same type
99 mkSplitUniqSupply _ = MkSplit initialNameSupply
101 splitUniqSupply (MkSplit us)
102 = case (splitNameSupply us) of { (s1, s2) ->
103 (MkSplit s1, MkSplit s2) }
105 getSUnique supply = error "getSUnique" -- mkUniqueGrimily (getName supply)
108 = error "getSUniques" -- [ mkUniqueGrimily (getName s) | s <- take i (listNameSupply supply) ]
110 getSUniqueAndDepleted supply
111 = error "getSUniqueAndDepleted"
114 u = mkUniqueGrimily (getName supply)
115 (s1, _) = splitNameSupply supply
120 getSUniquesAndDepleted i supply
121 = error "getSUniquesAndDepleted"
124 supplies = take (i+1) (listNameSupply supply)
125 uniqs = [ mkUniqueGrimily (getName s) | s <- take i supplies ]
126 last_supply = drop i supplies
131 #endif {- end of Chalmers implementation -}
134 %************************************************************************
136 \subsubsection{Glasgow implementation of @SplitUniqSupply@}
138 %************************************************************************
140 Glasgow Haskell implementation:
142 #ifdef __GLASGOW_HASKELL__
144 # ifdef IGNORE_REFERENTIAL_TRANSPARENCY
146 data SplitUniqSupply = MkSplitUniqSupply {-does nothing-}
148 mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
149 mkSplitUniqSupply (MkChar c#) = returnPrimIO MkSplitUniqSupply
151 splitUniqSupply _ = (MkSplitUniqSupply, MkSplitUniqSupply)
153 getSUnique s = unsafe_mk_unique s
155 getSUniques i@(MkInt i#) supply = get_from i# supply
159 = unsafe_mk_unique s : get_from (n# `minusInt#` 1#) s
161 getSUniqueAndDepleted s = (unsafe_mk_unique s, MkSplitUniqSupply)
163 getSUniquesAndDepleted i@(MkInt i#) s = get_from [] i# s
165 get_from acc 0# s = (acc, MkSplitUniqSupply)
167 = get_from (unsafe_mk_unique s : acc) (n# `minusInt#` 1#) s
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#)))
175 mask# = (i2w (ord# 'x'#)) `shiftL#` (i2w_s 24#)
176 junk = case supply of { MkSplitUniqSupply -> (1::Int) }
178 # else {- slight attention to referential transparency -}
181 = MkSplitUniqSupply Int -- make the Unique with this
182 SplitUniqSupply SplitUniqSupply
183 -- when split => these two supplies
186 @mkSplitUniqSupply@ is used to get a @SplitUniqSupply@ started.
189 mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
191 -- ToDo: 64-bit bugs here!!???
193 mkSplitUniqSupply (MkChar c#)
195 mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
197 -- here comes THE MAGIC:
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)
206 = unsafe_interleave (
207 mk_unique `thenPrimIO` \ uniq ->
208 mk_supply# `thenPrimIO` \ s1 ->
209 mk_supply# `thenPrimIO` \ s2 ->
210 returnPrimIO (MkSplitUniqSupply uniq s1 s2)
213 -- inlined copy of unsafeInterleavePrimIO;
214 -- this is the single-most-hammered bit of code
215 -- in the compiler....
216 unsafe_interleave m s
222 mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) ->
223 returnPrimIO (MkInt (w2i (mask# `or#` u#)))
227 splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
231 getSUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
233 getSUniques i@(MkInt i#) supply = i# `get_from` supply
236 get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
237 = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
239 getSUniqueAndDepleted (MkSplitUniqSupply (MkInt n) s1 _) = (mkUniqueGrimily n, s1)
241 getSUniquesAndDepleted i@(MkInt i#) supply = get_from [] i# supply
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
247 # endif {- slight attention to referential transparency -}
249 #endif {- end of Glasgow implementation -}
252 %************************************************************************
254 \subsection[SplitUniq-monad]{Splittable Unique-supply monad}
256 %************************************************************************
259 type SUniqSM result = SplitUniqSupply -> result
261 -- the initUs function also returns the final SplitUniqSupply
263 initSUs :: SplitUniqSupply -> SUniqSM a -> (SplitUniqSupply, a)
266 = case (splitUniqSupply init_us) of { (s1, s2) ->
269 #ifdef __GLASGOW_HASKELL__
270 {-# INLINE thenSUs #-}
271 {-# INLINE returnSUs #-}
272 {-# INLINE splitUniqSupply #-}
276 @thenSUs@ is where we split the @SplitUniqSupply@.
278 thenSUs :: SUniqSM a -> (a -> SUniqSM b) -> SUniqSM b
281 = case (splitUniqSupply us) of { (s1, s2) ->
282 case (expr s1) of { result ->
287 returnSUs :: a -> SUniqSM a
288 returnSUs result us = result
290 mapSUs :: (a -> SUniqSM b) -> [a] -> SUniqSM [b]
292 mapSUs f [] = returnSUs []
294 = f x `thenSUs` \ r ->
295 mapSUs f xs `thenSUs` \ rs ->
298 mapAndUnzipSUs :: (a -> SUniqSM (b,c)) -> [a] -> SUniqSM ([b],[c])
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)