compdata-0.2: benchmark/Benchmark.hs

module Main where

import Criterion.Main
import qualified Functions.Comp as A
import qualified Functions.Standard as S
import DataTypes.Comp as DC
import DataTypes.Standard as DS
import DataTypes.Transform
import Data.Comp
import Data.Comp.DeepSeq ()
import Control.DeepSeq
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen
import System.Random

aExpr :: SugarExpr
aExpr = iIf ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))
            `iOr` ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))))
       ((iVInt 2 `iMinus` iVInt 1))
       (iVInt 3)

sExpr :: PExpr
sExpr = transSugar aExpr


sfCoalg :: Coalg SugarSig Int
sfCoalg 0 = inj $ VInt 1
sfCoalg n = let n' = n-1 in inj $ Plus n' n'

sfGen' :: Int -> SugarExpr
sfGen'  = ana' sfCoalg

sfGen :: Int -> SugarExpr
sfGen  = ana sfCoalg

shortcutFusion :: Benchmark
shortcutFusion = bgroup "shortcut-fusion" [
                  bench "eval without fusion" (nf (A.evalSugar2 . sfGen) depth),
                  bench "eval with fusion" (nf (A.evalSugar2 . sfGen') depth)
                  ]
    where depth = 15

standardBenchmarks :: (PExpr, SugarExpr, String) -> Benchmark
standardBenchmarks  (sExpr,aExpr,n) = rnf aExpr `seq` rnf sExpr `seq` getBench (sExpr, aExpr,n)
    where getBench (sExpr, aExpr,n) = bgroup n [
                 -- bench "Comp.desug" (nf A.desugExpr aExpr),
                 -- bench "Comp.desugAlg" (nf A.desugExpr2 aExpr),
                 -- bench "Standard.desug" (nf S.desug sExpr),
                 bench "Comp.desugType" (nf A.desugType aExpr),
                 bench "Comp.desugType'" (nf A.desugType' aExpr),
                 bench "Standard.desugType" (nf S.desugType sExpr),
                 -- bench "Comp.typeSugar" (nf A.typeSugar aExpr),
                 -- bench "Standard.typeSugar" (nf S.typeSugar sExpr),
                 bench "Comp.desugType2" (nf A.desugType2 aExpr),
                 bench "Comp.desugType2'" (nf A.desugType2' aExpr),
                 bench "Standard.desugType2" (nf S.desugType2 sExpr)
                 -- bench "Comp.typeSugar2" (nf A.typeSugar2 aExpr),
                 -- bench "Standard.typeSugar2" (nf S.typeSugar2 sExpr),
                 -- bench "Comp.desugEval" (nf A.desugEval aExpr),
                 -- bench "Comp.desugEval'" (nf A.desugEval' aExpr),
                 -- bench "Standard.desugEval" (nf S.desugEval sExpr),
                 -- bench "Comp.evalSugar" (nf A.evalSugar aExpr),
                 -- bench "Comp.evalDirect" (nf A.evalDirectE aExpr),
                 -- bench "Standard.evalSugar" (nf S.evalSugar sExpr),
                 -- bench "Comp.desugEval2" (nf A.desugEval2 aExpr),
                 -- bench "Comp.desugEval2'" (nf A.desugEval2' aExpr),
                 -- bench "Standard.desugEval2" (nf S.desugEval2 sExpr),
                 -- bench "Comp.evalSugar2" (nf A.evalSugar2 aExpr),
                 -- bench "Comp.evalDirect2" (nf A.evalDirectE2 aExpr),
                 -- bench "Standard.evalSugar2" (nf S.evalSugar2 sExpr),
                 -- bench "Comp.contVar" (nf (A.contVar 10) aExpr),
                 -- bench "Comp.contVar'" (nf (A.contVar' 10) aExpr),
                 -- bench "Comp.contVarGen" (nf (A.contVarGen 10) aExpr),
                 -- bench "Standard.contVar" (nf (S.contVar 10) sExpr),
                 -- bench "Standard.contVarGen" (nf (S.contVarGen 10) sExpr),
                 -- bench "Comp.freeVars" (nf A.freeVars aExpr),
                 -- bench "Comp.freeVars'" (nf A.freeVars' aExpr),
                 -- bench "Comp.freeVarsGen" (nf A.freeVarsGen aExpr),
                 -- bench "Standard.freeVars" (nf S.freeVars sExpr),
                 -- bench "Standard.freeVarsGen" (nf S.freeVarsGen sExpr)
                                      ]

randStdBenchmarks :: Int -> IO Benchmark
randStdBenchmarks s = do
  rand <- getStdGen
  let ty = unGen arbitrary rand s
  putStr "size of the type term: "
  print $ size ty
  print $ ty
  let aExpr = unGen (genTyped ty) rand s
      sExpr = transSugar aExpr
  putStr "size of the input term: "
  print $ size aExpr
  putStr "does it type check: "
  print (A.desugType aExpr == Right ty)
  return $ standardBenchmarks (sExpr,aExpr, "random (depth: " ++ show s ++ ", size: "++ show (size aExpr) ++ ")")


main = do b1 <- randStdBenchmarks 5
          b2 <- randStdBenchmarks 10
          b3 <- randStdBenchmarks 20
          let b0 = standardBenchmarks (sExpr, aExpr, "hand-written")
          defaultMain $ [b0,b1,b2,b3]