Add benchmark for comparing PGF and LPGF

gf.cabal

@@ -364,7 +364,6 @@ test-suite lpgf
     src/compiler
     src/runtime/haskell
     testsuite/lpgf
-
   other-modules:
     Data.Binary
     Data.Binary.Builder
@@ -491,7 +490,6 @@ test-suite lpgf
     GF.Text.Pretty
     GF.Text.Transliterations
     LPGF
-    Paths_gf
     PGF
     PGF.Binary
     PGF.ByteCode
@@ -516,6 +514,194 @@ test-suite lpgf
     PGF.TypeCheck
     PGF.Utilities
     PGF.VisualizeTree
+    Paths_gf
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+  build-depends:
+    array,
+    base>=4.6 && <5,
+    bytestring,
+    containers,
+    directory,
+    filepath,
+    ghc-prim,
+    haskeline,
+    json,
+    mtl,
+    parallel>=3,
+    pretty,
+    process,
+    random,
+    terminfo,
+    text,
+    time,
+    transformers-compat,
+    unix,
+    utf8-string
+  default-language: Haskell2010
+
+benchmark lpgf-bench
+  type: exitcode-stdio-1.0
+  main-is: bench.hs
+  hs-source-dirs:
+    src/compiler
+    src/runtime/haskell
+    testsuite/lpgf
+  other-modules:
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF
+    GF.Command.Abstract
+    GF.Command.CommandInfo
+    GF.Command.Commands
+    GF.Command.CommonCommands
+    GF.Command.Help
+    GF.Command.Importing
+    GF.Command.Interpreter
+    GF.Command.Messages
+    GF.Command.Parse
+    GF.Command.SourceCommands
+    GF.Command.TreeOperations
+    GF.Compile
+    GF.Compile.CFGtoPGF
+    GF.Compile.CheckGrammar
+    GF.Compile.Compute.ConcreteNew
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
+    GF.Compile.ConcreteToHaskell
+    GF.Compile.ExampleBased
+    GF.Compile.Export
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToCanonical
+    GF.Compile.GrammarToLPGF
+    GF.Compile.GrammarToPGF
+    GF.Compile.Multi
+    GF.Compile.Optimize
+    GF.Compile.PGFtoHaskell
+    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoJava
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.ToAPI
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.RConcrete
+    GF.Compile.TypeCheck.TC
+    GF.Compile.Update
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compiler
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.Graph
+    GF.Data.Graphviz
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Data.XML
+    GF.Grammar
+    GF.Grammar.Analyse
+    GF.Grammar.BNFC
+    GF.Grammar.Binary
+    GF.Grammar.CFG
+    GF.Grammar.Canonical
+    GF.Grammar.CanonicalJSON
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Parser
+    GF.Grammar.PatternMatch
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.ShowTerm
+    GF.Grammar.Unify
+    GF.Grammar.Values
+    GF.Haskell
+    GF.Infra.BuildInfo
+    GF.Infra.CheckM
+    GF.Infra.Concurrency
+    GF.Infra.Dependencies
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.SIO
+    GF.Infra.UseIO
+    GF.Interactive
+    GF.JavaScript.AbsJS
+    GF.JavaScript.PrintJS
+    GF.Main
+    GF.Quiz
+    GF.Speech.CFGToFA
+    GF.Speech.FiniteState
+    GF.Speech.GSL
+    GF.Speech.JSGF
+    GF.Speech.PGFToCFG
+    GF.Speech.PrRegExp
+    GF.Speech.RegExp
+    GF.Speech.SISR
+    GF.Speech.SLF
+    GF.Speech.SRG
+    GF.Speech.SRGS_ABNF
+    GF.Speech.SRGS_XML
+    GF.Speech.VoiceXML
+    GF.Support
+    GF.System.Catch
+    GF.System.Concurrency
+    GF.System.Console
+    GF.System.Directory
+    GF.System.Process
+    GF.System.Signal
+    GF.Text.Clitics
+    GF.Text.Coding
+    GF.Text.Lexing
+    GF.Text.Pretty
+    GF.Text.Transliterations
+    LPGF
+    PGF
+    PGF.Binary
+    PGF.ByteCode
+    PGF.CId
+    PGF.Data
+    PGF.Expr
+    PGF.Expr
+    PGF.Forest
+    PGF.Generate
+    PGF.Internal
+    PGF.Linearize
+    PGF.Macros
+    PGF.Morphology
+    PGF.OldBinary
+    PGF.Optimize
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Printer
+    PGF.Probabilistic
+    PGF.Tree
+    PGF.TrieMap
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Utilities
+    PGF.VisualizeTree
+    Paths_gf
   if flag(interrupt)
     cpp-options: -DUSE_INTERRUPT
     other-modules: GF.System.UseSignal

