UniqSupply.lhs 6.89 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6
7
%

\begin{code}
module UniqSupply (
batterseapower's avatar
batterseapower committed
8
        -- * Main data type
Ian Lynagh's avatar
Ian Lynagh committed
9
        UniqSupply, -- Abstractly
10

Ian Lynagh's avatar
Ian Lynagh committed
11
        -- ** Operations on supplies
Ian Lynagh's avatar
Ian Lynagh committed
12
        uniqFromSupply, uniqsFromSupply, -- basic ops
Ian Lynagh's avatar
Ian Lynagh committed
13
        takeUniqFromSupply,
Ian Lynagh's avatar
Ian Lynagh committed
14

batterseapower's avatar
batterseapower committed
15
16
        mkSplitUniqSupply,
        splitUniqSupply, listSplitUniqSupply,
17

batterseapower's avatar
batterseapower committed
18
19
        -- * Unique supply monad and its abstraction
        UniqSM, MonadUnique(..),
Ian Lynagh's avatar
Ian Lynagh committed
20

batterseapower's avatar
batterseapower committed
21
        -- ** Operations on the monad
Ian Lynagh's avatar
Ian Lynagh committed
22
23
        initUs, initUs_,
        lazyThenUs, lazyMapUs,
Ian Lynagh's avatar
Ian Lynagh committed
24

batterseapower's avatar
batterseapower committed
25
        -- ** Deprecated operations on 'UniqSM'
26
        getUniqueUs, getUs,
27
28
29
  ) where

import Unique
30
import FastTypes
sof's avatar
sof committed
31

32
import GHC.IO (unsafeDupableInterleaveIO)
33

Ian Lynagh's avatar
Ian Lynagh committed
34
35
import MonadUtils
import Control.Monad
36

37
38
39
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
40
%*                                                                      *
41
\subsection{Splittable Unique supply: @UniqSupply@}
Ian Lynagh's avatar
Ian Lynagh committed
42
%*                                                                      *
43
44
45
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
46
47
48
49
-- | A value of type 'UniqSupply' is unique, and it can
-- supply /one/ distinct 'Unique'.  Also, from the supply, one can
-- also manufacture an arbitrary number of further 'UniqueSupply' values,
-- which will be distinct from the first and from all others.
50
data UniqSupply
Ian Lynagh's avatar
Ian Lynagh committed
51
52
53
  = MkSplitUniqSupply FastInt   -- make the Unique with this
                   UniqSupply UniqSupply
                                -- when split => these two supplies
54
55
56
\end{code}

\begin{code}
57
mkSplitUniqSupply :: Char -> IO UniqSupply
batterseapower's avatar
batterseapower committed
58
59
60
-- ^ Create a unique supply out of thin air. The character given must
-- be distinct from those of all calls to this function in the compiler
-- for the values generated to be truly unique.
61
62

splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
batterseapower's avatar
batterseapower committed
63
64
65
66
-- ^ Build two 'UniqSupply' from a single one, each of which
-- can supply its own 'Unique'.
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
-- ^ Create an infinite list of 'UniqSupply' from a single one
67
uniqFromSupply  :: UniqSupply -> Unique
batterseapower's avatar
batterseapower committed
68
-- ^ Obtain the 'Unique' from this particular 'UniqSupply'
Ian Lynagh's avatar
Ian Lynagh committed
69
uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
batterseapower's avatar
batterseapower committed
70
-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply
Ian Lynagh's avatar
Ian Lynagh committed
71
72
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply
73
74
75
\end{code}

\begin{code}
76
77
78
mkSplitUniqSupply c
  = case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of
     mask -> let
Ian Lynagh's avatar
Ian Lynagh committed
79
80
81
82
83
84
85
86
87
88
        -- here comes THE MAGIC:

        -- This is one of the most hammered bits in the whole compiler
        mk_supply
          = unsafeDupableInterleaveIO (
                genSymZh    >>= \ u_ -> case iUnbox u_ of { u -> (
                mk_supply   >>= \ s1 ->
                mk_supply   >>= \ s2 ->
                return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2)
            )})
89
90
       in
       mk_supply
91

Ian Lynagh's avatar
Ian Lynagh committed
92
foreign import ccall unsafe "genSymZh" genSymZh :: IO Int
93

