    {-# LANGUAGE MagicHash, UnboxedTuples, CPP #-}
    #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
    {-# LANGUAGE Trustworthy #-}
    #endif
    {-# OPTIONS_GHC -fno-full-laziness #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Concurrent.Supply
    -- Copyright   :  (C) 2011-2013 Edward Kmett
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  provisional
    -- Portability :  portable
    --
    -- A fast unique identifier supply with local pooling and replay
    -- support.
    --
    -- One often has a desire to generate a bunch of integer identifiers within
    -- a single process that are unique within that process. You could use
    -- UUIDs, but they can be expensive to generate; you don't want to have
    -- your threads contending for a single external counter if the identifier
    -- is not going to be used outside the process.
    --
    -- @concurrent-supply@ builds a tree-like structure which can be split; you
    -- can make smaller unique supplies and then you allocate from your supplies
    -- locally. Internally it pulls from a unique supply one block at a time as
    -- you walk into parts of the tree that haven't been explored.
    --
    ----------------------------------------------------------------------------
    module Control.Concurrent.Supply
      ( Supply
      -- * Variables
      , newSupply
      , freshId
      , splitSupply
      -- * Unboxed API
      , 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 a b. (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
    extract :: forall a. Stream a -> a
    extract (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 #-}

    -- Minimum size to be worth splitting a supply rather than just CAS'ing twice to avoid multiple subsequent biased splits
    minSplitSupplySize :: Int
    minSplitSupplySize :: Int
    minSplitSupplySize = Int
    32 -- based on sqrt blockSize
    {-# 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)
    forall a b. a -> b -> b
    `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 a. a -> IO a
    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# #-}

    -- | A user managed globally unique variable supply.
    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
    $c== :: Supply -> Supply -> Bool
    == :: Supply -> Supply -> Bool
    $c/= :: Supply -> Supply -> Bool
    /= :: 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
    $ccompare :: Supply -> Supply -> Ordering
    compare :: Supply -> Supply -> Ordering
    $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
    >= :: Supply -> Supply -> Bool
    $cmax :: Supply -> Supply -> Supply
    max :: Supply -> Supply -> Supply
    $cmin :: Supply -> Supply -> Supply
    min :: Supply -> Supply -> Supply
    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
    $cshowsPrec :: Int -> Supply -> ShowS
    showsPrec :: Int -> Supply -> ShowS
    $cshow :: Supply -> String
    show :: Supply -> String
    $cshowList :: [Supply] -> ShowS
    showList :: [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 #-}

    -- | Grab a new supply. Any two supplies obtained with newSupply are guaranteed to return
    -- disjoint sets of identifiers. Replaying the same sequence of operations on the same
    -- Supply will yield the same results.
    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 #-}

    -- | Obtain a fresh Id from a Supply.
    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 #-}

    -- | Split a supply into two supplies that will return disjoint identifiers
    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 #-}

    -- | An unboxed version of freshId
    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# #-}

    -- | An unboxed version of splitSupply
    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# #-}