module ADP.Fusion.Core.SynVar.FillTyLvl where
import Control.DeepSeq
import Control.Monad.Primitive
import Control.Monad.ST
import Data.Proxy
import Data.Singletons.Prelude.Bool
import Data.Singletons.Prelude.Bool
import Data.Singletons.Prelude.List
import Data.Type.Equality
import Data.Vector.Fusion.Util (Id(..))
import GHC.Exts
import GHC.Generics
import GHC.TypeNats
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import qualified Data.Vector.Unboxed as VU
import System.CPUTime
import Text.Printf
import Data.PrimitiveArray
import ADP.Fusion.Core.SynVar.TableWrap
import ADP.Fusion.Core.SynVar.Array
fillTables
∷ forall bigOrder s ts
. ( bigOrder ~ BigOrderNats ts
, EachBigOrder bigOrder ts
, CountNumberOfCells 0 ts
)
⇒ ts
→ ST s (Mutated ts)
{-# Inline fillTables #-}
fillTables ts = do
startTime ← unsafeIOToPrim getCPUTime
ps ← eachBigOrder (Proxy ∷ Proxy bigOrder) ts
stopTime ← unsafeIOToPrim getCPUTime
let deltaTime = max 1 $ stopTime - startTime
return $! Mutated
{ mutatedTables = ts
, perfCounter = PerfCounter
{ picoSeconds = deltaTime
, seconds = 1e-12 * fromIntegral deltaTime
, numberOfCells = countNumberOfCells (Nothing ∷ Maybe (Proxy 0)) ts
}
, eachBigPerfCounter = ps
}
class EachBigOrder (boNats ∷ [Nat]) ts where
eachBigOrder ∷ Proxy boNats → ts → ST s [PerfCounter]
instance EachBigOrder '[] ts where
{-# Inline eachBigOrder #-}
eachBigOrder Proxy _ = return []
instance
( EachBigOrder ns ts
, ThisBigOrder n (IsThisBigOrder n ts) ts
, CountNumberOfCells n ts
) ⇒ EachBigOrder (n ': ns) ts where
{-# Inline eachBigOrder #-}
eachBigOrder Proxy ts = do
startTime ← unsafeIOToPrim getCPUTime
thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts
stopTime ← unsafeIOToPrim getCPUTime
let deltaTime = max 1 $ stopTime - startTime
ps ← eachBigOrder (Proxy ∷ Proxy ns) ts
let p = PerfCounter
{ picoSeconds = deltaTime
, seconds = 1e-12 * fromIntegral deltaTime
, numberOfCells = countNumberOfCells (Just (Proxy ∷ Proxy n)) ts
}
return $ p:ps
class ThisBigOrder (boNat ∷ Nat) (thisOrder ∷ Bool) ts where
thisBigOrder ∷ Proxy boNat → Proxy thisOrder → ts → ST s ()
getAllBounds ∷ Proxy boNat → Proxy thisOrder → ts → [()]
instance ThisBigOrder boNat anyOrder Z where
{-# Inline thisBigOrder #-}
thisBigOrder Proxy Proxy Z = return ()
{-# Inline getAllBounds #-}
getAllBounds Proxy Proxy Z = []
instance
( smallOrder ~ SmallOrderNats (ts:.TwITbl bo so m arr c i x)
, EachSmallOrder boNat smallOrder (ts:.TwITbl bo so m arr c i x) i
, PrimArrayOps arr i x
, IndexStream i
) ⇒ ThisBigOrder boNat True (ts:.TwITbl bo so m arr c i x) where
{-# Inline thisBigOrder #-}
thisBigOrder Proxy Proxy tst@(_:.TW (ITbl _ arr) _) = do
let to = upperBound arr
let allBounds = getAllBounds (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy True) tst
flip SM.mapM_ (streamUp zeroBound' to) $ \k ->
eachSmallOrder (Proxy ∷ Proxy boNat) (Proxy ∷ Proxy smallOrder) tst k
{-# Inline getAllBounds #-}
getAllBounds Proxy Proxy (ts:.t) = undefined
instance
( ThisBigOrder n (IsThisBigOrder n ts) ts
) ⇒ ThisBigOrder n False (ts:.t) where
{-# Inline thisBigOrder #-}
thisBigOrder Proxy Proxy (ts:.t) =
thisBigOrder (Proxy ∷ Proxy n) (Proxy ∷ Proxy (IsThisBigOrder n ts)) ts
class EachSmallOrder (bigOrder ∷ Nat) (smallOrders ∷ [Nat]) ts i where
eachSmallOrder
∷ Proxy bigOrder
→ Proxy smallOrders
→ ts
→ i
→ ST s ()
instance EachSmallOrder bigOrder '[] ts i where
{-# Inline eachSmallOrder #-}
eachSmallOrder Proxy Proxy ts i = return ()
instance
( EachSmallOrder bigOrder so ts i
, isThisBigOrder ~ IsThisBigOrder bigOrder ts
, isThisSmallOrder ~ IsThisSmallOrder s ts
, isThisOrder ~ (isThisBigOrder && isThisSmallOrder)
, ThisSmallOrder bigOrder s isThisOrder ts i
) ⇒ EachSmallOrder bigOrder (s ': so) ts i where
{-# Inline eachSmallOrder #-}
eachSmallOrder Proxy Proxy ts i = do
thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy s) (Proxy ∷ Proxy isThisOrder) ts i
eachSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy so) ts i
class ThisSmallOrder (bigNat ∷ Nat) (smallNat ∷ Nat) (thisOrder ∷ Bool) ts i where
thisSmallOrder ∷ Proxy bigNat → Proxy smallNat → Proxy thisOrder → ts → i → ST s ()
instance ThisSmallOrder b s any Z i where
{-# Inline thisSmallOrder #-}
thisSmallOrder _ _ _ _ _ = return ()
instance
( isThisBigOrder ~ IsThisBigOrder bigOrder ts
, isThisSmallOrder ~ IsThisSmallOrder smallOrder ts
, isThisOrder ~ (isThisBigOrder && isThisSmallOrder)
, ThisSmallOrder bigOrder smallOrder isThisOrder ts i
) ⇒ ThisSmallOrder bigOrder smallOrder 'False (ts:.t) i where
{-# Inline thisSmallOrder #-}
thisSmallOrder Proxy Proxy Proxy (ts:.t) i =
thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i
instance
( PrimArrayOps arr i x
, MPrimArrayOps arr i x
, isThisBigOrder ~ IsThisBigOrder bigOrder ts
, isThisSmallOrder ~ IsThisSmallOrder smallOrder ts
, isThisOrder ~ (isThisBigOrder && isThisSmallOrder)
, ThisSmallOrder bigOrder smallOrder isThisOrder ts i
) ⇒ ThisSmallOrder bigOrder smallOrder 'True (ts:.TwITbl bo so Id arr c i x) i where
{-# Inline thisSmallOrder #-}
thisSmallOrder Proxy Proxy Proxy (ts:.TW (ITbl _ arr) f) i = do
let uB = upperBound arr
marr <- unsafeThaw arr
z ← return . unId $ (inline f) uB i
writeM marr i z
thisSmallOrder (Proxy ∷ Proxy bigOrder) (Proxy ∷ Proxy smallOrder) (Proxy ∷ Proxy isThisOrder) ts i
type BigOrderNats arr = Nub (Sort (BigOrderNats' arr))
type family BigOrderNats' arr ∷ [Nat]
type instance BigOrderNats' Z = '[]
type instance BigOrderNats' (ts:.TwITbl bo so m arr c i x) = bo ': BigOrderNats' ts
type family IsThisBigOrder (n ∷ Nat) arr ∷ Bool
type instance IsThisBigOrder n Z = 'False
type instance IsThisBigOrder n (ts:.TwITbl bo so m arr c i x) = n == bo
type SmallOrderNats arr = Nub (Sort (SmallOrderNats' arr))
type family SmallOrderNats' arr ∷ [Nat]
type instance SmallOrderNats' Z = '[]
type instance SmallOrderNats' (ts:.TwITbl bo so m arr c i x) = so ': SmallOrderNats' ts
type family IsThisSmallOrder (n ∷ Nat) arr ∷ Bool
type instance IsThisSmallOrder n Z = 'False
type instance IsThisSmallOrder n (ts:.TwITbl bo so m arr c i x) = n == so
data Mutated ts = Mutated
{ mutatedTables ∷ !ts
, perfCounter ∷ !PerfCounter
, eachBigPerfCounter ∷ [PerfCounter]
}
deriving (Eq,Ord,Show,Generic)
instance NFData ts ⇒ NFData (Mutated ts)
data PerfCounter = PerfCounter
{ picoSeconds :: !Integer
, seconds :: !Double
, numberOfCells :: !Integer
}
deriving (Eq,Ord,Show,Generic)
instance NFData PerfCounter
showPerfCounter ∷ PerfCounter → String
{-# NoInline showPerfCounter #-}
showPerfCounter PerfCounter{..} =
let cellsSecond = round $ fromIntegral numberOfCells / seconds
m ∷ Integer = 1000000
in printf "%.4f seconds, %d,%06d cells @ %d,%06d cells/second"
seconds
(numberOfCells `div` m) (numberOfCells `mod` m)
(cellsSecond `div` m) (cellsSecond `mod` m)
instance Num PerfCounter where
PerfCounter p1 s1 n1 + PerfCounter p2 s2 n2 = PerfCounter (p1+p2) (s1+s2) (n1+n2)
class CountNumberOfCells (n ∷ Nat) t where
countNumberOfCells ∷ Maybe (Proxy n) → t → Integer
instance CountNumberOfCells n Z where
{-# NoInline countNumberOfCells #-}
countNumberOfCells p Z = 0
instance
( CountNumberOfCells n ts
, Index i
, PrimArrayOps arr i x
, KnownNat n
, KnownNat bo
) ⇒ CountNumberOfCells n (ts:.TwITbl bo so Id arr c i x) where
{-# NoInline countNumberOfCells #-}
countNumberOfCells mayP (ts:.(TW (ITbl _ arr) fun)) =
let n = natVal (Proxy ∷ Proxy n)
bo = natVal (Proxy ∷ Proxy bo)
cs = countNumberOfCells mayP ts
c = product . totalSize $ upperBound arr
in case mayP of
Nothing → cs + c
Just _ → cs + if n==bo then c else 0