Commits

Patrick Bahr committed 4de478a

added benchmarks for macro tree transducers

  • Participants
  • Parent commits 7ee3ad5
  • Branches macro

Comments (0)

Files changed (6)

benchmark-macro/Benchmark.hs

+{-# LANGUAGE TypeOperators, DeriveFunctor, DeriveTraversable, DeriveFoldable, TemplateHaskell, GADTs #-}
+
+module Main where
+
+import Criterion.Main
+import Data.Comp.Derive
+import Data.Comp.DeepSeq ()
+import Data.Comp.Arbitrary ()
+import Data.Comp.Show ()
+import Data.Comp
+
+import qualified Functions.Mono as M
+import qualified DataTypes.Mono as M
+
+
+
+benchmarks :: String -> Term M.ArithLet -> String -> Term M.ArithExc -> Benchmark
+benchmarks n t n' t' = rnf t `seq` rnf t' `seq` getBench
+    where getBench = bgroup "" [letBench, excBench]
+          letBench = bgroup n
+                     [ inlineAnnBench
+                     , annInlineBench
+                     ]
+          excBench = bgroup n' 
+                     [ compAnnBench
+                     , annCompBench]
+          inlineAnnBench = bgroup "inlineAnn" 
+                           [ bench "fused" (nf M.inlineAnnFuse t) 
+                           , bench "seq" (nf M.inlineAnnSeq t)
+                           , bench "implicit, fused" (nf M.inlineAnnImpFuse t) 
+                           , bench "implicit, seq" (nf M.inlineAnnImpSeq t) ]
+          annInlineBench = bgroup "annInline" 
+                           [ bench "fused" (nf M.annInlineFuse t) 
+                           , bench "seq" (nf M.annInlineSeq t)
+                           , bench "implicit, fused)" (nf M.annInlineImpFuse t) 
+                           , bench "implicit, seq" (nf M.annInlineImpSeq t) ]
+          compAnnBench = bgroup "compAnn"
+                         [ bench "fused" (nf M.compAnnFuse t')
+                         , bench "seq" (nf M.compAnnSeq t')]
+          annCompBench = bgroup "annComp"
+                         [ bench "fused" (nf M.annCompFuse t')
+                         , bench "seq" (nf M.annCompSeq t')]
+
+genExpr :: Int -> IO Benchmark
+genExpr s = do
+  let t = M.exprAL s
+  let t' = M.exprAE s
+  putStr "size of the term: "
+  let termsize = size t
+  let termsize' = size t'
+  print termsize
+  putStr "size of the other term: "
+  print termsize'
+  return $ benchmarks ("term size="++ show termsize) t ("term size="++ show termsize') t'
+
+main = do b0 <- genExpr 11
+          b1 <- genExpr 8
+          b2 <- genExpr 4
+          defaultMain [b0, b1,b2]

benchmark-macro/DataTypes/Comp.hs

+{-# LANGUAGE DeriveFunctor, DeriveTraversable, DeriveFoldable, TemplateHaskell, FlexibleContexts #-}
+
+module DataTypes.Comp where
+
+import Data.Comp.Derive
+
+type Var = String
+
+data Arith a = Add a a | Val Int 
+               deriving (Show, Functor, Foldable, Traversable)
+
+data Let a = Let Var a a | Var Var
+                           deriving (Show, Functor, Foldable, Traversable)
+data Exc a = Throw | Catch a a
+             deriving (Show, Functor, Foldable, Traversable)
+
+data Code a = PUSH Int a 
+             | ADD a
+             | THROW
+             | MARK a a
+             | UNMARK a
+             | NIL
+
+
+
+$(derive
+  [makeEqF, makeNFDataF, makeArbitraryF, smartConstructors]
+  [''Arith, ''Let, ''Exc])

benchmark-macro/DataTypes/Mono.hs

+{-# LANGUAGE DeriveFunctor, DeriveTraversable, DeriveFoldable, TemplateHaskell, FlexibleContexts #-}
+
+module DataTypes.Mono where
+
+import Data.Comp.Derive
+import Data.Comp
+
+type Var = String
+
+data ArithLet a = Add a a | Mult a a | Sub a a | Val Int | Let Var a a | Var Var
+               deriving (Show, Functor, Foldable, Traversable)
+
+data ArithExc a = Add' a a | Val' Int | Throw | Catch a a
+             deriving (Show, Functor, Foldable, Traversable)
+
+data Code a = PUSH Int a 
+             | ADD a
+             | THROW
+             | MARK a a
+             | UNMARK a
+             | NIL
+             deriving (Show, Functor, Foldable, Traversable)
+
+
+$(derive
+  [makeShowF, makeEqF, makeNFDataF, makeArbitraryF, smartConstructors]
+  [''ArithLet, ''ArithExc, ''Code])
+
+
+exprAL :: Int -> Term ArithLet 
+exprAL 0 = iVal 4
+exprAL n = iLet "x" e1 e2
+    where e1 = (iVal 1 `iSub` iVal 2) `iAdd` iLet "y" e3 e4
+          e2 = iVar "x" `iMult` iVal 4 `iAdd` iLet "z" e5 e6 `iSub` exprAL (n-1)
+          e3 = iVal 2 `iAdd` iVal 3
+          e4 = iVar "y" `iAdd` iVar "y"
+          e5 = iVar "x" `iMult` iVar "x"
+          e6 = (iVar "x" `iSub` iVar "z") `iAdd` exprAL (n-1)
+
+exprAE :: Int -> Term ArithExc
+exprAE 0 = iVal' 3
+exprAE n = iVal' 1 `iAdd'` iCatch (exprAE (n-1) `iAdd'` iThrow) (iVal' 2 `iAdd'` exprAE (n-1))

benchmark-macro/Functions/Comp.hs

+module Functions.Comp where
+
+import DataTypes.Comp
+
+import Data.Comp
+import Data.Comp.MacroAutomata
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+
+inlineTrans :: MacroTrans' Arith (Map Var) Arith
+inlineTrans m (Var v) = case Map.lookup v m of
+                          Nothing -> iVar v
+                          Just e -> e
+inlineTrans m (Let v x y) = y (Map.insert v (x m) m)
+inlineTrans m f = Term $ fmap ($ m) f

benchmark-macro/Functions/Mono.hs

+{-# LANGUAGE TypeOperators #-}
+
+module Functions.Mono where
+
+import DataTypes.Mono
+
+import Data.Comp
+import Data.Comp.MacroAutomata
+import Data.Comp.Automata
+import Data.Comp.Number
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+pathAnnTrans :: (Functor g, Traversable g) => DownTrans g [Int] (g :&: [Int])
+pathAnnTrans q t = simpCxt (fmap (\ (Numbered (n,s)) -> s (n:q)) (number t) :&: q)
+
+
+-- Inlining
+
+
+inlineTrans :: MacroTrans' ArithLet (Map Var) ArithLet
+inlineTrans m (Var v) = case Map.lookup v m of
+                          Nothing -> iVar v
+                          Just e -> e
+inlineTrans m (Let v x y) = y (Map.insert v (x m) m)
+inlineTrans m f = Term $ fmap ($ m) f
+
+
+inlineTransExplicit :: MacroTrans ArithLet (Map Var) ArithLet
+inlineTransExplicit m (Var v) = case Map.lookup v m of
+                          Nothing -> iVar v
+                          Just e -> Hole e
+inlineTransExplicit m (Let v x y) = Hole $ y (Map.insert v (Hole $ x m') m')
+                             where m' = fmap Hole m
+inlineTransExplicit m (Add x y) = iAdd (Hole $ x m') (Hole $ y m')
+                             where m' = fmap Hole m
+inlineTransExplicit m (Mult x y) = iMult (Hole $ x m') (Hole $ y m')
+                             where m' = fmap Hole m
+inlineTransExplicit m (Sub x y) = iSub (Hole $ x m') (Hole $ y m')
+                             where m' = fmap Hole m
+inlineTransExplicit _ (Val n) = iVal n
+
+
+inlineAnnFuse :: Term ArithLet -> Term (ArithLet :&: [Int])
+inlineAnnFuse t = runMacroTrans (compMacroDown (propAnnMacro inlineTransExplicit) pathAnnTrans)
+                (Map.empty :&: []) t
+
+inlineAnnImpFuse :: Term ArithLet -> Term (ArithLet :&: [Int])
+inlineAnnImpFuse t = runMacroTrans (compMacroDown (propAnnMacro $ mkMacroTrans inlineTrans)
+                                    pathAnnTrans) (Map.empty :&: []) t
+
+inlineAnnSeq  :: Term ArithLet -> Term (ArithLet :&: [Int])
+inlineAnnSeq t = runMacroTrans (propAnnMacro inlineTransExplicit) Map.empty 
+                  (runDownTrans pathAnnTrans [] t)
+
+inlineAnnImpSeq  :: Term ArithLet -> Term (ArithLet :&: [Int])
+inlineAnnImpSeq t = runMacroTrans (propAnnMacro $ mkMacroTrans inlineTrans) Map.empty 
+                  (runDownTrans pathAnnTrans [] t)
+
+annInlineFuse :: Term ArithLet -> Term (ArithLet :&: [Int])
+annInlineFuse t = runMacroTrans (compDownMacro pathAnnTrans inlineTransExplicit) 
+                  (Map.empty :^: []) t
+
+annInlineImpFuse :: Term ArithLet -> Term (ArithLet :&: [Int])
+annInlineImpFuse t = runMacroTrans (compDownMacro pathAnnTrans (mkMacroTrans inlineTrans)) 
+                  (Map.empty :^: []) t
+
+annInlineSeq :: Term ArithLet -> Term (ArithLet :&: [Int])
+annInlineSeq t = runDownTrans pathAnnTrans [] (runMacroTrans inlineTransExplicit Map.empty t)
+
+annInlineImpSeq :: Term ArithLet -> Term (ArithLet :&: [Int])
+annInlineImpSeq t = runDownTrans pathAnnTrans [] (runMacroTrans (mkMacroTrans inlineTrans) Map.empty t)
+
+
+-- Code generator
+
+compTrans :: MacroTransId' ArithExc Code
+compTrans q (Val' n) = iPUSH n q
+compTrans q (Add' x y) = x $ y $ iADD q
+compTrans _ Throw = iTHROW
+compTrans q (Catch x h) = iMARK (h q) (x $ iUNMARK q)
+
+
+compAnnFuse :: Term ArithExc -> Term (Code :&: [Int])
+compAnnFuse t = runMacroTrans (compMacroDown (propAnnMacro $ fromMacroTransId' compTrans) pathAnnTrans ) (Id (ann [] iNIL) :&: [])  t
+
+compAnnSeq :: Term ArithExc -> Term (Code :&: [Int])
+compAnnSeq t = runMacroTrans (propAnnMacro $ fromMacroTransId' compTrans) (Id (ann [] iNIL))
+               (runDownTrans pathAnnTrans [] t)
+
+annCompFuse :: Term ArithExc -> Term (Code :&: [Int])
+annCompFuse t = runMacroTrans (compDownMacro pathAnnTrans (fromMacroTransId' compTrans)) 
+                (Id (`ann` iNIL) :^: []) t
+
+annCompSeq :: Term ArithExc -> Term (Code :&: [Int])
+annCompSeq t = runDownTrans pathAnnTrans [] (runMacroTrans (fromMacroTransId' compTrans)
+                (Id iNIL) t)
   cpp-options:          -DNO_RULES
   Build-Depends:        base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns, transformers
 
+Benchmark macro
+  Type:                 exitcode-stdio-1.0
+  Main-is:		Benchmark.hs
+  hs-source-dirs:	src benchmark-macro
+  ghc-options:          -W -O2
+  -- Disable short-cut fusion rules in order to compare optimised and unoptimised code.
+  cpp-options:          -DNO_RULES
+  Build-Depends:        base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns, transformers
+
 
 source-repository head
   type:     hg