94
splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
95
listSplitUniqSupply  (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
96
97
98
\end{code}

\begin{code}
99
100
uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily (iBox n)
uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2
Ian Lynagh's avatar
Ian Lynagh committed
101
takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily (iBox n), s1)
102
103
104
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
105
%*                                                                      *
106
\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
Ian Lynagh's avatar
Ian Lynagh committed
107
%*                                                                      *
108
109
110
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
111
-- | A monad which just gives the ability to obtain 'Unique's
112
113
114
115
116
117
newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) }

instance Monad UniqSM where
  return = returnUs
  (>>=) = thenUs
  (>>)  = thenUs_
118

Ian Lynagh's avatar
Ian Lynagh committed
119
120
121
122
123
124
instance Functor UniqSM where
    fmap f (USM x) = USM (\us -> case x us of
                                 (r, us') -> (f r, us'))

instance Applicative UniqSM where
    pure = returnUs
Ian Lynagh's avatar
Ian Lynagh committed
125
126
    (USM f) <*> (USM x) = USM $ \us -> case f us of
                            (ff, us')  -> case x us' of
Ian Lynagh's avatar
Ian Lynagh committed
127
128
                              (xx, us'') -> (ff xx, us'')

batterseapower's avatar
batterseapower committed
129
130
-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
131
initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) }
132

batterseapower's avatar
batterseapower committed
133
-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'
134
initUs_ :: UniqSupply -> UniqSM a -> a
Ian Lynagh's avatar
Ian Lynagh committed
135
initUs_ init_us m = case unUSM m init_us of { (r, _) -> r }
136
137

{-# INLINE thenUs #-}
138
{-# INLINE lazyThenUs #-}
139
140
141
142
143
144
{-# INLINE returnUs #-}
{-# INLINE splitUniqSupply #-}
\end{code}

@thenUs@ is where we split the @UniqSupply@.
\begin{code}
145
146
instance MonadFix UniqSM where
    mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us'))
147

148
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
149
thenUs (USM expr) cont
Ian Lynagh's avatar
Ian Lynagh committed
150
151
  = USM (\us -> case (expr us) of
                   (result, us') -> unUSM (cont result) us')
152

153
lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
154
155
lazyThenUs (USM expr) cont
  = USM (\us -> let (result, us') = expr us in unUSM (cont result) us')
156

157
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
158
159
thenUs_ (USM expr) (USM cont)
  = USM (\us -> case (expr us) of { (_, us') -> cont us' })
160
161

returnUs :: a -> UniqSM a
162
returnUs result = USM (\us -> (result, us))
163
164

getUs :: UniqSM UniqSupply
165
getUs = USM (\us -> splitUniqSupply us)
166

167
168
169
170
171
172
173
174
-- | A monad for generating unique identifiers
class Monad m => MonadUnique m where
    -- | Get a new UniqueSupply
    getUniqueSupplyM :: m UniqSupply
    -- | Get a new unique identifier
    getUniqueM  :: m Unique
    -- | Get an infinite list of new unique identifiers
    getUniquesM :: m [Unique]
Ian Lynagh's avatar
Ian Lynagh committed
175

176
177
178
179
180
181
182
183
    getUniqueM  = liftM uniqFromSupply  getUniqueSupplyM
    getUniquesM = liftM uniqsFromSupply getUniqueSupplyM

instance MonadUnique UniqSM where
    getUniqueSupplyM = USM (\us -> splitUniqSupply us)
    getUniqueM  = getUniqueUs
    getUniquesM = getUniquesUs

184
getUniqueUs :: UniqSM Unique
185
getUniqueUs = USM (\us -> case splitUniqSupply us of
Ian Lynagh's avatar
Ian Lynagh committed
186
                          (us1,us2) -> (uniqFromSupply us1, us2))
187

188
getUniquesUs :: UniqSM [Unique]
189
getUniquesUs = USM (\us -> case splitUniqSupply us of
Ian Lynagh's avatar
Ian Lynagh committed
190
                           (us1,us2) -> (uniqsFromSupply us1, us2))
191
192
193
\end{code}

\begin{code}
194
195
196
-- {-# SPECIALIZE mapM          :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-}
-- {-# SPECIALIZE mapAndUnzipM  :: (a -> UniqSM (b,c))   -> [a] -> UniqSM ([b],[c]) #-}
-- {-# SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-}
197

198
lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
Ian Lynagh's avatar
Ian Lynagh committed
199
lazyMapUs _ []     = returnUs []
200
201
202
203
lazyMapUs f (x:xs)
  = f x             `lazyThenUs` \ r  ->
    lazyMapUs f xs  `lazyThenUs` \ rs ->
    returnUs (r:rs)
204
\end{code}