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:
1
gf.cabal
1
gf.cabal
@@ -729,6 +729,7 @@ benchmark lpgf-bench
|
|||||||
base>=4.6 && <5,
|
base>=4.6 && <5,
|
||||||
bytestring,
|
bytestring,
|
||||||
containers,
|
containers,
|
||||||
|
deepseq,
|
||||||
directory,
|
directory,
|
||||||
filepath,
|
filepath,
|
||||||
ghc-prim,
|
ghc-prim,
|
||||||
|
|||||||
@@ -190,7 +190,7 @@ inlineParamAliases defs = if null aliases then defs else map rp' pdefs
|
|||||||
|
|
||||||
rp' :: C.ParamDef -> C.ParamDef
|
rp' :: C.ParamDef -> C.ParamDef
|
||||||
rp' (C.ParamDef pid pids) = C.ParamDef pid (map rp'' pids)
|
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.ParamValueDef -> C.ParamValueDef
|
||||||
rp'' (C.Param pid pids) = C.Param pid (map rp''' pids)
|
rp'' (C.Param pid pids) = C.Param pid (map rp''' pids)
|
||||||
|
|||||||
@@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE BangPatterns #-}
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import qualified LPGF
|
import qualified LPGF
|
||||||
@@ -8,6 +7,8 @@ import qualified PGF2
|
|||||||
import GF (compileToPGF, compileToLPGF, writePGF, writeLPGF)
|
import GF (compileToPGF, compileToLPGF, writePGF, writeLPGF)
|
||||||
import GF.Support (Options, Flags (..), Verbosity (..), noOptions, addOptions, modifyFlags)
|
import GF.Support (Options, Flags (..), Verbosity (..), noOptions, addOptions, modifyFlags)
|
||||||
|
|
||||||
|
import Control.DeepSeq (force)
|
||||||
|
import Control.Exception (evaluate)
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import qualified Data.List as L
|
import qualified Data.List as L
|
||||||
import Data.Maybe (fromJust, isJust, isNothing)
|
import Data.Maybe (fromJust, isJust, isNothing)
|
||||||
@@ -80,19 +81,19 @@ main = do
|
|||||||
when doPGF $ do
|
when doPGF $ do
|
||||||
putStrLn "PGF"
|
putStrLn "PGF"
|
||||||
pgf <- PGF.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
|
pgf <- PGF.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
|
||||||
time "linearise" (return $ length $ linPGF pgf trees)
|
time "linearise" (evaluate $ force $ linPGF pgf trees)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
when doPGF2 $ do
|
when doPGF2 $ do
|
||||||
putStrLn "PGF2"
|
putStrLn "PGF2"
|
||||||
pgf <- PGF2.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
|
pgf <- PGF2.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
|
||||||
time "linearise" (return $ length $ linPGF2 pgf trees2)
|
time "linearise" (evaluate $ force $ linPGF2 pgf trees2)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
when doLPGF $ do
|
when doLPGF $ do
|
||||||
putStrLn "LPGF"
|
putStrLn "LPGF"
|
||||||
lpgf <- LPGF.readLPGF (dropExtension (fromJust binaryFile) <.> "lpgf")
|
lpgf <- LPGF.readLPGF (dropExtension (fromJust binaryFile) <.> "lpgf")
|
||||||
time "linearise" (return $ length $ linLPGF lpgf trees)
|
time "linearise" (evaluate $ force $ linLPGF lpgf trees)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
stats <- getRTSStats
|
stats <- getRTSStats
|
||||||
@@ -102,7 +103,7 @@ main = do
|
|||||||
time :: String -> IO a -> IO a
|
time :: String -> IO a -> IO a
|
||||||
time desc io = do
|
time desc io = do
|
||||||
start <- getCurrentTime
|
start <- getCurrentTime
|
||||||
!r <- io
|
r <- io
|
||||||
end <- getCurrentTime
|
end <- getCurrentTime
|
||||||
printf "- %s: %s\n" desc (show (diffUTCTime end start))
|
printf "- %s: %s\n" desc (show (diffUTCTime end start))
|
||||||
return r
|
return r
|
||||||
@@ -110,7 +111,7 @@ time desc io = do
|
|||||||
-- timePure :: String -> a -> IO a
|
-- timePure :: String -> a -> IO a
|
||||||
-- timePure desc val = do
|
-- timePure desc val = do
|
||||||
-- start <- getCurrentTime
|
-- start <- getCurrentTime
|
||||||
-- let !r = val
|
-- let r = val
|
||||||
-- end <- getCurrentTime
|
-- end <- getCurrentTime
|
||||||
-- printf "- %s: %s\n" desc (show (diffUTCTime end start))
|
-- printf "- %s: %s\n" desc (show (diffUTCTime end start))
|
||||||
-- return r
|
-- return r
|
||||||
|
|||||||
Reference in New Issue
Block a user