From d84c5ef1715c3e4aed4098ee9c847e2dcc86cba4 Mon Sep 17 00:00:00 2001 From: hallgren Date: Mon, 25 Aug 2014 09:56:00 +0000 Subject: Experimental: parallel batch compilation of grammars On my laptop these changes speed up the full build of the RGL and example grammars with 'cabal build' from ~95s to ~43s and the zero build from ~18s to ~5s. The main change is the introduction of the module GF.CompileInParallel that replaces GF.Compile and the function GF.Compile.ReadFiles.getAllFiles. At present, it is activated with the new -j flag, and it is only used when combined with --make or --batch. In addition, to get parallel computations, you need to add GHC run-time flags, e.g., +RTS -N -A20M -RTS, to the command line. The Setup.hs script has been modified to pass the appropriate flags to GF for parallel compilation when compiling the RGL and example grammars, but you need a recent version of Cabal for this to work (probably >=1.20). Some additonal refactoring were made during this work. A new monad is used to avoid warnings/error messages from different modules to be intertwined when compiling in parallel, so some functios that were hardiwred to the IO or IOE monads have been lifted to work in arbitrary monads that are instances in the appropriate classes. --- src/compiler/GF/Infra/UseIO.hs | 78 +++++++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 39 deletions(-) (limited to 'src/compiler/GF/Infra/UseIO.hs') diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index a0a36ad52..6de68bc44 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/src/compiler/GF/Infra/UseIO.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -cpp #-} ---------------------------------------------------------------------- -- | -- Module : UseIO @@ -22,7 +21,7 @@ import GF.Infra.Option import GF.System.Catch import Paths_gf(getDataDir) -import System.Directory +import GF.System.Directory import System.FilePath import System.IO import System.IO.Error(isUserError,ioeGetErrorString) @@ -36,24 +35,9 @@ import Control.Monad import Control.Monad.Trans(MonadIO(..)) import Control.Exception(evaluate) ---putShow' :: Show a => (c -> a) -> c -> IO () ---putShow' f = putStrLn . show . length . show . f - -putIfVerb :: MonadIO io => Options -> String -> io () -putIfVerb opts msg = - when (verbAtLeast opts Verbose) $ liftIO $ putStrLn msg - -putIfVerbW :: MonadIO io => Options -> String -> io () -putIfVerbW opts msg = - when (verbAtLeast opts Verbose) $ liftIO $ putStr (' ' : msg) -{- -errOptIO :: Options -> a -> Err a -> IO a -errOptIO os e m = case m of - Ok x -> return x - Bad k -> do - putIfVerb os k - return e --} +--putIfVerb :: MonadIO io => Options -> String -> io () +putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg + type FileName = String type InitPath = String -- ^ the directory portion of a pathname type FullPath = String @@ -68,8 +52,8 @@ getLibraryDirectory opts = Nothing -> liftIO $ catch (getEnv gfLibraryPath) (\ex -> fmap ( "lib") getDataDir) -getGrammarPath :: FilePath -> IO [FilePath] -getGrammarPath lib_dir = do +getGrammarPath :: MonadIO io => FilePath -> io [FilePath] +getGrammarPath lib_dir = liftIO $ do catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_dir "alltenses",lib_dir "prelude"]) -- e.g. GF_GRAMMAR_PATH @@ -110,15 +94,14 @@ getSubdirs dir = do justModuleName :: FilePath -> String justModuleName = dropExtension . takeFileName -isGFO :: FilePath -> Bool +isGF,isGFO :: FilePath -> Bool +isGF = (== ".gf") . takeExtensions isGFO = (== ".gfo") . takeExtensions -gfoFile :: FilePath -> FilePath +gfFile,gfoFile :: FilePath -> FilePath +gfFile f = addExtension f "gf" gfoFile f = addExtension f "gfo" -gfFile :: FilePath -> FilePath -gfFile f = addExtension f "gf" - gf2gfo :: Options -> FilePath -> FilePath gf2gfo = gf2gfo' . flag optGFODir @@ -143,6 +126,8 @@ newtype IOE a = IOE { appIOE :: IO (Err a) } ioe :: IO (Err a) -> IOE a ioe = IOE +runIOE m = err fail return =<< appIOE m + instance MonadIO IOE where liftIO io = ioe (io >>= return . return) instance ErrorMonad IOE where @@ -162,11 +147,11 @@ instance Monad IOE where appIOE $ err raise f x -- f :: a -> IOE a fail = raise -maybeIO io = either (const Nothing) Just `fmap` liftIO (try io) - useIOE :: a -> IOE a -> IO a useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return +maybeIO io = either (const Nothing) Just `fmap` liftIO (try io) + --foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) foldIOE f s xs = case xs of [] -> return (s,Nothing) @@ -180,27 +165,42 @@ die :: String -> IO a die s = do hPutStrLn stderr s exitFailure -ePutStr, ePutStrLn, putStrE, putStrLnE :: MonadIO m => String -> m () -ePutStr s = liftIO $ hPutStr stderr s -ePutStrLn s = liftIO $ hPutStrLn stderr s -putStrLnE s = liftIO $ putStrLn s >> hFlush stdout -putStrE s = liftIO $ putStr s >> hFlush stdout +class Monad m => Output m where + ePutStr, ePutStrLn, putStrE, putStrLnE :: String -> m () + +instance Output IO where + ePutStr s = hPutStr stderr s `catch` oops + where oops _ = return () -- prevent crash on character encoding problem + ePutStrLn s = hPutStrLn stderr s `catch` oops + where oops _ = ePutStrLn "" -- prevent crash on character encoding problem + putStrLnE s = putStrLn s >> hFlush stdout + putStrE s = putStr s >> hFlush stdout -putPointE :: MonadIO m => Verbosity -> Options -> String -> m a -> m a +instance Output IOE where + ePutStr = liftIO . ePutStr + ePutStrLn = liftIO . ePutStrLn + putStrLnE = liftIO . putStrLnE + putStrE = liftIO . putStrE + +--putPointE :: Verbosity -> Options -> String -> IO a -> IO a putPointE v opts msg act = do when (verbAtLeast opts v) $ putStrE msg - t1 <- liftIO $ getCPUTime - a <- act >>= liftIO . evaluate - t2 <- liftIO $ getCPUTime + (t,a) <- timeIt act if flag optShowCPUTime opts - then do let msec = (t2 - t1) `div` 1000000000 + then do let msec = t `div` 1000000000 putStrLnE (printf " %5d msec" msec) else when (verbAtLeast opts v) $ putStrLnE "" return a +timeIt act = + do t1 <- liftIO $ getCPUTime + a <- liftIO . evaluate =<< act + t2 <- liftIO $ getCPUTime + return (t2-t1,a) + -- * File IO writeUTF8File :: FilePath -> String -> IO () -- cgit v1.2.3