{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
module GHC.Types.Unique.Supply (
UniqSupply,
uniqFromSupply, uniqsFromSupply,
takeUniqFromSupply, uniqFromMask,
mkSplitUniqSupply,
splitUniqSupply, listSplitUniqSupply,
UniqSM, MonadUnique(..),
initUs, initUs_,
initUniqSupply
) where
import GHC.Prelude
import GHC.Types.Unique
import GHC.Utils.Panic.Plain
import GHC.IO
import GHC.Utils.Monad
import Control.Monad
import Data.Char
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )
#endif
import Foreign.Storable
#include "Unique.h"
data UniqSupply
= MkSplitUniqSupply {-# UNPACK #-} !Int
UniqSupply UniqSupply
mkSplitUniqSupply :: Char -> IO UniqSupply
mkSplitUniqSupply :: Char -> IO UniqSupply
mkSplitUniqSupply Char
c
= forall a. IO a -> IO a
unsafeDupableInterleaveIO (forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply)
where
!mask :: Int
mask = Char -> Int
ord Char
c forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
uNIQUE_BITS
mk_supply :: State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply State# RealWorld
s0 =
case forall d. State# d -> State# d
noDuplicate# State# RealWorld
s0 of { State# RealWorld
s1 ->
case forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO IO Int
genSym State# RealWorld
s1 of { (# State# RealWorld
s2, Int
u #) ->
case forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (forall a. IO a -> IO a
unsafeDupableInterleaveIO (forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply)) State# RealWorld
s2 of { (# State# RealWorld
s3, UniqSupply
x #) ->
case forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (forall a. IO a -> IO a
unsafeDupableInterleaveIO (forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply)) State# RealWorld
s3 of { (# State# RealWorld
s4, UniqSupply
y #) ->
(# State# RealWorld
s4, Int -> UniqSupply -> UniqSupply -> UniqSupply
MkSplitUniqSupply (Int
mask forall a. Bits a => a -> a -> a
.|. Int
u) UniqSupply
x UniqSupply
y #)
}}}}
#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Int
#else
genSym :: IO Int
genSym :: IO Int
genSym = do
let !mask :: Int
mask = (Int
1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
uNIQUE_BITS) forall a. Num a => a -> a -> a
- Int
1
let !(Ptr Addr#
counter) = Ptr Word
ghc_unique_counter
let !(Ptr Addr#
inc_ptr) = Ptr Int
ghc_unique_inc
Int
u <- forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 -> case forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #)
readWordOffAddr# Addr#
inc_ptr Int#
0# State# RealWorld
s0 of
(# State# RealWorld
s1, Word#
inc #) -> case forall d. Addr# -> Word# -> State# d -> (# State# d, Word# #)
fetchAddWordAddr# Addr#
counter Word#
inc State# RealWorld
s1 of
(# State# RealWorld
s2, Word#
val #) ->
let !u :: Int
u = Int# -> Int
I# (Word# -> Int#
word2Int# (Word#
val Word# -> Word# -> Word#
`plusWord#` Word#
inc)) forall a. Bits a => a -> a -> a
.&. Int
mask
in (# State# RealWorld
s2, Int
u #)
#if defined(DEBUG)
massert (u /= mask)
#endif
forall (m :: * -> *) a. Monad m => a -> m a
return Int
u
#endif
foreign import ccall unsafe "&ghc_unique_counter" ghc_unique_counter :: Ptr Word
foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int
initUniqSupply :: Word -> Int -> IO ()
initUniqSupply :: Word -> Int -> IO ()
initUniqSupply Word
counter Int
inc = do
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word
ghc_unique_counter Word
counter
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Int
ghc_unique_inc Int
inc
uniqFromMask :: Char -> IO Unique
uniqFromMask :: Char -> IO Unique
uniqFromMask !Char
mask
= do { Int
uqNum <- IO Int
genSym
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Char -> Int -> Unique
mkUnique Char
mask Int
uqNum }
{-# NOINLINE uniqFromMask #-}
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
uniqFromSupply :: UniqSupply -> Unique
uniqsFromSupply :: UniqSupply -> [Unique]
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (MkSplitUniqSupply Int
_ UniqSupply
s1 UniqSupply
s2) = (UniqSupply
s1, UniqSupply
s2)
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
listSplitUniqSupply (MkSplitUniqSupply Int
_ UniqSupply
s1 UniqSupply
s2) = UniqSupply
s1 forall a. a -> [a] -> [a]
: UniqSupply -> [UniqSupply]
listSplitUniqSupply UniqSupply
s2
uniqFromSupply :: UniqSupply -> Unique
uniqFromSupply (MkSplitUniqSupply Int
n UniqSupply
_ UniqSupply
_) = Int -> Unique
mkUniqueGrimily Int
n
uniqsFromSupply :: UniqSupply -> [Unique]
uniqsFromSupply (MkSplitUniqSupply Int
n UniqSupply
_ UniqSupply
s2) = Int -> Unique
mkUniqueGrimily Int
n forall a. a -> [a] -> [a]
: UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
s2
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (MkSplitUniqSupply Int
n UniqSupply
s1 UniqSupply
_) = (Int -> Unique
mkUniqueGrimily Int
n, UniqSupply
s1)
type UniqResult result = (# result, UniqSupply #)
pattern UniqResult :: a -> b -> (# a, b #)
pattern $bUniqResult :: forall a b. a -> b -> (# a, b #)
$mUniqResult :: forall {r} {a} {b}.
(# a, b #) -> (a -> b -> r) -> ((# #) -> r) -> r
UniqResult x y = (# x, y #)
{-# COMPLETE UniqResult #-}
newtype UniqSM result = USM { forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM :: UniqSupply -> UniqResult result }
instance Functor UniqSM where
fmap :: forall a b. (a -> b) -> UniqSM a -> UniqSM b
fmap a -> b
f (USM UniqSupply -> UniqResult a
m) = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM forall a b. (a -> b) -> a -> b
$ \UniqSupply
us ->
case UniqSupply -> UniqResult a
m UniqSupply
us of
(# a
r, UniqSupply
us' #) -> forall a b. a -> b -> (# a, b #)
UniqResult (a -> b
f a
r) UniqSupply
us'
mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM :: forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM UniqSupply -> UniqResult a
f = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
USM (oneShot :: forall a b. (a -> b) -> a -> b
oneShot UniqSupply -> UniqResult a
f)
{-# INLINE mkUniqSM #-}
instance Monad UniqSM where
>>= :: forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
(>>=) = forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs
>> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
instance Applicative UniqSM where
pure :: forall a. a -> UniqSM a
pure = forall a. a -> UniqSM a
returnUs
(USM UniqSupply -> UniqResult (a -> b)
f) <*> :: forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
<*> (USM UniqSupply -> UniqResult a
x) = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM forall a b. (a -> b) -> a -> b
$ \UniqSupply
us0 -> case UniqSupply -> UniqResult (a -> b)
f UniqSupply
us0 of
UniqResult a -> b
ff UniqSupply
us1 -> case UniqSupply -> UniqResult a
x UniqSupply
us1 of
UniqResult a
xx UniqSupply
us2 -> forall a b. a -> b -> (# a, b #)
UniqResult (a -> b
ff a
xx) UniqSupply
us2
*> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
(*>) = forall a b. UniqSM a -> UniqSM b -> UniqSM b
thenUs_
instance MonadFail UniqSM where
fail :: forall a. String -> UniqSM a
fail = forall a. HasCallStack => String -> a
panic
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs :: forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
init_us UniqSM a
m = case forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM UniqSM a
m UniqSupply
init_us of { UniqResult a
r UniqSupply
us -> (a
r, UniqSupply
us) }
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ :: forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
init_us UniqSM a
m = case forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM UniqSM a
m UniqSupply
init_us of { UniqResult a
r UniqSupply
_ -> a
r }
{-# INLINE thenUs #-}
{-# INLINE returnUs #-}
{-# INLINE splitUniqSupply #-}
liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM :: forall a. UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (USM UniqSupply -> UniqResult a
m) UniqSupply
us0 = case UniqSupply -> UniqResult a
m UniqSupply
us0 of UniqResult a
a UniqSupply
us1 -> (a
a, UniqSupply
us1)
instance MonadFix UniqSM where
mfix :: forall a. (a -> UniqSM a) -> UniqSM a
mfix a -> UniqSM a
m = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> let (a
r,UniqSupply
us1) = forall a. UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (a -> UniqSM a
m a
r) UniqSupply
us0 in forall a b. a -> b -> (# a, b #)
UniqResult a
r UniqSupply
us1)
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs :: forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs (USM UniqSupply -> UniqResult a
expr) a -> UniqSM b
cont
= forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case (UniqSupply -> UniqResult a
expr UniqSupply
us0) of
UniqResult a
result UniqSupply
us1 -> forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM (a -> UniqSM b
cont a
result) UniqSupply
us1)
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
thenUs_ :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
thenUs_ (USM UniqSupply -> UniqResult a
expr) (USM UniqSupply -> UniqResult b
cont)
= forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case (UniqSupply -> UniqResult a
expr UniqSupply
us0) of { UniqResult a
_ UniqSupply
us1 -> UniqSupply -> UniqResult b
cont UniqSupply
us1 })
returnUs :: a -> UniqSM a
returnUs :: forall a. a -> UniqSM a
returnUs a
result = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us -> forall a b. a -> b -> (# a, b #)
UniqResult a
result UniqSupply
us)
getUs :: UniqSM UniqSupply
getUs :: UniqSM UniqSupply
getUs = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us0 of (UniqSupply
us1,UniqSupply
us2) -> forall a b. a -> b -> (# a, b #)
UniqResult UniqSupply
us1 UniqSupply
us2)
class Monad m => MonadUnique m where
getUniqueSupplyM :: m UniqSupply
getUniqueM :: m Unique
getUniquesM :: m [Unique]
getUniqueM = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UniqSupply -> Unique
uniqFromSupply forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
getUniquesM = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UniqSupply -> [Unique]
uniqsFromSupply forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
instance MonadUnique UniqSM where
getUniqueSupplyM :: UniqSM UniqSupply
getUniqueSupplyM = UniqSM UniqSupply
getUs
getUniqueM :: UniqSM Unique
getUniqueM = UniqSM Unique
getUniqueUs
getUniquesM :: UniqSM [Unique]
getUniquesM = UniqSM [Unique]
getUniquesUs
getUniqueUs :: UniqSM Unique
getUniqueUs :: UniqSM Unique
getUniqueUs = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us0 of
(Unique
u,UniqSupply
us1) -> forall a b. a -> b -> (# a, b #)
UniqResult Unique
u UniqSupply
us1)
getUniquesUs :: UniqSM [Unique]
getUniquesUs :: UniqSM [Unique]
getUniquesUs = forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us0 of
(UniqSupply
us1,UniqSupply
us2) -> forall a b. a -> b -> (# a, b #)
UniqResult (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us1) UniqSupply
us2)