{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
{-# OPTIONS_GHC -fno-full-laziness #-}
module Control.Concurrent.Supply
( Supply
, newSupply
, freshId
, splitSupply
, freshId#
, splitSupply#
) where
import Data.Hashable
import Data.IORef
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710
import Data.Functor ((<$>))
import Data.Monoid
#endif
import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)
import GHC.Types (Int(..))
import GHC.Prim (Int#)
infixr 5 :-
data Stream a = a :- Stream a
instance Functor Stream where
fmap :: forall a b. (a -> b) -> Stream a -> Stream b
fmap a -> b
f (a
a :- Stream a
as) = a -> b
f a
a b -> Stream b -> Stream b
forall a. a -> Stream a -> Stream a
:- (a -> b) -> Stream a -> Stream b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Stream a
as
extract :: Stream a -> a
(a
a :- Stream a
_) = a
a
units :: Stream ()
units :: Stream ()
units = () () -> Stream () -> Stream ()
forall a. a -> Stream a -> Stream a
:- Stream ()
units
{-# NOINLINE units #-}
data Block = Block Int !(Stream Block)
instance Eq Block where
Block Int
a (Block Int
b Stream Block
_ :- Stream Block
_) == :: Block -> Block -> Bool
== Block Int
c (Block Int
d Stream Block
_ :- Stream Block
_) = Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c Bool -> Bool -> Bool
&& Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
d
instance Ord Block where
Block Int
a (Block Int
b Stream Block
_ :- Stream Block
_) compare :: Block -> Block -> Ordering
`compare` Block Int
c (Block Int
d Stream Block
_ :- Stream Block
_) = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
c Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
b Int
d
instance Show Block where
showsPrec :: Int -> Block -> ShowS
showsPrec Int
d (Block Int
a (Block Int
b Stream Block
_ :- Stream Block
_)) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString String
"Block " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
10 Int
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" (Block " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
10 Int
b ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ... :- ...)"
instance Hashable Block where
hashWithSalt :: Int -> Block -> Int
hashWithSalt Int
s (Block Int
a (Block Int
b Stream Block
_ :- Stream Block
_)) = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int
a Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int
b
blockSize :: Int
blockSize :: Int
blockSize = Int
1024
{-# INLINE blockSize #-}
minSplitSupplySize :: Int
minSplitSupplySize :: Int
minSplitSupplySize = Int
32
{-# INLINE minSplitSupplySize #-}
blockCounter :: IORef Int
blockCounter :: IORef Int
blockCounter = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0)
{-# NOINLINE blockCounter #-}
modifyBlock :: a -> IO Int
modifyBlock :: forall a. a -> IO Int
modifyBlock a
_ = IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Int
blockCounter ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \ Int
i -> let i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
blockSize in Int
i' Int -> (Int, Int) -> (Int, Int)
`seq` (Int
i', Int
i)
{-# NOINLINE modifyBlock #-}
gen :: a -> Block
gen :: forall a. a -> Block
gen a
x = Int -> Stream Block -> Block
Block (IO Int -> Int
forall a. IO a -> a
unsafeDupablePerformIO (a -> IO Int
forall a. a -> IO Int
modifyBlock a
x)) (() -> Block
forall a. a -> Block
gen (() -> Block) -> Stream () -> Stream Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream ()
units)
{-# NOINLINE gen #-}
newBlock :: IO Block
newBlock :: IO Block
newBlock = Block -> IO Block
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> IO Block) -> Block -> IO Block
forall a b. (a -> b) -> a -> b
$! () -> Block
forall a. a -> Block
gen ()
{-# NOINLINE newBlock #-}
splitBlock# :: Block -> (# Block, Block #)
splitBlock# :: Block -> (# Block, Block #)
splitBlock# (Block Int
i (Block
x :- Stream Block
xs)) = (# Block
x, Int -> Stream Block -> Block
Block Int
i Stream Block
xs #)
{-# INLINE splitBlock# #-}
data Supply = Supply {-# UNPACK #-} !Int {-# UNPACK #-} !Int Block
deriving (Supply -> Supply -> Bool
(Supply -> Supply -> Bool)
-> (Supply -> Supply -> Bool) -> Eq Supply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Supply -> Supply -> Bool
$c/= :: Supply -> Supply -> Bool
== :: Supply -> Supply -> Bool
$c== :: Supply -> Supply -> Bool
Eq,Eq Supply
Eq Supply
-> (Supply -> Supply -> Ordering)
-> (Supply -> Supply -> Bool)
-> (Supply -> Supply -> Bool)
-> (Supply -> Supply -> Bool)
-> (Supply -> Supply -> Bool)
-> (Supply -> Supply -> Supply)
-> (Supply -> Supply -> Supply)
-> Ord Supply
Supply -> Supply -> Bool
Supply -> Supply -> Ordering
Supply -> Supply -> Supply
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Supply -> Supply -> Supply
$cmin :: Supply -> Supply -> Supply
max :: Supply -> Supply -> Supply
$cmax :: Supply -> Supply -> Supply
>= :: Supply -> Supply -> Bool
$c>= :: Supply -> Supply -> Bool
> :: Supply -> Supply -> Bool
$c> :: Supply -> Supply -> Bool
<= :: Supply -> Supply -> Bool
$c<= :: Supply -> Supply -> Bool
< :: Supply -> Supply -> Bool
$c< :: Supply -> Supply -> Bool
compare :: Supply -> Supply -> Ordering
$ccompare :: Supply -> Supply -> Ordering
Ord,Int -> Supply -> ShowS
[Supply] -> ShowS
Supply -> String
(Int -> Supply -> ShowS)
-> (Supply -> String) -> ([Supply] -> ShowS) -> Show Supply
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Supply] -> ShowS
$cshowList :: [Supply] -> ShowS
show :: Supply -> String
$cshow :: Supply -> String
showsPrec :: Int -> Supply -> ShowS
$cshowsPrec :: Int -> Supply -> ShowS
Show)
instance Hashable Supply where
hashWithSalt :: Int -> Supply -> Int
hashWithSalt Int
s (Supply Int
i Int
j Block
b) = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int
i Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int
j Int -> Block -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Block
b
blockSupply :: Block -> Supply
blockSupply :: Block -> Supply
blockSupply (Block Int
i Stream Block
bs) = Int -> Int -> Block -> Supply
Supply Int
i (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
blockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Stream Block -> Block
forall a. Stream a -> a
extract Stream Block
bs)
{-# INLINE blockSupply #-}
newSupply :: IO Supply
newSupply :: IO Supply
newSupply = Block -> Supply
blockSupply (Block -> Supply) -> IO Block -> IO Supply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Block
newBlock
{-# INLINE newSupply #-}
freshId :: Supply -> (Int, Supply)
freshId :: Supply -> (Int, Supply)
freshId Supply
s = case Supply -> (# Int#, Supply #)
freshId# Supply
s of
(# Int#
i, Supply
s' #) -> (Int# -> Int
I# Int#
i, Supply
s')
{-# INLINE freshId #-}
splitSupply :: Supply -> (Supply, Supply)
splitSupply :: Supply -> (Supply, Supply)
splitSupply Supply
s = case Supply -> (# Supply, Supply #)
splitSupply# Supply
s of
(# Supply
l, Supply
r #) -> (Supply
l, Supply
r)
{-# INLINE splitSupply #-}
freshId# :: Supply -> (# Int#, Supply #)
freshId# :: Supply -> (# Int#, Supply #)
freshId# (Supply i :: Int
i@(I# Int#
i#) Int
j Block
b)
| Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j = (# Int#
i#, Int -> Int -> Block -> Supply
Supply (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
j Block
b #)
| Bool
otherwise = (# Int#
i#, Block -> Supply
blockSupply Block
b #)
{-# INLINE freshId# #-}
splitSupply# :: Supply -> (# Supply, Supply #)
splitSupply# :: Supply -> (# Supply, Supply #)
splitSupply# (Supply Int
i Int
k Block
b) = case Block -> (# Block, Block #)
splitBlock# Block
b of
(# Block
bl, Block
br #)
| Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minSplitSupplySize
, Int
j <- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int
2 ->
(# Int -> Int -> Block -> Supply
Supply Int
i Int
j Block
bl, Int -> Int -> Block -> Supply
Supply (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
k Block
br #)
| Block Int
x (Block
l :- Block
r :- Stream Block
_) <- Block
bl
, Int
y <- Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
blockSize Int
2
, Int
z <- Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
blockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 ->
(# Int -> Int -> Block -> Supply
Supply Int
x (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Block
l, Int -> Int -> Block -> Supply
Supply Int
y Int
z Block
r #)
{-# INLINE splitSupply# #-}