GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

Setup.hs: reduce zero build time by ~30% (from 26 to 18 seconds on my laptop)

Browse Source 
This speedup is obtained by instead of generating 211 shell commands to compile the RGL one file at a time, generate 7 shell commands, passing a number of
related files to GF in one go.

In addition to cutting down the zero build time, this opens up for speeding up
full builds of the RGL, by adding more parallelism in GF's grammar compilation
machinery.

(Note: gf.cabal already takes advantage of GHC's parallel build option to
speed up the compilation of GF itself, if GHC>=7.8 is used.)
This commit is contained in:
hallgren
2014-07-28 15:11:58 +00:00
parent 7a91afc02a
commit 4adb4bab71
1 changed files with 72 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files

138
Setup.hs
View File

@@ -23,14 +23,13 @@ tryIOE :: IO a -> IO (Either E.IOException a)
tryIOE = E.try tryIOE = E.try
main :: IO () main :: IO ()
main = defaultMainWithHooks simpleUserHooks{ preBuild =gfPreBuild main = defaultMainWithHooks simpleUserHooks{ preBuild = gfPreBuild
, postBuild=gfPostBuild , postBuild = gfPostBuild
, preInst =gfPreInst , preInst = gfPreInst
, postInst =gfPostInst , postInst = gfPostInst
, preCopy =const . checkRGLArgs , preCopy = const . checkRGLArgs
, postCopy =gfPostCopy , postCopy = gfPostCopy
, sDistHook=sdistRGL , sDistHook = sdistRGL
-- , runTests =testRGL
} }
where where
gfPreBuild args = gfPre args . buildDistPref gfPreBuild args = gfPre args . buildDistPref
@@ -42,18 +41,19 @@ main = defaultMainWithHooks simpleUserHooks{ preBuild =gfPreBuild
return h return h
gfPostBuild args flags pkg lbi = gfPostBuild args flags pkg lbi =
do buildRGL args flags pkg lbi do writeFile "running" ""
let gf = default_gf pkg lbi buildRGL args flags (pkg,lbi)
let gf = default_gf (pkg,lbi)
buildWeb gf args flags pkg lbi buildWeb gf args flags pkg lbi
gfPostInst args flags pkg lbi = gfPostInst args flags pkg lbi =
do installRGL args flags pkg lbi do installRGL args flags (pkg,lbi)
let gf = default_gf pkg lbi let gf = default_gf (pkg,lbi)
installWeb gf args flags pkg lbi installWeb gf args flags pkg lbi
gfPostCopy args flags pkg lbi = gfPostCopy args flags pkg lbi =
do copyRGL args flags pkg lbi do copyRGL args flags (pkg,lbi)
let gf = default_gf pkg lbi let gf = default_gf (pkg,lbi)
copyWeb gf args flags pkg lbi copyWeb gf args flags pkg lbi
-------------------------------------------------------- --------------------------------------------------------
@@ -68,49 +68,53 @@ data RGLCommand
= RGLCommand = RGLCommand
{ cmdName :: String { cmdName :: String
, cmdIsDef :: Bool , cmdIsDef :: Bool
, cmdAction :: [Mode] -> [String] -> PackageDescription -> LocalBuildInfo -> IO () , cmdAction :: [Mode] -> [String] -> Info -> IO ()
} }
type Info = (PackageDescription,LocalBuildInfo)
rglCommands = rglCommands =
[ RGLCommand "prelude" True $ \mode args pkg lbi -> do [ RGLCommand "prelude" True $ \mode args bi -> do
putStrLn $ "Compiling [prelude]" putStrLn $ "Compiling [prelude]"
let prelude_src_dir = rgl_src_dir </> "prelude" let prelude_src_dir = rgl_src_dir </> "prelude"
prelude_dst_dir = rgl_dst_dir lbi </> "prelude" prelude_dst_dir = rgl_dst_dir bi </> "prelude"
createDirectoryIfMissing True prelude_dst_dir createDirectoryIfMissing True prelude_dst_dir
files <- ls prelude_src_dir files <- ls prelude_src_dir
run_gfc pkg lbi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir </> file | file <- files]) run_gfc bi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir </> file | file <- files])
, RGLCommand "lang" True $ \modes args pkg lbi -> do , RGLCommand "lang" True $ \modes args bi ->
parallel_ parallel_ [gfcn bi mode (summary lang++" "++summary symbol) files
[do mapM_ (gfc1 mode pkg lbi . lang) (optml mode langsLang args) | mode <- modes,
mapM_ (gfc1 mode pkg lbi . symbol) (optml mode langsAPI args) let files = map lang (optml mode langsLang args)++
| mode <- modes] map symbol (optml mode langsAPI args)]
, RGLCommand "compat" True $ \modes args pkg lbi -> do , RGLCommand "compat" True $ \modes args bi ->
mapM_ (gfc modes pkg lbi . compat) (optl langsCompat args) gfc bi modes (summary compat) (map compat (optl langsCompat args))
, RGLCommand "api" True $ \modes args pkg lbi -> do , RGLCommand "api" True $ \modes args bi ->
parallel_ parallel_ [gfcn bi mode (summary try++" "++summary symbolic) files
[do mapM_ (gfc1 mode pkg lbi . try) (optml mode langsAPI args) | mode <- modes,
mapM_ (gfc1 mode pkg lbi . symbolic) (optml mode langsSymbolic args) let files = map try (optml mode langsAPI args) ++
| mode <- modes] map symbolic (optml mode langsSymbolic args)]
, RGLCommand "pgf" False $ \modes args pkg lbi -> , RGLCommand "pgf" False $ \modes args bi ->
parallel_ [ parallel_ [
do let dir = getRGLBuildDir lbi mode do let dir = getRGLBuildDir bi mode
createDirectoryIfMissing True dir createDirectoryIfMissing True dir
sequence_ [run_gfc pkg lbi ["-s","-make","-name=Lang"++la, sequence_ [run_gfc bi ["-s","-make","-name=Lang"++la,
dir ++ "/Lang" ++ la ++ ".gfo"] dir ++ "/Lang" ++ la ++ ".gfo"]
| (_,la) <- optl langsPGF args] | (_,la) <- optl langsPGF args]
run_gfc pkg lbi (["-s","-make","-name=Lang"]++ run_gfc bi (["-s","-make","-name=Lang"]++
["Lang" ++ la ++ ".pgf"|(_,la)<-optl langsPGF args]) ["Lang" ++ la ++ ".pgf"|(_,la)<-optl langsPGF args])
| mode <- modes] | mode <- modes]
, RGLCommand "demo" False $ \modes args pkg lbi -> do , RGLCommand "demo" False $ \modes args bi -> do
let ls = optl langsDemo args let ls = optl langsDemo args
gf (demos "Demo" ls) ["demo/Demo" ++ la ++ ".gf" | (_,la) <- ls] pkg lbi gf bi (demos "Demo" ls) ["demo/Demo" ++ la ++ ".gf" | (_,la) <- ls]
return () return ()
, RGLCommand "parse" False $ \mode args pkg lbi -> do , RGLCommand "parse" False $ \mode args bi ->
mapM_ (gfc mode pkg lbi . parse) (optl langsParse args) gfc bi mode (summary parse) (map parse (optl langsParse args))
, RGLCommand "none" False $ \mode args pkg lbi -> do , RGLCommand "none" False $ \mode args bi ->
return () return ()
] ]
where where
summary f = f ("*","*")
optl = optml AllTenses optl = optml AllTenses
optml mode ls args = getOptLangs (shrink ls) args optml mode ls args = getOptLangs (shrink ls) args
where where
@@ -128,25 +132,25 @@ checkRGLArgs args = do
putStrLn $ "Unrecognised flags: " ++ intercalate ", " args' putStrLn $ "Unrecognised flags: " ++ intercalate ", " args'
return emptyHookedBuildInfo return emptyHookedBuildInfo
buildRGL args flags pkg lbi = do buildRGL args flags bi = do
let cmds = getRGLCommands args let cmds = getRGLCommands args
let modes = getOptMode args let modes = getOptMode args
mapM_ (\cmd -> cmdAction cmd modes args pkg lbi) cmds mapM_ (\cmd -> cmdAction cmd modes args bi) cmds
installRGL args flags pkg lbi = do installRGL args flags bi = do
let modes = getOptMode args let modes = getOptMode args
let inst_gf_lib_dir = datadir (absoluteInstallDirs pkg lbi NoCopyDest) </> "lib" let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi NoCopyDest) </> "lib"
copyAll "prelude" (rgl_dst_dir lbi </> "prelude") (inst_gf_lib_dir </> "prelude") copyAll "prelude" (rgl_dst_dir bi </> "prelude") (inst_gf_lib_dir </> "prelude")
sequence_ [copyAll (show mode) (getRGLBuildDir lbi mode) (inst_gf_lib_dir </> getRGLBuildSubDir lbi mode)|mode<-modes] sequence_ [copyAll (show mode) (getRGLBuildDir bi mode) (inst_gf_lib_dir </> getRGLBuildSubDir bi mode)|mode<-modes]
copyRGL args flags pkg lbi = do copyRGL args flags bi = do
let modes = getOptMode args let modes = getOptMode args
dest = case copyDest flags of dest = case copyDest flags of
NoFlag -> NoCopyDest NoFlag -> NoCopyDest
Flag d -> d Flag d -> d
let inst_gf_lib_dir = datadir (absoluteInstallDirs pkg lbi dest) </> "lib" let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi dest) </> "lib"
copyAll "prelude" (rgl_dst_dir lbi </> "prelude") (inst_gf_lib_dir </> "prelude") copyAll "prelude" (rgl_dst_dir bi </> "prelude") (inst_gf_lib_dir </> "prelude")
sequence_ [copyAll (show mode) (getRGLBuildDir lbi mode) (inst_gf_lib_dir </> getRGLBuildSubDir lbi mode)|mode<-modes] sequence_ [copyAll (show mode) (getRGLBuildDir bi mode) (inst_gf_lib_dir </> getRGLBuildSubDir bi mode)|mode<-modes]
copyAll s from to = do copyAll s from to = do
putStrLn $ "Installing [" ++ s ++ "] " ++ to putStrLn $ "Installing [" ++ s ++ "] " ++ to
@@ -170,8 +174,8 @@ sdistRGL pkg mb_lbi hooks flags = do
else return paths else return paths
else getRGLFiles path paths else getRGLFiles path paths
rgl_src_dir = "lib" </> "src" rgl_src_dir = "lib" </> "src"
rgl_dst_dir lbi = buildDir lbi </> "rgl" rgl_dst_dir (_,lbi) = buildDir lbi </> "rgl"
-- the languages have long directory names and short ISO codes (3 letters) -- the languages have long directory names and short ISO codes (3 letters)
-- we also give the decodings for postprocessing linearizations, as long as grammars -- we also give the decodings for postprocessing linearizations, as long as grammars
@@ -245,19 +249,20 @@ langsPGF = langsLang `except` ["Ara","Hin","Ron","Tha"]
-- languages for which Compatibility exists (to be extended) -- languages for which Compatibility exists (to be extended)
langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"] langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"]
gfc modes pkg lbi file = parallel_ [gfc1 mode pkg lbi file | mode<-modes] gfc bi modes summary files =
gfc1 mode pkg lbi file = do parallel_ [gfcn bi mode summary files | mode<-modes]
let dir = getRGLBuildDir lbi mode gfcn bi mode summary files = do
let dir = getRGLBuildDir bi mode
preproc = case mode of preproc = case mode of
AllTenses -> "" AllTenses -> ""
Present -> "-preproc="++({-rgl_src_dir </>-} "mkPresent") Present -> "-preproc="++({-rgl_src_dir </>-} "mkPresent")
createDirectoryIfMissing True dir createDirectoryIfMissing True dir
putStrLn $ "Compiling [" ++ show mode ++ "] " ++ file putStrLn $ "Compiling [" ++ show mode ++ "] " ++ summary
run_gfc pkg lbi ["-s", "-no-pmcfg", preproc, "--gfo-dir="++dir, file] run_gfc bi (["-s", "-no-pmcfg", preproc, "--gfo-dir="++dir] ++ files)
gf comm files pkg lbi = do gf bi comm files = do
putStrLn $ "Reading " ++ unwords files putStrLn $ "Reading " ++ unwords files
let gf = default_gf pkg lbi let gf = default_gf bi
putStrLn ("executing: " ++ comm ++ "\n" ++ putStrLn ("executing: " ++ comm ++ "\n" ++
"in " ++ gf) "in " ++ gf)
out <- readProcess gf ("-s":files) comm out <- readProcess gf ("-s":files) comm
@@ -307,13 +312,13 @@ getOptLangs defaultLangs args =
then findLangs langs [l]++ls then findLangs langs [l]++ls
else ls else ls
getRGLBuildSubDir lbi mode = getRGLBuildSubDir (_,lbi) mode =
case mode of case mode of
AllTenses -> "alltenses" AllTenses -> "alltenses"
Present -> "present" Present -> "present"
getRGLBuildDir lbi mode = rgl_dst_dir lbi </> getRGLBuildSubDir lbi mode getRGLBuildDir bi mode = rgl_dst_dir bi </> getRGLBuildSubDir bi mode
getRGLCommands args = getRGLCommands args =
let cmds0 = [cmd | arg <- args, let cmds0 = [cmd | arg <- args,
@@ -337,14 +342,15 @@ unlexer abstr ls =
unlex lla = maybe "" id $ lookup lla langsCoding unlex lla = maybe "" id $ lookup lla langsCoding
-- | Runs the gf executable in compile mode with the given arguments. -- | Runs the gf executable in compile mode with the given arguments.
run_gfc :: PackageDescription -> LocalBuildInfo -> [String] -> IO () run_gfc :: Info -> [String] -> IO ()
run_gfc pkg lbi args = run_gfc bi args =
do let args' = ["-batch","-gf-lib-path="++rgl_src_dir] do let args' = ["-batch","-gf-lib-path="++rgl_src_dir]
++ ["+RTS","-K32M","-RTS"] -- not needed with new-comp ++ ["+RTS","-A20M","-RTS"]
++ filter (not . null) args ++ filter (not . null) args
gf = default_gf pkg lbi gf = default_gf bi
gf_cmdline = gf ++ " " ++ unwords (map showArg args') gf_cmdline = gf ++ " " ++ unwords (map showArg args')
-- putStrLn $ "Running: " ++ gf_cmdline -- putStrLn $ "Running: " ++ gf_cmdline
appendFile "running" (gf_cmdline++"\n")
e <- rawSystem gf args' e <- rawSystem gf args'
case e of case e of
ExitSuccess -> return () ExitSuccess -> return ()
@@ -353,7 +359,7 @@ run_gfc pkg lbi args =
where where
showArg arg = if ' ' `elem` arg then "'" ++ arg ++ "'" else arg showArg arg = if ' ' `elem` arg then "'" ++ arg ++ "'" else arg
default_gf pkg lbi = buildDir lbi </> exeName' </> exeNameReal default_gf (_,lbi) = buildDir lbi </> exeName' </> exeNameReal
where where
exeName' = "gf" exeName' = "gf"
exeNameReal = exeName' <.> exeExtension exeNameReal = exeName' <.> exeExtension