Commit 055bdf57 authored by Ben Gamari's avatar Ben Gamari 🐢
Browse files

Model collectArgsTicks

parent f4c943a3
......@@ -7,12 +7,20 @@ import Control.DeepSeq
import Data.Foldable
import Criterion.Main
newtype Tickish = Tickish Int
deriving (Show)
instance NFData Tickish where
rnf (Tickish n) = rnf n
data Expr = App Expr Expr
| Tick Tickish Expr
| Var Int
deriving (Show)
instance NFData Expr where
rnf (App a b) = rnf a `seq` rnf b
rnf (Tick a b) = rnf a `seq` rnf b
rnf (Var a) = rnf a
appChain :: Int -> Expr
......@@ -21,6 +29,56 @@ appChain = go
go 0 = Var 0
go n = go (n-1) `App` (Var n)
appTickChain :: Int -> Expr
appTickChain = go
where
go 0 = Var 0
go n = Tick (Tickish n) $ go (n-1) `App` (Var n)
collectArgsTicks_Seq :: Expr -> (Expr, [Expr], Seq.Seq Tickish)
collectArgsTicks_Seq = go mempty mempty
where
go :: [Expr] -> Seq.Seq Tickish -> Expr -> (Expr, [Expr], Seq.Seq Tickish)
go as ts (App f a) = go (a:as) ts f
go as ts (Tick t e) = go as (ts <> Seq.singleton t) e
go as ts a = (a, as, ts)
collectArgsTicks_List :: Expr -> (Expr, [Expr], [Tickish])
collectArgsTicks_List = go mempty mempty
where
go :: [Expr] -> [Tickish] -> Expr -> (Expr, [Expr], [Tickish])
go as ts (App f a) = go (a:as) ts f
go as ts (Tick t e) = go as (t:ts) e
go as ts a = (a, as, reverse ts)
collectArgsTicks_DList :: Expr -> (Expr, [Expr], [Tickish])
collectArgsTicks_DList = go mempty mempty
where
go :: [Expr] -> DList.DList Tickish -> Expr -> (Expr, [Expr], [Tickish])
go as ts (App f a) = go (a:as) ts f
go as ts (Tick t e) = go as (ts <> DList.singleton t) e
go as ts a = (a, as, toList ts)
collectArgsTicks_OnStack :: Expr -> (Expr, [Expr], [Tickish])
collectArgsTicks_OnStack = go mempty
where
go :: [Expr] -> Expr -> (Expr, [Expr], [Tickish])
go as (App f a) = go (a:as) f
go as (Tick t a) =
let !(e', as, ts) = go as a
in (e', as, t:ts)
go as a = (a, as, [])
collectArgsTicksBenchmarks :: Int -> Benchmark
collectArgsTicksBenchmarks len = bgroup ("length="++show len)
[ bench "sequence" $ nf (collectArgsTicks_Seq) xs
, bench "dlist" $ nf (collectArgsTicks_DList) xs
, bench "list" $ nf (collectArgsTicks_List) xs
, bench "on-stack" $ nf (collectArgsTicks_OnStack) xs
]
where
xs = appChain len
collectArgs_Seq :: Expr -> (Expr, Seq.Seq Expr)
collectArgs_Seq = go mempty
where
......@@ -97,4 +155,5 @@ main :: IO ()
main = defaultMain
[ bgroup "rebuild" $ map rebuildBenchmarks lengths
, bgroup "collectArgs" $ map collectArgsBenchmarks lengths
, bgroup "collectArgsTicks" $ map collectArgsTicksBenchmarks lengths
]
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment