X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FUniqSupply.lhs;h=493bfbe6dba572509c119692d2c51782f114b1a6;hp=41ad5c0f60dadb5846cfe77716e77673443ab0e6;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index 41ad5c0..493bfbe 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -1,114 +1,137 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[UniqSupply]{The @UniqueSupply@ data type and a (monadic) supply thereof} \begin{code} module UniqSupply ( + -- * Main data type + UniqSupply, -- Abstractly - UniqSupply, -- Abstractly + -- ** Operations on supplies + uniqFromSupply, uniqsFromSupply, -- basic ops + takeUniqFromSupply, - uniqFromSupply, uniqsFromSupply, -- basic ops + mkSplitUniqSupply, + splitUniqSupply, listSplitUniqSupply, - UniqSM, -- type: unique supply monad - initUs, initUs_, thenUs, thenUs_, returnUs, fixUs, getUs, withUs, - getUniqueUs, getUniquesUs, - mapUs, mapAndUnzipUs, mapAndUnzip3Us, - thenMaybeUs, mapAccumLUs, - lazyThenUs, lazyMapUs, + -- * Unique supply monad and its abstraction + UniqSM, MonadUnique(..), - mkSplitUniqSupply, - splitUniqSupply - ) where + -- ** Operations on the monad + initUs, initUs_, + lazyThenUs, lazyMapUs, -#include "HsVersions.h" + -- ** Deprecated operations on 'UniqSM' + getUniqueUs, getUs, returnUs, thenUs, mapUs + ) where import Unique +import FastTypes -import GLAEXTS -import UNSAFE_IO ( unsafeInterleaveIO ) +import MonadUtils +import Control.Monad +import GHC.IO (unsafeDupableInterleaveIO) -w2i x = word2Int# x -i2w x = int2Word# x -i2w_s x = (x :: Int#) \end{code} - %************************************************************************ -%* * +%* * \subsection{Splittable Unique supply: @UniqSupply@} -%* * +%* * %************************************************************************ -A value of type @UniqSupply@ is unique, and it can -supply {\em one} distinct @Unique@. Also, from the supply, one can -also manufacture an arbitrary number of further @UniqueSupplies@, -which will be distinct from the first and from all others. - \begin{code} +-- | 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. data UniqSupply - = MkSplitUniqSupply Int -- make the Unique with this - UniqSupply UniqSupply - -- when split => these two supplies + = MkSplitUniqSupply FastInt -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies \end{code} \begin{code} mkSplitUniqSupply :: Char -> IO UniqSupply +-- ^ 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. splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +-- ^ 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 uniqFromSupply :: UniqSupply -> Unique -uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain the 'Unique' from this particular 'UniqSupply' +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply \end{code} \begin{code} -mkSplitUniqSupply (C# c#) - = let -#if __GLASGOW_HASKELL__ >= 503 - mask# = (i2w (ord# c#)) `uncheckedShiftL#` (i2w_s 24#) -#else - mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#) -#endif - -- here comes THE MAGIC: - - -- This is one of the most hammered bits in the whole compiler - mk_supply# - = unsafeInterleaveIO ( - mk_unique >>= \ uniq -> - mk_supply# >>= \ s1 -> - mk_supply# >>= \ s2 -> - return (MkSplitUniqSupply uniq s1 s2) - ) - - mk_unique = genSymZh >>= \ (W# u#) -> - return (I# (w2i (mask# `or#` u#))) - in - mk_supply# - -foreign import ccall unsafe "genSymZh" genSymZh :: IO Word +mkSplitUniqSupply c + = case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of + mask -> let + -- 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) + )}) + in + mk_supply + +foreign import ccall unsafe "genSymZh" genSymZh :: IO Int splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 \end{code} \begin{code} -uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n -uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n) +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily (iBox n), s1) \end{code} %************************************************************************ -%* * +%* * \subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} -%* * +%* * %************************************************************************ \begin{code} -type UniqSM result = UniqSupply -> (result, UniqSupply) +-- | A monad which just gives the ability to obtain 'Unique's +newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) } + +instance Monad UniqSM where + return = returnUs + (>>=) = thenUs + (>>) = thenUs_ --- the initUs function also returns the final UniqSupply; initUs_ drops it -initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply) -initUs init_us m = case m init_us of { (r,us) -> (r,us) } +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 + (USM f) <*> (USM x) = USM $ \us -> case f us of + (ff, us') -> case x us' of + (xx, us'') -> (ff xx, us'') + +-- | Run the 'UniqSM' action, returning the final 'UniqSupply' +initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) +initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) } + +-- | Run the 'UniqSM' action, discarding the final 'UniqSupply' initUs_ :: UniqSupply -> UniqSM a -> a -initUs_ init_us m = case m init_us of { (r,us) -> r } +initUs_ init_us m = case unUSM m init_us of { (r, _) -> r } {-# INLINE thenUs #-} {-# INLINE lazyThenUs #-} @@ -118,86 +141,70 @@ initUs_ init_us m = case m init_us of { (r,us) -> r } @thenUs@ is where we split the @UniqSupply@. \begin{code} -fixUs :: (a -> UniqSM a) -> UniqSM a -fixUs m us - = (r,us') where (r,us') = m r us +instance MonadFix UniqSM where + mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us')) thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -thenUs expr cont us - = case (expr us) of { (result, us') -> cont result us' } +thenUs (USM expr) cont + = USM (\us -> case (expr us) of + (result, us') -> unUSM (cont result) us') lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -lazyThenUs expr cont us - = let (result, us') = expr us in cont result us' +lazyThenUs (USM expr) cont + = USM (\us -> let (result, us') = expr us in unUSM (cont result) us') thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b -thenUs_ expr cont us - = case (expr us) of { (_, us') -> cont us' } - +thenUs_ (USM expr) (USM cont) + = USM (\us -> case (expr us) of { (_, us') -> cont us' }) returnUs :: a -> UniqSM a -returnUs result us = (result, us) +returnUs result = USM (\us -> (result, us)) -withUs :: (UniqSupply -> (a, UniqSupply)) -> UniqSM a -withUs f us = f us -- Ha ha! - getUs :: UniqSM UniqSupply -getUs us = splitUniqSupply us +getUs = USM (\us -> splitUniqSupply us) + +-- | 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] + + getUniqueM = liftM uniqFromSupply getUniqueSupplyM + getUniquesM = liftM uniqsFromSupply getUniqueSupplyM + +instance MonadUnique UniqSM where + getUniqueSupplyM = USM (\us -> splitUniqSupply us) + getUniqueM = getUniqueUs + getUniquesM = getUniquesUs getUniqueUs :: UniqSM Unique -getUniqueUs us = case splitUniqSupply us of - (us1,us2) -> (uniqFromSupply us1, us2) +getUniqueUs = USM (\us -> case splitUniqSupply us of + (us1,us2) -> (uniqFromSupply us1, us2)) getUniquesUs :: UniqSM [Unique] -getUniquesUs us = case splitUniqSupply us of - (us1,us2) -> (uniqsFromSupply us1, us2) -\end{code} +getUniquesUs = USM (\us -> case splitUniqSupply us of + (us1,us2) -> (uniqsFromSupply us1, us2)) -\begin{code} mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] -mapUs f [] = returnUs [] +mapUs _ [] = returnUs [] mapUs f (x:xs) = f x `thenUs` \ r -> mapUs f xs `thenUs` \ rs -> returnUs (r:rs) +\end{code} + +\begin{code} +-- {-# 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]) #-} lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] -lazyMapUs f [] = returnUs [] +lazyMapUs _ [] = returnUs [] lazyMapUs f (x:xs) = f x `lazyThenUs` \ r -> lazyMapUs f xs `lazyThenUs` \ rs -> returnUs (r:rs) - -mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) -mapAndUnzip3Us :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) - -mapAndUnzipUs f [] = returnUs ([],[]) -mapAndUnzipUs f (x:xs) - = f x `thenUs` \ (r1, r2) -> - mapAndUnzipUs f xs `thenUs` \ (rs1, rs2) -> - returnUs (r1:rs1, r2:rs2) - -mapAndUnzip3Us f [] = returnUs ([],[],[]) -mapAndUnzip3Us f (x:xs) - = f x `thenUs` \ (r1, r2, r3) -> - mapAndUnzip3Us f xs `thenUs` \ (rs1, rs2, rs3) -> - returnUs (r1:rs1, r2:rs2, r3:rs3) - -thenMaybeUs :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b) -thenMaybeUs m k - = m `thenUs` \ result -> - case result of - Nothing -> returnUs Nothing - Just x -> k x - -mapAccumLUs :: (acc -> x -> UniqSM (acc, y)) - -> acc - -> [x] - -> UniqSM (acc, [y]) - -mapAccumLUs f b [] = returnUs (b, []) -mapAccumLUs f b (x:xs) - = f b x `thenUs` \ (b__2, x__2) -> - mapAccumLUs f b__2 xs `thenUs` \ (b__3, xs__2) -> - returnUs (b__3, x__2:xs__2) \end{code}