1
0
forked from GitHub/gf-core

Force evaluation in benchmark linearisation

BangPatterns only does WHNF which is not sufficient, previous benchmark results are thus wrong
This commit is contained in:
John J. Camilleri
2021-02-18 21:01:30 +01:00
parent 5240749fad
commit 625386a14f
3 changed files with 9 additions and 7 deletions

View File

@@ -729,6 +729,7 @@ benchmark lpgf-bench
base>=4.6 && <5,
bytestring,
containers,
deepseq,
directory,
filepath,
ghc-prim,

View File

@@ -190,7 +190,7 @@ inlineParamAliases defs = if null aliases then defs else map rp' pdefs
rp' :: C.ParamDef -> C.ParamDef
rp' (C.ParamDef pid pids) = C.ParamDef pid (map rp'' pids)
rp' _ = error "inlineParamAliases called on ParamAliasDef"
rp' (C.ParamAliasDef _ _) = error "inlineParamAliases called on ParamAliasDef"
rp'' :: C.ParamValueDef -> C.ParamValueDef
rp'' (C.Param pid pids) = C.Param pid (map rp''' pids)

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified LPGF
@@ -8,6 +7,8 @@ import qualified PGF2
import GF (compileToPGF, compileToLPGF, writePGF, writeLPGF)
import GF.Support (Options, Flags (..), Verbosity (..), noOptions, addOptions, modifyFlags)
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Control.Monad (when)
import qualified Data.List as L
import Data.Maybe (fromJust, isJust, isNothing)
@@ -80,19 +81,19 @@ main = do
when doPGF $ do
putStrLn "PGF"
pgf <- PGF.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
time "linearise" (return $ length $ linPGF pgf trees)
time "linearise" (evaluate $ force $ linPGF pgf trees)
return ()
when doPGF2 $ do
putStrLn "PGF2"
pgf <- PGF2.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
time "linearise" (return $ length $ linPGF2 pgf trees2)
time "linearise" (evaluate $ force $ linPGF2 pgf trees2)
return ()
when doLPGF $ do
putStrLn "LPGF"
lpgf <- LPGF.readLPGF (dropExtension (fromJust binaryFile) <.> "lpgf")
time "linearise" (return $ length $ linLPGF lpgf trees)
time "linearise" (evaluate $ force $ linLPGF lpgf trees)
return ()
stats <- getRTSStats
@@ -102,7 +103,7 @@ main = do
time :: String -> IO a -> IO a
time desc io = do
start <- getCurrentTime
!r <- io
r <- io
end <- getCurrentTime
printf "- %s: %s\n" desc (show (diffUTCTime end start))
return r
@@ -110,7 +111,7 @@ time desc io = do
-- timePure :: String -> a -> IO a
-- timePure desc val = do
-- start <- getCurrentTime
-- let !r = val
-- let r = val
-- end <- getCurrentTime
-- printf "- %s: %s\n" desc (show (diffUTCTime end start))
-- return r