{-# LANGUAGE MagicHash, UnboxedTuples, CPP, PatternSynonyms #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
{-# OPTIONS_GHC -fno-full-laziness #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Clash.Util.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 Clash.Util.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 Clash.Unique (Unique, Unique#, pattern Unique#)

infixr 5 :-
data Stream a = a :- Stream a

instance Functor Stream where
  fmap :: (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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Stream a
as

extract :: Stream a -> a
extract :: 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 Unique !(Stream Block)

instance Eq Block where
  Block Unique
a (Block Unique
b Stream Block
_ :- Stream Block
_) == :: Block -> Block -> Bool
== Block Unique
c (Block Unique
d Stream Block
_ :- Stream Block
_) = Unique
a Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
c Bool -> Bool -> Bool
&& Unique
b Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
d

instance Ord Block where
  Block Unique
a (Block Unique
b Stream Block
_ :- Stream Block
_) compare :: Block -> Block -> Ordering
`compare` Block Unique
c (Block Unique
d Stream Block
_ :- Stream Block
_) = Unique -> Unique -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Unique
a Unique
c Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Unique -> Unique -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Unique
b Unique
d

instance Show Block where
  showsPrec :: Unique -> Block -> ShowS
showsPrec Unique
d (Block Unique
a (Block Unique
b Stream Block
_ :- Stream Block
_)) = Bool -> ShowS -> ShowS
showParen (Unique
d Unique -> Unique -> Bool
forall a. Ord a => a -> a -> Bool
>= Unique
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
. Unique -> Unique -> ShowS
forall a. Show a => Unique -> a -> ShowS
showsPrec Unique
10 Unique
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
. Unique -> Unique -> ShowS
forall a. Show a => Unique -> a -> ShowS
showsPrec Unique
10 Unique
b ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ... :- ...)"

instance Hashable Block where
  hashWithSalt :: Unique -> Block -> Unique
hashWithSalt Unique
s (Block Unique
a (Block Unique
b Stream Block
_ :- Stream Block
_)) = Unique
s Unique -> Unique -> Unique
forall a. Hashable a => Unique -> a -> Unique
`hashWithSalt` Unique
a Unique -> Unique -> Unique
forall a. Hashable a => Unique -> a -> Unique
`hashWithSalt` Unique
b

blockSize :: Unique
blockSize :: Unique
blockSize = Unique
1024
{-# INLINE blockSize #-}

-- Minimum size to be worth splitting a supply rather than just CAS'ing twice to avoid multiple subsequent biased splits
minSplitSupplySize :: Unique
minSplitSupplySize :: Unique
minSplitSupplySize = Unique
32 -- based on sqrt blockSize
{-# INLINE minSplitSupplySize #-}

blockCounter :: IORef Unique
blockCounter :: IORef Unique
blockCounter = IO (IORef Unique) -> IORef Unique
forall a. IO a -> a
unsafePerformIO (Unique -> IO (IORef Unique)
forall a. a -> IO (IORef a)
newIORef Unique
0)
{-# NOINLINE blockCounter #-}

modifyBlock :: a -> IO Unique
modifyBlock :: a -> IO Unique
modifyBlock a
_ = IORef Unique -> (Unique -> (Unique, Unique)) -> IO Unique
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Unique
blockCounter ((Unique -> (Unique, Unique)) -> IO Unique)
-> (Unique -> (Unique, Unique)) -> IO Unique
forall a b. (a -> b) -> a -> b
$ \ Unique
i -> let i' :: Unique
i' = Unique
i Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
+ Unique
blockSize in Unique
i' Unique -> (Unique, Unique) -> (Unique, Unique)
`seq` (Unique
i', Unique
i)
{-# NOINLINE modifyBlock #-}

gen :: a -> Block
gen :: a -> Block
gen a
x = Unique -> Stream Block -> Block
Block (IO Unique -> Unique
forall a. IO a -> a
unsafeDupablePerformIO (a -> IO Unique
forall a. a -> IO Unique
modifyBlock a
x)) (() -> Block
forall a. a -> Block
gen (() -> Block) -> Stream () -> Stream Block
forall (f :: Type -> Type) 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 :: Type -> Type) 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 Unique
i (Block
x :- Stream Block
xs)) = (# Block
x, Unique -> Stream Block -> Block
Block Unique
i Stream Block
xs #)
{-# INLINE splitBlock# #-}

-- | A user managed globally unique variable supply.
data Supply = Supply {-# UNPACK #-} !Unique {-# UNPACK #-} !Unique 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
$cp1Ord :: Eq Supply
Ord,Unique -> Supply -> ShowS
[Supply] -> ShowS
Supply -> String
(Unique -> Supply -> ShowS)
-> (Supply -> String) -> ([Supply] -> ShowS) -> Show Supply
forall a.
(Unique -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Supply] -> ShowS
$cshowList :: [Supply] -> ShowS
show :: Supply -> String
$cshow :: Supply -> String
showsPrec :: Unique -> Supply -> ShowS
$cshowsPrec :: Unique -> Supply -> ShowS
Show)

instance Hashable Supply where
  hashWithSalt :: Unique -> Supply -> Unique
hashWithSalt Unique
s (Supply Unique
i Unique
j Block
b) = Unique
s Unique -> Unique -> Unique
forall a. Hashable a => Unique -> a -> Unique
`hashWithSalt` Unique
i Unique -> Unique -> Unique
forall a. Hashable a => Unique -> a -> Unique
`hashWithSalt` Unique
j Unique -> Block -> Unique
forall a. Hashable a => Unique -> a -> Unique
`hashWithSalt` Block
b

blockSupply :: Block -> Supply
blockSupply :: Block -> Supply
blockSupply (Block Unique
i Stream Block
bs) = Unique -> Unique -> Block -> Supply
Supply Unique
i (Unique
i Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
+ Unique
blockSize Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
- Unique
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 :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Block
newBlock
{-# INLINE newSupply #-}

-- | Obtain a fresh Id from a Supply.
freshId :: Supply -> (Unique, Supply)
freshId :: Supply -> (Unique, Supply)
freshId Supply
s = case Supply -> (# Unique#, Supply #)
freshId# Supply
s of
  (# Unique#
i, Supply
s' #) -> (Unique# -> Unique
Unique# Unique#
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 -> (# Unique#, Supply #)
freshId# :: Supply -> (# Unique#, Supply #)
freshId# (Supply i :: Unique
i@(Unique# Unique#
i#) Unique
j Block
b)
  | Unique
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
/= Unique
j = (# Unique#
i#, Unique -> Unique -> Block -> Supply
Supply (Unique
i Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
+ Unique
1) Unique
j Block
b #)
  | Bool
otherwise = (# Unique#
i#, Block -> Supply
blockSupply Block
b #)
{-# INLINE freshId# #-}

-- | An unboxed version of splitSupply
splitSupply# :: Supply -> (# Supply, Supply #)
splitSupply# :: Supply -> (# Supply, Supply #)
splitSupply# (Supply Unique
i Unique
k Block
b) = case Block -> (# Block, Block #)
splitBlock# Block
b of
    (# Block
bl, Block
br #)
      | Unique
k Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
- Unique
i Unique -> Unique -> Bool
forall a. Ord a => a -> a -> Bool
>= Unique
minSplitSupplySize
      , Unique
j <- Unique
i Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
+ Unique -> Unique -> Unique
forall a. Integral a => a -> a -> a
div (Unique
k Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
- Unique
i) Unique
2 ->
        (# Unique -> Unique -> Block -> Supply
Supply Unique
i Unique
j Block
bl, Unique -> Unique -> Block -> Supply
Supply (Unique
j Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
+ Unique
1) Unique
k Block
br #)
      | Block Unique
x (Block
l :- Block
r :- Stream Block
_) <- Block
bl
      , Unique
y <- Unique
x Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
+ Unique -> Unique -> Unique
forall a. Integral a => a -> a -> a
div Unique
blockSize Unique
2
      , Unique
z <- Unique
x Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
+ Unique
blockSize Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
- Unique
1 ->
        (# Unique -> Unique -> Block -> Supply
Supply Unique
x (Unique
y Unique -> Unique -> Unique
forall a. Num a => a -> a -> a
- Unique
1) Block
l, Unique -> Unique -> Block -> Supply
Supply Unique
y Unique
z Block
r #)
{-# INLINE splitSupply# #-}