testsuite/lpgf/bench.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import qualified LPGF
+import LPGF (LPGF)
+import qualified PGF
+import PGF (PGF)
+import GF (compileToPGF, compileToLPGF, writePGF, writeLPGF)
+import GF.Support (Options, Flags (..), Verbosity (..), noOptions, addOptions, modifyFlags)
+
+import qualified Data.List as L
+import Data.Maybe (fromJust)
+import qualified Data.Map as Map
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+import System.Directory (listDirectory, getFileSize)
+import System.FilePath ((</>), takeBaseName, takeExtension)
+import Text.Printf (printf)
+
+dir :: FilePath
+dir = "testsuite" </> "lpgf"
+
+grammarName :: String
+grammarName = "Foods"
+
+treesFile :: String
+treesFile = "Foods-all.trees"
+
+options :: Options
+options = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) noOptions
+
+main :: IO ()
+main = do
+  -- Collect concrete modules
+  mods <- map (dir </>)
+        . filter (\p -> grammarName `L.isPrefixOf` takeBaseName p && takeExtension p == ".gf")
+        <$> listDirectory dir
+
+  -- Compile
+  (pathPGF, pgf) <- time "compile PGF" (compilePGF mods)
+  (pathLPGF, lpgf) <- time "compile LPGF" (compileLPGF mods)
+
+  -- Compare filesizes
+  sizePGF <- getFileSize pathPGF
+  sizeLPGF <- getFileSize pathLPGF
+  printf "- PGF size: %s\n" (convertSize sizePGF)
+  printf "- LPGF size: %s\n" (convertSize sizeLPGF)
+
+  -- Read trees
+  lns <- lines <$> readFile (dir </> treesFile)
+  let trees = map (fromJust . PGF.readExpr) lns
+  printf "Read %d trees\n" (length trees)
+
+  -- Linearise
+  time "linearise PGF" (return $ length $ linPGF pgf trees)
+  time "linearise LPGF" (return $ length $ linLPGF lpgf trees)
+
+  return ()
+
+time :: String -> IO a -> IO a
+time desc io = do
+  start <- getCurrentTime
+  !r <- io
+  end <- getCurrentTime
+  printf "- %s: %s\n" desc (show (diffUTCTime end start))
+  return r
+
+-- timePure :: String -> a -> IO a
+-- timePure desc val = do
+--   start <- getCurrentTime
+--   let !r = val
+--   end <- getCurrentTime
+--   printf "- %s: %s\n" desc (show (diffUTCTime end start))
+--   return r
+
+compilePGF :: [FilePath] -> IO (FilePath, PGF)
+compilePGF mods = do
+  pgf <- compileToPGF options mods
+  files <- writePGF options pgf
+  return (head files, pgf)
+
+compileLPGF :: [FilePath] -> IO (FilePath, LPGF)
+compileLPGF mods = do
+  lpgf <- compileToLPGF options mods
+  file <- writeLPGF options lpgf
+  return (file, lpgf)
+
+linPGF :: PGF -> [PGF.Expr] -> [[String]]
+linPGF pgf trees =
+  [ map (PGF.linearize pgf lang) trees | lang <- PGF.languages pgf ]
+
+linLPGF :: LPGF -> [PGF.Expr] -> [[Text]]
+linLPGF lpgf trees =
+  [ map (LPGF.linearizeConcreteText concr) trees | (_,concr) <- Map.toList (LPGF.concretes lpgf) ]
+
+-- | Produce human readable file size
+-- Adapted from https://hackage.haskell.org/package/hrfsize
+convertSize :: Integer -> String
+convertSize = convertSize' . fromInteger
+convertSize' :: Double -> String
+convertSize' size
+  | size < 1024.0 = printf "%.0v bytes" size
+  | size < 1024.0 ^ (2 :: Int) = printf "%.2v KiB" $ size / 1024.0
+  | size < 1024.0 ^ (3 :: Int) = printf "%.2v MiB" $ size / 1024.0 ^ (2 :: Int)
+  | size < 1024.0 ^ (4 :: Int) = printf "%.2v GiB" $ size / 1024.0 ^ (3 :: Int)
+  | otherwise = printf "%.2v TiB" $ size / 1024.0 ^ (4 :: Int)

testsuite/lpgf/run.hs

@@ -1,3 +1,5 @@
+module Main where
+
 import LPGF
 import PGF (showLanguage, readExpr)
 import GF (compileToLPGF, writeLPGF)