{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
module GHC.Types.Unique.Supply (
UniqSupply,
uniqFromSupply, uniqsFromSupply,
takeUniqFromSupply, uniqFromTag,
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.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
import Foreign.Storable
import GHC.Utils.Monad.State.Strict as Strict
#include "MachDeps.h"
#if WORD_SIZE_IN_BITS != 64
#define NO_FETCH_ADD
#endif
#if defined(NO_FETCH_ADD)
import GHC.Exts ( atomicCasWord64Addr#, eqWord64#, readWord64OffAddr# )
#else
import GHC.Exts( fetchAddWordAddr#, word64ToWord# )
#endif
import GHC.Exts ( Addr#, State#, Word64#, RealWorld )
import GHC.Int ( Int(..) )
import GHC.Word( Word64(..) )
import GHC.Exts( plusWord64#, int2Word#, wordToWord64# )
data UniqSupply
= MkSplitUniqSupply {-# UNPACK #-} !Word64
UniqSupply UniqSupply
mkSplitUniqSupply :: Char -> IO UniqSupply
mkSplitUniqSupply :: Char -> IO UniqSupply
mkSplitUniqSupply Char
c
= IO UniqSupply -> IO UniqSupply
forall a. IO a -> IO a
unsafeDupableInterleaveIO ((State# RealWorld -> (# State# RealWorld, UniqSupply #))
-> IO UniqSupply
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply)
where
!tag :: Word64
tag = Char -> Word64
mkTag Char
c
mk_supply :: State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply State# RealWorld
s0 =
case State# RealWorld -> State# RealWorld
forall d. State# d -> State# d
noDuplicate# State# RealWorld
s0 of { State# RealWorld
s1 ->
case IO Word64 -> State# RealWorld -> (# State# RealWorld, Word64 #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO IO Word64
genSym State# RealWorld
s1 of { (# State# RealWorld
s2, Word64
u #) ->
case IO UniqSupply
-> State# RealWorld -> (# State# RealWorld, UniqSupply #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO UniqSupply -> IO UniqSupply
forall a. IO a -> IO a
unsafeDupableInterleaveIO ((State# RealWorld -> (# State# RealWorld, UniqSupply #))
-> IO UniqSupply
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 IO UniqSupply
-> State# RealWorld -> (# State# RealWorld, UniqSupply #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO UniqSupply -> IO UniqSupply
forall a. IO a -> IO a
unsafeDupableInterleaveIO ((State# RealWorld -> (# State# RealWorld, UniqSupply #))
-> IO UniqSupply
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, Word64 -> UniqSupply -> UniqSupply -> UniqSupply
MkSplitUniqSupply (Word64
tag Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
u) UniqSupply
x UniqSupply
y #)
}}}}
#if defined(NO_FETCH_ADD)
fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
-> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# = go
where
go ptr inc s0 =
case readWord64OffAddr# ptr 0# s0 of
(# s1, n0 #) ->
case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of
(# s2, res #)
| 1# <- res `eqWord64#` n0 -> (# s2, n0 #)
| otherwise -> go ptr inc s2
#else
fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
-> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# :: Addr#
-> Word64# -> State# RealWorld -> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# Addr#
addr Word64#
inc State# RealWorld
s0 =
case Addr# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
forall d. Addr# -> Word# -> State# d -> (# State# d, Word# #)
fetchAddWordAddr# Addr#
addr (Word64# -> Word#
word64ToWord# Word64#
inc) State# RealWorld
s0 of
(# State# RealWorld
s1, Word#
res #) -> (# State# RealWorld
s1, Word# -> Word64#
wordToWord64# Word#
res #)
#endif
genSym :: IO Word64
genSym :: IO Word64
genSym = do
let !mask :: Word64
mask = (Word64
1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
uNIQUE_BITS) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1
let !(Ptr Addr#
counter) = Ptr Word64
ghc_unique_counter64
I# inc# <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
ghc_unique_inc
let !inc = Word# -> Word64#
wordToWord64# (Int# -> Word#
int2Word# Int#
inc#)
u <- IO $ \State# RealWorld
s1 -> case Addr#
-> Word64# -> State# RealWorld -> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# Addr#
counter Word64#
inc State# RealWorld
s1 of
(# State# RealWorld
s2, Word64#
val #) ->
let !u :: Word64
u = Word64# -> Word64
W64# (Word64#
val Word64# -> Word64# -> Word64#
`plusWord64#` Word64#
inc) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
mask
in (# State# RealWorld
s2, Word64
u #)
#if defined(DEBUG)
massert (u /= mask)
#endif
return u
foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64
foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int
initUniqSupply :: Word64 -> Int -> IO ()
initUniqSupply :: Word64 -> Int -> IO ()
initUniqSupply Word64
counter Int
inc = do
Ptr Word64 -> Word64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word64
ghc_unique_counter64 Word64
counter
Ptr Int -> Int -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Int
ghc_unique_inc Int
inc
uniqFromTag :: Char -> IO Unique
uniqFromTag :: Char -> IO Unique
uniqFromTag !Char
tag
= do { uqNum <- IO Word64
genSym
; return $! mkUnique tag uqNum }
{-# NOINLINE uniqFromTag #-}
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
uniqFromSupply :: UniqSupply -> Unique
uniqsFromSupply :: UniqSupply -> [Unique]
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (MkSplitUniqSupply Word64
_ UniqSupply
s1 UniqSupply
s2) = (UniqSupply
s1, UniqSupply
s2)
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
listSplitUniqSupply (MkSplitUniqSupply Word64
_ UniqSupply
s1 UniqSupply
s2) = UniqSupply
s1 UniqSupply -> [UniqSupply] -> [UniqSupply]
forall a. a -> [a] -> [a]
: UniqSupply -> [UniqSupply]
listSplitUniqSupply UniqSupply
s2
uniqFromSupply :: UniqSupply -> Unique
uniqFromSupply (MkSplitUniqSupply Word64
n UniqSupply
_ UniqSupply
_) = Word64 -> Unique
mkUniqueGrimily Word64
n
uniqsFromSupply :: UniqSupply -> [Unique]
uniqsFromSupply (MkSplitUniqSupply Word64
n UniqSupply
_ UniqSupply
s2) = Word64 -> Unique
mkUniqueGrimily Word64
n Unique -> [Unique] -> [Unique]
forall a. a -> [a] -> [a]
: UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
s2
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (MkSplitUniqSupply Word64
n UniqSupply
s1 UniqSupply
_) = (Word64 -> Unique
mkUniqueGrimily Word64
n, UniqSupply
s1)
{-# INLINE splitUniqSupply #-}
type UniqResult result = (# result, UniqSupply #)
pattern UniqResult :: a -> b -> (# a, b #)
pattern $mUniqResult :: forall {r} {a} {b}.
(# a, b #) -> (a -> b -> r) -> ((# #) -> r) -> r
$bUniqResult :: forall a b. a -> b -> (# a, b #)
UniqResult x y = (# x, y #)
{-# COMPLETE UniqResult #-}
newtype UniqSM result = USM { forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM :: UniqSupply -> UniqResult result }
deriving ((forall a b. (a -> b) -> UniqSM a -> UniqSM b)
-> (forall a b. a -> UniqSM b -> UniqSM a) -> Functor UniqSM
forall a b. a -> UniqSM b -> UniqSM a
forall a b. (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> UniqSM a -> UniqSM b
fmap :: forall a b. (a -> b) -> UniqSM a -> UniqSM b
$c<$ :: forall a b. a -> UniqSM b -> UniqSM a
<$ :: forall a b. a -> UniqSM b -> UniqSM a
Functor, Functor UniqSM
Functor UniqSM =>
(forall a. a -> UniqSM a)
-> (forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b)
-> (forall a b c.
(a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c)
-> (forall a b. UniqSM a -> UniqSM b -> UniqSM b)
-> (forall a b. UniqSM a -> UniqSM b -> UniqSM a)
-> Applicative UniqSM
forall a. a -> UniqSM a
forall a b. UniqSM a -> UniqSM b -> UniqSM a
forall a b. UniqSM a -> UniqSM b -> UniqSM b
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall a b c. (a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> UniqSM a
pure :: forall a. a -> UniqSM a
$c<*> :: forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
<*> :: forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
$cliftA2 :: forall a b c. (a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c
liftA2 :: forall a b c. (a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c
$c*> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
*> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
$c<* :: forall a b. UniqSM a -> UniqSM b -> UniqSM a
<* :: forall a b. UniqSM a -> UniqSM b -> UniqSM a
Applicative, Applicative UniqSM
Applicative UniqSM =>
(forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b)
-> (forall a b. UniqSM a -> UniqSM b -> UniqSM b)
-> (forall a. a -> UniqSM a)
-> Monad UniqSM
forall a. a -> UniqSM a
forall a b. UniqSM a -> UniqSM b -> UniqSM b
forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
>>= :: forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
$c>> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
>> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
$creturn :: forall a. a -> UniqSM a
return :: forall a. a -> UniqSM a
Monad) via (Strict.State UniqSupply)
mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM :: forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM UniqSupply -> UniqResult a
f = (UniqSupply -> UniqResult a) -> UniqSM a
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
USM ((UniqSupply -> UniqResult a) -> UniqSupply -> UniqResult a
forall a b. (a -> b) -> a -> b
oneShot UniqSupply -> UniqResult a
f)
{-# INLINE mkUniqSM #-}
instance MonadFail UniqSM where
fail :: forall a. String -> UniqSM a
fail = String -> UniqSM a
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 UniqSM a -> UniqSupply -> UniqResult a
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 UniqSM a -> UniqSupply -> UniqResult a
forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM UniqSM a
m UniqSupply
init_us of { UniqResult a
r UniqSupply
_ -> a
r }
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 = (UniqSupply -> UniqResult a) -> UniqSM a
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> let (a
r,UniqSupply
us1) = UniqSM a -> UniqSupply -> (a, UniqSupply)
forall a. UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (a -> UniqSM a
m a
r) UniqSupply
us0 in a -> UniqSupply -> UniqResult a
forall a b. a -> b -> (# a, b #)
UniqResult a
r UniqSupply
us1)
getUs :: UniqSM UniqSupply
getUs :: UniqSM UniqSupply
getUs = (UniqSupply -> UniqResult UniqSupply) -> UniqSM UniqSupply
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us0 of (UniqSupply
us1,UniqSupply
us2) -> UniqSupply -> UniqSupply -> UniqResult UniqSupply
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 = (UniqSupply -> Unique) -> m UniqSupply -> m Unique
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UniqSupply -> Unique
uniqFromSupply m UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
getUniquesM = (UniqSupply -> [Unique]) -> m UniqSupply -> m [Unique]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UniqSupply -> [Unique]
uniqsFromSupply m UniqSupply
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 = (UniqSupply -> UniqResult Unique) -> UniqSM Unique
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us0 of
(Unique
u,UniqSupply
us1) -> Unique -> UniqSupply -> UniqResult Unique
forall a b. a -> b -> (# a, b #)
UniqResult Unique
u UniqSupply
us1)
getUniquesUs :: UniqSM [Unique]
getUniquesUs :: UniqSM [Unique]
getUniquesUs = (UniqSupply -> UniqResult [Unique]) -> UniqSM [Unique]
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us0 of
(UniqSupply
us1,UniqSupply
us2) -> [Unique] -> UniqSupply -> UniqResult [Unique]
forall a b. a -> b -> (# a, b #)
UniqResult (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us1) UniqSupply
us2)