From 4adb4bab7170245e0b2b28245f96e3ceea58ca87 Mon Sep 17 00:00:00 2001 From: hallgren Date: Mon, 28 Jul 2014 15:11:58 +0000 Subject: [PATCH] Setup.hs: reduce zero build time by ~30% (from 26 to 18 seconds on my laptop) 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.) --- Setup.hs | 138 +++++++++++++++++++++++++++++-------------------------- 1 file changed, 72 insertions(+), 66 deletions(-) diff --git a/Setup.hs b/Setup.hs index 7d6aafa4a..42f8b182b 100644 --- a/Setup.hs +++ b/Setup.hs @@ -23,14 +23,13 @@ tryIOE :: IO a -> IO (Either E.IOException a) tryIOE = E.try main :: IO () -main = defaultMainWithHooks simpleUserHooks{ preBuild =gfPreBuild - , postBuild=gfPostBuild - , preInst =gfPreInst - , postInst =gfPostInst - , preCopy =const . checkRGLArgs - , postCopy =gfPostCopy - , sDistHook=sdistRGL --- , runTests =testRGL +main = defaultMainWithHooks simpleUserHooks{ preBuild = gfPreBuild + , postBuild = gfPostBuild + , preInst = gfPreInst + , postInst = gfPostInst + , preCopy = const . checkRGLArgs + , postCopy = gfPostCopy + , sDistHook = sdistRGL } where gfPreBuild args = gfPre args . buildDistPref @@ -42,18 +41,19 @@ main = defaultMainWithHooks simpleUserHooks{ preBuild =gfPreBuild return h gfPostBuild args flags pkg lbi = - do buildRGL args flags pkg lbi - let gf = default_gf pkg lbi + do writeFile "running" "" + buildRGL args flags (pkg,lbi) + let gf = default_gf (pkg,lbi) buildWeb gf args flags pkg lbi gfPostInst args flags pkg lbi = - do installRGL args flags pkg lbi - let gf = default_gf pkg lbi + do installRGL args flags (pkg,lbi) + let gf = default_gf (pkg,lbi) installWeb gf args flags pkg lbi gfPostCopy args flags pkg lbi = - do copyRGL args flags pkg lbi - let gf = default_gf pkg lbi + do copyRGL args flags (pkg,lbi) + let gf = default_gf (pkg,lbi) copyWeb gf args flags pkg lbi -------------------------------------------------------- @@ -68,49 +68,53 @@ data RGLCommand = RGLCommand { cmdName :: String , cmdIsDef :: Bool - , cmdAction :: [Mode] -> [String] -> PackageDescription -> LocalBuildInfo -> IO () + , cmdAction :: [Mode] -> [String] -> Info -> IO () } +type Info = (PackageDescription,LocalBuildInfo) + rglCommands = - [ RGLCommand "prelude" True $ \mode args pkg lbi -> do + [ RGLCommand "prelude" True $ \mode args bi -> do putStrLn $ "Compiling [prelude]" - let prelude_src_dir = rgl_src_dir "prelude" - prelude_dst_dir = rgl_dst_dir lbi "prelude" + let prelude_src_dir = rgl_src_dir "prelude" + prelude_dst_dir = rgl_dst_dir bi "prelude" createDirectoryIfMissing True prelude_dst_dir files <- ls prelude_src_dir - run_gfc pkg lbi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir file | file <- files]) - , RGLCommand "lang" True $ \modes args pkg lbi -> do - parallel_ - [do mapM_ (gfc1 mode pkg lbi . lang) (optml mode langsLang args) - mapM_ (gfc1 mode pkg lbi . symbol) (optml mode langsAPI args) - | mode <- modes] - , RGLCommand "compat" True $ \modes args pkg lbi -> do - mapM_ (gfc modes pkg lbi . compat) (optl langsCompat args) - , RGLCommand "api" True $ \modes args pkg lbi -> do - parallel_ - [do mapM_ (gfc1 mode pkg lbi . try) (optml mode langsAPI args) - mapM_ (gfc1 mode pkg lbi . symbolic) (optml mode langsSymbolic args) - | mode <- modes] - , RGLCommand "pgf" False $ \modes args pkg lbi -> + run_gfc bi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir file | file <- files]) + , RGLCommand "lang" True $ \modes args bi -> + parallel_ [gfcn bi mode (summary lang++" "++summary symbol) files + | mode <- modes, + let files = map lang (optml mode langsLang args)++ + map symbol (optml mode langsAPI args)] + , RGLCommand "compat" True $ \modes args bi -> + gfc bi modes (summary compat) (map compat (optl langsCompat args)) + , RGLCommand "api" True $ \modes args bi -> + parallel_ [gfcn bi mode (summary try++" "++summary symbolic) files + | mode <- modes, + let files = map try (optml mode langsAPI args) ++ + map symbolic (optml mode langsSymbolic args)] + , RGLCommand "pgf" False $ \modes args bi -> parallel_ [ - do let dir = getRGLBuildDir lbi mode + do let dir = getRGLBuildDir bi mode 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"] | (_,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]) | mode <- modes] - , RGLCommand "demo" False $ \modes args pkg lbi -> do + , RGLCommand "demo" False $ \modes args bi -> do 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 () - , RGLCommand "parse" False $ \mode args pkg lbi -> do - mapM_ (gfc mode pkg lbi . parse) (optl langsParse args) - , RGLCommand "none" False $ \mode args pkg lbi -> do + , RGLCommand "parse" False $ \mode args bi -> + gfc bi mode (summary parse) (map parse (optl langsParse args)) + , RGLCommand "none" False $ \mode args bi -> return () ] where + summary f = f ("*","*") + optl = optml AllTenses optml mode ls args = getOptLangs (shrink ls) args where @@ -128,25 +132,25 @@ checkRGLArgs args = do putStrLn $ "Unrecognised flags: " ++ intercalate ", " args' return emptyHookedBuildInfo -buildRGL args flags pkg lbi = do +buildRGL args flags bi = do let cmds = getRGLCommands 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 inst_gf_lib_dir = datadir (absoluteInstallDirs pkg lbi NoCopyDest) "lib" - copyAll "prelude" (rgl_dst_dir lbi "prelude") (inst_gf_lib_dir "prelude") - sequence_ [copyAll (show mode) (getRGLBuildDir lbi mode) (inst_gf_lib_dir getRGLBuildSubDir lbi mode)|mode<-modes] + let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi NoCopyDest) "lib" + copyAll "prelude" (rgl_dst_dir bi "prelude") (inst_gf_lib_dir "prelude") + 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 dest = case copyDest flags of NoFlag -> NoCopyDest Flag d -> d - let inst_gf_lib_dir = datadir (absoluteInstallDirs pkg lbi dest) "lib" - copyAll "prelude" (rgl_dst_dir lbi "prelude") (inst_gf_lib_dir "prelude") - sequence_ [copyAll (show mode) (getRGLBuildDir lbi mode) (inst_gf_lib_dir getRGLBuildSubDir lbi mode)|mode<-modes] + let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi dest) "lib" + copyAll "prelude" (rgl_dst_dir bi "prelude") (inst_gf_lib_dir "prelude") + sequence_ [copyAll (show mode) (getRGLBuildDir bi mode) (inst_gf_lib_dir getRGLBuildSubDir bi mode)|mode<-modes] copyAll s from to = do putStrLn $ "Installing [" ++ s ++ "] " ++ to @@ -170,8 +174,8 @@ sdistRGL pkg mb_lbi hooks flags = do else return paths else getRGLFiles path paths -rgl_src_dir = "lib" "src" -rgl_dst_dir lbi = buildDir lbi "rgl" +rgl_src_dir = "lib" "src" +rgl_dst_dir (_,lbi) = buildDir lbi "rgl" -- the languages have long directory names and short ISO codes (3 letters) -- 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) langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"] -gfc modes pkg lbi file = parallel_ [gfc1 mode pkg lbi file | mode<-modes] -gfc1 mode pkg lbi file = do - let dir = getRGLBuildDir lbi mode +gfc bi modes summary files = + parallel_ [gfcn bi mode summary files | mode<-modes] +gfcn bi mode summary files = do + let dir = getRGLBuildDir bi mode preproc = case mode of AllTenses -> "" Present -> "-preproc="++({-rgl_src_dir -} "mkPresent") createDirectoryIfMissing True dir - putStrLn $ "Compiling [" ++ show mode ++ "] " ++ file - run_gfc pkg lbi ["-s", "-no-pmcfg", preproc, "--gfo-dir="++dir, file] + putStrLn $ "Compiling [" ++ show mode ++ "] " ++ summary + 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 - let gf = default_gf pkg lbi + let gf = default_gf bi putStrLn ("executing: " ++ comm ++ "\n" ++ "in " ++ gf) out <- readProcess gf ("-s":files) comm @@ -307,13 +312,13 @@ getOptLangs defaultLangs args = then findLangs langs [l]++ls else ls -getRGLBuildSubDir lbi mode = +getRGLBuildSubDir (_,lbi) mode = case mode of AllTenses -> "alltenses" Present -> "present" -getRGLBuildDir lbi mode = rgl_dst_dir lbi getRGLBuildSubDir lbi mode +getRGLBuildDir bi mode = rgl_dst_dir bi getRGLBuildSubDir bi mode getRGLCommands args = let cmds0 = [cmd | arg <- args, @@ -337,14 +342,15 @@ unlexer abstr ls = unlex lla = maybe "" id $ lookup lla langsCoding -- | Runs the gf executable in compile mode with the given arguments. -run_gfc :: PackageDescription -> LocalBuildInfo -> [String] -> IO () -run_gfc pkg lbi args = +run_gfc :: Info -> [String] -> IO () +run_gfc bi args = 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 - gf = default_gf pkg lbi + gf = default_gf bi gf_cmdline = gf ++ " " ++ unwords (map showArg args') -- putStrLn $ "Running: " ++ gf_cmdline + appendFile "running" (gf_cmdline++"\n") e <- rawSystem gf args' case e of ExitSuccess -> return () @@ -353,7 +359,7 @@ run_gfc pkg lbi args = where 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 exeName' = "gf" exeNameReal = exeName' <.> exeExtension