X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FUniqSupply.lhs;h=2599d8d5f0f3e3bf1fdc0984583ed8f21f715b79;hb=992bdde6de529002406a63abf94cb3e8a644bf3b;hp=c228eeb5708740740059a5850a1d3383c8d5f2d2;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4;p=ghc-hetmet.git diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index c228eeb..2599d8d 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -18,11 +18,10 @@ module UniqSupply ( uniqFromSupply, uniqsFromSupply, -- basic ops UniqSM, -- type: unique supply monad - initUs, initUs_, thenUs, thenUs_, returnUs, fixUs, getUs, withUs, - getUniqueUs, getUniquesUs, - mapUs, mapAndUnzipUs, mapAndUnzip3Us, - thenMaybeUs, mapAccumLUs, + initUs, initUs_, lazyThenUs, lazyMapUs, + module MonadUtils, mapAndUnzipM, + MonadUnique(..), mkSplitUniqSupply, splitUniqSupply, listSplitUniqSupply @@ -31,20 +30,16 @@ module UniqSupply ( #include "HsVersions.h" import Unique - -import GHC.Exts -import System.IO.Unsafe ( unsafeInterleaveIO ) +import FastTypes #if __GLASGOW_HASKELL__ >= 607 import GHC.IOBase (unsafeDupableInterleaveIO) #else +import System.IO.Unsafe ( unsafeInterleaveIO ) unsafeDupableInterleaveIO :: IO a -> IO a unsafeDupableInterleaveIO = unsafeInterleaveIO #endif -w2i x = word2Int# x -i2w x = int2Word# x -i2w_s x = (x :: Int#) \end{code} @@ -61,7 +56,7 @@ which will be distinct from the first and from all others. \begin{code} data UniqSupply - = MkSplitUniqSupply Int# -- make the Unique with this + = MkSplitUniqSupply FastInt -- make the Unique with this UniqSupply UniqSupply -- when split => these two supplies \end{code} @@ -76,21 +71,21 @@ uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite \end{code} \begin{code} -mkSplitUniqSupply (C# c#) - = let - mask# = (i2w (ord# c#)) `uncheckedShiftL#` (i2w_s 24#) +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# + mk_supply = unsafeDupableInterleaveIO ( - genSymZh >>= \ (I# u#) -> - mk_supply# >>= \ s1 -> - mk_supply# >>= \ s2 -> - return (MkSplitUniqSupply (w2i (mask# `or#` (i2w u#))) s1 s2) - ) - in - mk_supply# + 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 @@ -99,8 +94,8 @@ listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 \end{code} \begin{code} -uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (I# n) -uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (I# n) : uniqsFromSupply s2 +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n) +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2 \end{code} %************************************************************************ @@ -132,8 +127,8 @@ initUs_ init_us m = case unUSM m init_us of { (r,us) -> r } @thenUs@ is where we split the @UniqSupply@. \begin{code} -fixUs :: (a -> UniqSM a) -> UniqSM a -fixUs m = USM (\us -> let (r,us') = unUSM (m r) us in (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 (USM expr) cont @@ -148,7 +143,6 @@ thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b thenUs_ (USM expr) (USM cont) = USM (\us -> case (expr us) of { (_, us') -> cont us' }) - returnUs :: a -> UniqSM a returnUs result = USM (\us -> (result, us)) @@ -158,6 +152,23 @@ withUs f = USM (\us -> f us) -- Ha ha! getUs :: UniqSM UniqSupply 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 = USM (\us -> case splitUniqSupply us of (us1,us2) -> (uniqFromSupply us1, us2)) @@ -168,12 +179,9 @@ getUniquesUs = USM (\us -> case splitUniqSupply us of \end{code} \begin{code} -mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] -mapUs f [] = returnUs [] -mapUs f (x:xs) - = f x `thenUs` \ r -> - mapUs f xs `thenUs` \ rs -> - returnUs (r:rs) +{-# -- 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 [] @@ -182,36 +190,4 @@ lazyMapUs f (x:xs) 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}