X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FUniqSupply.lhs;h=493bfbe6dba572509c119692d2c51782f114b1a6;hp=d28372adb38d985e7cfe00f9edd3a26b50c7f47f;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index d28372a..493bfbe 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -4,87 +4,87 @@ % \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - 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, listSplitUniqSupply - ) 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 -#if __GLASGOW_HASKELL__ >= 607 -import GHC.IOBase (unsafeDupableInterleaveIO) -#else -import System.IO.Unsafe ( unsafeInterleaveIO ) -unsafeDupableInterleaveIO :: IO a -> IO a -unsafeDupableInterleaveIO = unsafeInterleaveIO -#endif +import MonadUtils +import Control.Monad +import GHC.IO (unsafeDupableInterleaveIO) \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 FastInt -- 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) -listSplitUniqSupply :: UniqSupply -> [UniqSupply] -- Infinite +-- ^ 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 = 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) - )}) + -- 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 @@ -97,15 +97,17 @@ listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 \begin{code} 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} +-- | A monad which just gives the ability to obtain 'Unique's newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) } instance Monad UniqSM where @@ -113,12 +115,23 @@ instance Monad UniqSM where (>>=) = thenUs (>>) = thenUs_ --- the initUs function also returns the final UniqSupply; initUs_ drops it -initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply) +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 unUSM m init_us of { (r,us) -> r } +initUs_ init_us m = case unUSM m init_us of { (r, _) -> r } {-# INLINE thenUs #-} {-# INLINE lazyThenUs #-} @@ -128,13 +141,13 @@ 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 - = USM (\us -> case (expr us) of - (result, us') -> unUSM (cont result) us') + = USM (\us -> case (expr us) of + (result, us') -> unUSM (cont result) us') lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b lazyThenUs (USM expr) cont @@ -144,70 +157,54 @@ 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)) -withUs :: (UniqSupply -> (a, UniqSupply)) -> UniqSM a -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)) + (us1,us2) -> (uniqFromSupply us1, us2)) getUniquesUs :: UniqSM [Unique] getUniquesUs = USM (\us -> case splitUniqSupply us of - (us1,us2) -> (uniqsFromSupply us1, us2)) -\end{code} + (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}