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

Experimental: parallel batch compilation of grammars

Browse Source 
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.
This commit is contained in:
hallgren
2014-08-25 09:56:00 +00:00
parent 9253d54b7e
commit d84c5ef171
11 changed files with 420 additions and 178 deletions
Download Patch File Download Diff File Expand all files Collapse all files

68
Setup.hs
View File

@@ -9,11 +9,10 @@ import Data.List(isPrefixOf,intersect)
import Data.Maybe(listToMaybe) import Data.Maybe(listToMaybe)
--import System.IO --import System.IO
import qualified Control.Exception as E import qualified Control.Exception as E
import System.Process import System.Process(readProcess)
import System.FilePath import System.FilePath
import System.Directory import System.Directory
import System.Process --import System.Exit
import System.Exit
--import Control.Concurrent(forkIO) --import Control.Concurrent(forkIO)
--import Control.Concurrent.Chan(newChan,writeChan,readChan) --import Control.Concurrent.Chan(newChan,writeChan,readChan)
@@ -42,19 +41,19 @@ main = defaultMainWithHooks simpleUserHooks{ preBuild = gfPreBuild
gfPostBuild args flags pkg lbi = gfPostBuild args flags pkg lbi =
do --writeFile "running" "" do --writeFile "running" ""
buildRGL args flags (pkg,lbi) buildRGL args flags (flags,pkg,lbi)
-- let gf = default_gf (pkg,lbi) -- let gf = default_gf lbi
-- buildWeb gf (pkg,lbi) -- buildWeb gf (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 lbi
installWeb gf args flags (pkg,lbi) installWeb (pkg,lbi)
gfPostCopy args flags pkg lbi = gfPostCopy args flags pkg lbi =
do copyRGL args flags (pkg,lbi) do let gf = default_gf lbi
let gf = default_gf (pkg,lbi) copyRGL args flags (pkg,lbi)
copyWeb gf args flags (pkg,lbi) copyWeb flags (pkg,lbi)
-------------------------------------------------------- --------------------------------------------------------
-- Commands for building the Resource Grammar Library -- Commands for building the Resource Grammar Library
@@ -71,13 +70,16 @@ data RGLCommand
, cmdAction :: [Mode] -> [String] -> Info -> IO () , cmdAction :: [Mode] -> [String] -> Info -> IO ()
} }
type Info = (PackageDescription,LocalBuildInfo) type Info = (BuildFlags,PackageDescription,LocalBuildInfo)
bf (i,_,_) = i
--pd (_,i,_) = i
lbi (_,_,i) = i
rglCommands = rglCommands =
[ RGLCommand "prelude" True $ \mode args bi -> 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 bi </> "prelude" prelude_dst_dir = rgl_dst_dir (lbi bi) </> "prelude"
createDirectoryIfMissing True prelude_dst_dir createDirectoryIfMissing True prelude_dst_dir
files <- ls prelude_src_dir files <- ls prelude_src_dir
run_gfc bi (["-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])
@@ -86,11 +88,11 @@ rglCommands =
, RGLCommand "lang" False $ gfcp [l,s] , RGLCommand "lang" False $ gfcp [l,s]
, RGLCommand "api" False $ gfcp [t,sc] , RGLCommand "api" False $ gfcp [t,sc]
, RGLCommand "compat" False $ gfcp [c] , RGLCommand "compat" False $ gfcp [c]
, RGLCommand "web" True $ \ _ _ bi -> buildWeb (default_gf bi) bi , RGLCommand "web" True $ \ _ _ bi -> buildWeb (default_gf (lbi bi)) bi
, RGLCommand "pgf" False $ \modes args bi -> , RGLCommand "pgf" False $ \modes args bi ->
parallel_ [ parallel_ [
do let dir = getRGLBuildDir bi mode do let dir = getRGLBuildDir (lbi bi) mode
createDirectoryIfMissing True dir createDirectoryIfMissing True dir
sequence_ [run_gfc bi ["-s","-make","-name=Lang"++la, sequence_ [run_gfc bi ["-s","-make","-name=Lang"++la,
dir ++ "/Lang" ++ la ++ ".gfo"] dir ++ "/Lang" ++ la ++ ".gfo"]
@@ -146,8 +148,8 @@ buildRGL args flags bi = do
installRGL args flags bi = do installRGL args flags bi = do
let modes = getOptMode args let modes = getOptMode args
let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi NoCopyDest) </> "lib" let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi NoCopyDest) </> "lib"
copyAll "prelude" (rgl_dst_dir bi </> "prelude") (inst_gf_lib_dir </> "prelude") copyAll "prelude" (rgl_dst_dir (snd bi) </> "prelude") (inst_gf_lib_dir </> "prelude")
sequence_ [copyAll (show mode) (getRGLBuildDir bi mode) (inst_gf_lib_dir </> getRGLBuildSubDir bi mode)|mode<-modes] sequence_ [copyAll (show mode) (getRGLBuildDir (snd bi) mode) (inst_gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes]
copyRGL args flags bi = do copyRGL args flags bi = do
let modes = getOptMode args let modes = getOptMode args
@@ -155,8 +157,8 @@ copyRGL args flags bi = do
NoFlag -> NoCopyDest NoFlag -> NoCopyDest
Flag d -> d Flag d -> d
let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi dest) </> "lib" let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi dest) </> "lib"
copyAll "prelude" (rgl_dst_dir bi </> "prelude") (inst_gf_lib_dir </> "prelude") copyAll "prelude" (rgl_dst_dir (snd bi) </> "prelude") (inst_gf_lib_dir </> "prelude")
sequence_ [copyAll (show mode) (getRGLBuildDir bi mode) (inst_gf_lib_dir </> getRGLBuildSubDir bi mode)|mode<-modes] sequence_ [copyAll (show mode) (getRGLBuildDir (snd bi) mode) (inst_gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes]
copyAll s from to = do copyAll s from to = do
putStrLn $ "Installing [" ++ s ++ "] " ++ to putStrLn $ "Installing [" ++ s ++ "] " ++ to
@@ -181,7 +183,7 @@ sdistRGL pkg mb_lbi hooks flags = do
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
@@ -258,7 +260,7 @@ langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"]
gfc bi modes summary files = gfc bi modes summary files =
parallel_ [gfcn bi mode summary files | mode<-modes] parallel_ [gfcn bi mode summary files | mode<-modes]
gfcn bi mode summary files = do gfcn bi mode summary files = do
let dir = getRGLBuildDir bi mode let dir = getRGLBuildDir (lbi bi) mode
preproc = case mode of preproc = case mode of
AllTenses -> "" AllTenses -> ""
Present -> "-preproc="++({-rgl_src_dir </>-} "mkPresent") Present -> "-preproc="++({-rgl_src_dir </>-} "mkPresent")
@@ -268,7 +270,7 @@ gfcn bi mode summary files = do
gf bi comm files = do gf bi comm files = do
putStrLn $ "Reading " ++ unwords files putStrLn $ "Reading " ++ unwords files
let gf = default_gf bi let gf = default_gf (lbi 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
@@ -318,13 +320,14 @@ getOptLangs defaultLangs args =
then findLangs langs [l]++ls then findLangs langs [l]++ls
else ls else ls
getRGLBuildSubDir (_,lbi) mode = getRGLBuildSubDir mode =
case mode of case mode of
AllTenses -> "alltenses" AllTenses -> "alltenses"
Present -> "present" Present -> "present"
getRGLBuildDir bi mode = rgl_dst_dir bi </> getRGLBuildSubDir bi mode getRGLBuildDir :: LocalBuildInfo -> Mode -> FilePath
getRGLBuildDir lbi mode = rgl_dst_dir lbi </> getRGLBuildSubDir mode
getRGLCommands args = getRGLCommands args =
let cmds0 = [cmd | arg <- args, let cmds0 = [cmd | arg <- args,
@@ -350,22 +353,13 @@ unlexer abstr ls =
-- | Runs the gf executable in compile mode with the given arguments. -- | Runs the gf executable in compile mode with the given arguments.
run_gfc :: Info -> [String] -> IO () run_gfc :: Info -> [String] -> IO ()
run_gfc bi args = run_gfc bi args =
do let args' = ["-batch","-gf-lib-path="++rgl_src_dir] do let args' = numJobs (bf bi)++["-batch","-gf-lib-path="++rgl_src_dir]
++ ["+RTS","-A20M","-RTS"]
++ filter (not . null) args ++ filter (not . null) args
gf = default_gf bi gf = default_gf (lbi bi)
gf_cmdline = gf ++ " " ++ unwords (map showArg args') execute gf args'
-- putStrLn $ "Running: " ++ gf_cmdline
-- appendFile "running" (gf_cmdline++"\n")
e <- rawSystem gf args'
case e of
ExitSuccess -> return ()
ExitFailure i -> do putStrLn $ "Ran: " ++ gf_cmdline
die $ "gf exited with exit code: " ++ show i
where
showArg arg = if ' ' `elem` arg then "'" ++ arg ++ "'" else arg
default_gf (_,lbi) = buildDir lbi </> exeName' </> exeNameReal default_gf :: LocalBuildInfo -> FilePath
default_gf lbi = buildDir lbi </> exeName' </> exeNameReal
where where
exeName' = "gf" exeName' = "gf"
exeNameReal = exeName' <.> exeExtension exeNameReal = exeName' <.> exeExtension

59
WebSetup.hs
View File

@@ -1,11 +1,12 @@
module WebSetup(buildWeb,installWeb,copyWeb) where module WebSetup(buildWeb,installWeb,copyWeb,numJobs,execute) where
import System.Directory(createDirectoryIfMissing,copyFile,removeFile) import System.Directory(createDirectoryIfMissing,copyFile)
import System.FilePath((</>)) import System.FilePath((</>),dropExtension)
import System.Cmd(system) import System.Process(rawSystem)
import System.Exit(ExitCode(..)) import System.Exit(ExitCode(..))
import Distribution.Simple.Setup(Flag(..),CopyDest(..),copyDest) import Distribution.Simple.Setup(BuildFlags(..),Flag(..),CopyDest(..),copyDest)
import Distribution.Simple.LocalBuildInfo(datadir,buildDir,absoluteInstallDirs) import Distribution.Simple.LocalBuildInfo(datadir,buildDir,absoluteInstallDirs)
import Distribution.Simple.Utils(die)
{- {-
To test the GF web services, the minibar and the grammar editor, use To test the GF web services, the minibar and the grammar editor, use
@@ -33,7 +34,8 @@ example_grammars = -- :: [(pgf, subdir, src)]
letterSrc = ["Letter"++lang++".gf"|lang<-letterLangs] letterSrc = ["Letter"++lang++".gf"|lang<-letterLangs]
letterLangs = words "Eng Fin Fre Heb Rus Swe" letterLangs = words "Eng Fin Fre Heb Rus Swe"
buildWeb gf (pkg,lbi) =
buildWeb gf (flags,pkg,lbi) =
do --putStrLn "buildWeb" do --putStrLn "buildWeb"
mapM_ build_pgf example_grammars mapM_ build_pgf example_grammars
where where
@@ -42,26 +44,26 @@ buildWeb gf (pkg,lbi) =
build_pgf (pgf,subdir,src) = build_pgf (pgf,subdir,src) =
do createDirectoryIfMissing True tmp_dir do createDirectoryIfMissing True tmp_dir
putStrLn $ "Building "++pgf putStrLn $ "Building "++pgf
execute cmd execute gf args
where where
tmp_dir = gfo_dir</>subdir tmp_dir = gfo_dir</>subdir
dir = "examples"</>subdir dir = "examples"</>subdir
cmd = gf++" -make -s -optimize-pgf --gfo-dir="++tmp_dir++ args = numJobs flags++["-make","-s","-optimize-pgf"]
" --gf-lib-path="++buildDir lbi </> "rgl"++ ++["--gfo-dir="++tmp_dir,
" --output-dir="++gfo_dir++ "--gf-lib-path="++buildDir lbi </> "rgl",
" "++unwords [dir</>file|file<-src] "--name="++dropExtension pgf,
"--output-dir="++gfo_dir]
++[dir</>file|file<-src]
installWeb gf args flags = setupWeb gf args dest installWeb = setupWeb NoCopyDest
where
dest = NoCopyDest
copyWeb gf args flags = setupWeb gf args dest copyWeb flags = setupWeb dest
where where
dest = case copyDest flags of dest = case copyDest flags of
NoFlag -> NoCopyDest NoFlag -> NoCopyDest
Flag d -> d Flag d -> d
setupWeb gf args dest (pkg,lbi) = setupWeb dest (pkg,lbi) =
do mapM_ (createDirectoryIfMissing True) [grammars_dir,cloud_dir] do mapM_ (createDirectoryIfMissing True) [grammars_dir,cloud_dir]
mapM_ copy_pgf example_grammars mapM_ copy_pgf example_grammars
copyGFLogo copyGFLogo
@@ -83,10 +85,23 @@ setupWeb gf args dest (pkg,lbi) =
do createDirectoryIfMissing True logo_dir do createDirectoryIfMissing True logo_dir
copyFile ("doc"</>"Logos"</>gf_logo) (logo_dir</>gf_logo) copyFile ("doc"</>"Logos"</>gf_logo) (logo_dir</>gf_logo)
execute command = execute command args =
do --putStrLn command do let cmdline = command ++ " " ++ unwords (map showArg args)
e <- system command -- putStrLn $ "Running: " ++ cmdline
-- appendFile "running" (cmdline++"\n")
e <- rawSystem command args
case e of case e of
ExitSuccess -> return () ExitSuccess -> return ()
_ -> fail "Command failed" ExitFailure i -> do putStrLn $ "Ran: " ++ cmdline
return () die $ command++" exited with exit code: " ++ show i
where
showArg arg = if ' ' `elem` arg then "'" ++ arg ++ "'" else arg
numJobs flags =
if null n
then []
else ["-j=8"++n,"+RTS","-A20M","-N"++n,"-RTS"]
where
n = case buildNumJobs flags of
Flag mn | mn/=Just 1-> maybe "" show mn
_ -> ""

4
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -45,7 +45,7 @@ import Control.Monad.Identity
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- main conversion function -- main conversion function
generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule --generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
generatePMCFG opts sgr opath cmo@(cm,cmi) = do generatePMCFG opts sgr opath cmo@(cm,cmi) = do
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi) (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
when (verbAtLeast opts Verbose) $ ePutStrLn "" when (verbAtLeast opts Verbose) $ ePutStrLn ""
@@ -67,7 +67,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
return (a,(k,y):kys) return (a,(k,y):kys)
addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info) --addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...") --when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
let pres = protoFCat gr res val let pres = protoFCat gr res val

22
src/compiler/GF/Compile/GetGrammar.hs
View File

@@ -25,29 +25,29 @@ import GF.Grammar.Parser
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.CFG import GF.Grammar.CFG
import GF.Grammar.EBNF import GF.Grammar.EBNF
import GF.Compile.ReadFiles(parseSource,lift) import GF.Compile.ReadFiles(parseSource)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.Char(isAscii) import Data.Char(isAscii)
import Control.Monad (foldM,when,unless) import Control.Monad (foldM,when,unless)
import System.Process (system) import System.Process (system)
import System.Directory(removeFile,getCurrentDirectory) import GF.System.Directory(removeFile,getCurrentDirectory)
import System.FilePath(makeRelative) import System.FilePath(makeRelative)
getSourceModule :: Options -> FilePath -> IOE SourceModule --getSourceModule :: Options -> FilePath -> IOE SourceModule
getSourceModule opts file0 = getSourceModule opts file0 =
--errIn file0 $ --errIn file0 $
do tmp <- lift $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts) do tmp <- liftIO $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
raw <- lift $ keepTemp tmp raw <- liftIO $ keepTemp tmp
--ePutStrLn $ "1 "++file0 --ePutStrLn $ "1 "++file0
(optCoding,parsed) <- parseSource opts pModDef raw (optCoding,parsed) <- parseSource opts pModDef raw
case parsed of case parsed of
Left (Pn l c,msg) -> do file <- lift $ writeTemp tmp Left (Pn l c,msg) -> do file <- liftIO $ writeTemp tmp
cwd <- lift $ getCurrentDirectory cwd <- getCurrentDirectory
let location = makeRelative cwd file++":"++show l++":"++show c let location = makeRelative cwd file++":"++show l++":"++show c
raise (location++":\n "++msg) raise (location++":\n "++msg)
Right (i,mi0) -> Right (i,mi0) ->
do lift $ removeTemp tmp do liftIO $ removeTemp tmp
let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0} let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0) optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
case (optCoding,optCoding') of case (optCoding,optCoding') of
@@ -59,7 +59,7 @@ getSourceModule opts file0 =
raise $ "Encoding mismatch: "++coding++" /= "++coding' raise $ "Encoding mismatch: "++coding++" /= "++coding'
where coding = maybe defaultEncoding renameEncoding optCoding where coding = maybe defaultEncoding renameEncoding optCoding
_ -> return () _ -> return ()
--lift $ transcodeModule' (i,mi) -- old lexer --liftIO $ transcodeModule' (i,mi) -- old lexer
return (i,mi) -- new lexer return (i,mi) -- new lexer
getCFRules :: Options -> FilePath -> IOE [CFRule] getCFRules :: Options -> FilePath -> IOE [CFRule]
@@ -67,7 +67,7 @@ getCFRules opts fpath = do
raw <- liftIO (BS.readFile fpath) raw <- liftIO (BS.readFile fpath)
(optCoding,parsed) <- parseSource opts pCFRules raw (optCoding,parsed) <- parseSource opts pCFRules raw
case parsed of case parsed of
Left (Pn l c,msg) -> do cwd <- lift $ getCurrentDirectory Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
let location = makeRelative cwd fpath++":"++show l++":"++show c let location = makeRelative cwd fpath++":"++show l++":"++show c
raise (location++":\n "++msg) raise (location++":\n "++msg)
Right rules -> return rules Right rules -> return rules
@@ -77,7 +77,7 @@ getEBNFRules opts fpath = do
raw <- liftIO (BS.readFile fpath) raw <- liftIO (BS.readFile fpath)
(optCoding,parsed) <- parseSource opts pEBNFRules raw (optCoding,parsed) <- parseSource opts pEBNFRules raw
case parsed of case parsed of
Left (Pn l c,msg) -> do cwd <- lift $ getCurrentDirectory Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
let location = makeRelative cwd fpath++":"++show l++":"++show c let location = makeRelative cwd fpath++":"++show l++":"++show c
raise (location++":\n "++msg) raise (location++":\n "++msg)
Right rules -> return rules Right rules -> return rules

71
src/compiler/GF/Compile/ReadFiles.hs
View File

@@ -20,8 +20,8 @@
module GF.Compile.ReadFiles module GF.Compile.ReadFiles
( getAllFiles,ModName,ModEnv,importsOfModule, ( getAllFiles,ModName,ModEnv,importsOfModule,
parseSource,lift, findFile,gfImports,gfoImports,
getOptionsFromFile,getPragmas) where parseSource,getOptionsFromFile,getPragmas) where
import Prelude hiding (catch) import Prelude hiding (catch)
import GF.System.Catch import GF.System.Catch
@@ -32,15 +32,17 @@ import GF.Data.Operations
import GF.Grammar.Lexer import GF.Grammar.Lexer
import GF.Grammar.Parser import GF.Grammar.Parser
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Binary import GF.Grammar.Binary(decodeModuleHeader)
import System.IO(mkTextEncoding) import System.IO(mkTextEncoding)
import qualified Data.ByteString.UTF8 as UTF8
import GF.Text.Coding(decodeUnicodeIO) import GF.Text.Coding(decodeUnicodeIO)
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS
import Control.Monad import Control.Monad
import Data.Maybe(isJust) import Data.Maybe(isJust)
import qualified Data.ByteString.Char8 as BS import Data.Char(isSpace)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Time(UTCTime) import Data.Time(UTCTime)
import GF.System.Directory(getModificationTime,doesFileExist,canonicalizePath) import GF.System.Directory(getModificationTime,doesFileExist,canonicalizePath)
@@ -123,8 +125,8 @@ findFile gfoDir ps name =
maybe noSource haveSource =<< getFilePath ps (gfFile name) maybe noSource haveSource =<< getFilePath ps (gfFile name)
where where
haveSource gfFile = haveSource gfFile =
do gfTime <- modtime gfFile do gfTime <- getModificationTime gfFile
mb_gfoTime <- maybeIO $ modtime (gf2gfo' gfoDir gfFile) mb_gfoTime <- maybeIO $ getModificationTime (gf2gfo' gfoDir gfFile)
return (gfFile, Just gfTime, mb_gfoTime) return (gfFile, Just gfTime, mb_gfoTime)
noSource = noSource =
@@ -133,14 +135,12 @@ findFile gfoDir ps name =
gfoPath = maybe id (:) gfoDir ps gfoPath = maybe id (:) gfoDir ps
haveGFO gfoFile = haveGFO gfoFile =
do gfoTime <- modtime gfoFile do gfoTime <- getModificationTime gfoFile
return (gfoFile, Nothing, Just gfoTime) return (gfoFile, Nothing, Just gfoTime)
noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$ noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$
"searched in:" <+> vcat ps)) "searched in:" <+> vcat ps))
modtime path = getModificationTime path
gfImports opts file = importsOfModule `fmap` parseModHeader opts file gfImports opts file = importsOfModule `fmap` parseModHeader opts file
gfoImports gfo = fmap importsOfModule `fmap` liftIO (decodeModuleHeader gfo) gfoImports gfo = fmap importsOfModule `fmap` liftIO (decodeModuleHeader gfo)
@@ -216,7 +216,7 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
parseModHeader opts file = parseModHeader opts file =
do --ePutStrLn file do --ePutStrLn file
(_,parsed) <- parseSource opts pModHeader =<< lift (BS.readFile file) (_,parsed) <- parseSource opts pModHeader =<< liftIO (BS.readFile file)
case parsed of case parsed of
Right mo -> return mo Right mo -> return mo
Left (Pn l c,msg) -> Left (Pn l c,msg) ->
@@ -234,43 +234,44 @@ toUTF8 opts0 raw =
then return raw then return raw
else if coding=="CP1252" -- Latin1 else if coding=="CP1252" -- Latin1
then return . UTF8.fromString $ BS.unpack raw -- faster then return . UTF8.fromString $ BS.unpack raw -- faster
else lift $ else do --ePutStrLn $ "toUTF8 from "++coding
do --ePutStrLn $ "toUTF8 from "++coding recodeToUTF8 coding raw
enc <- mkTextEncoding coding
-- decodeUnicodeIO uses a lot of stack space,
-- so we need to split the file into smaller pieces
ls <- mapM (decodeUnicodeIO enc) (BS.lines raw)
return $ UTF8.fromString (unlines ls)
return (given,utf8) return (given,utf8)
--lift io = ioe (fmap Ok io `catch` (return . Bad . show)) recodeToUTF8 coding raw =
lift io = liftIO io liftIO $
do enc <- mkTextEncoding coding
-- decodeUnicodeIO uses a lot of stack space,
-- so we need to split the file into smaller pieces
ls <- mapM (decodeUnicodeIO enc) (BS.lines raw)
return $ UTF8.fromString (unlines ls)
-- | options can be passed to the compiler by comments in @--#@, in the main file -- | options can be passed to the compiler by comments in @--#@, in the main file
getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options --getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
getOptionsFromFile file = do getOptionsFromFile file = do
s <- either (\_ -> raise $ "File " ++ file ++ " does not exist") return =<< opts <- either failed getPragmas =<< (liftIO $ try $ BS.readFile file)
liftIO (try $ BS.readFile file)
opts <- getPragmas s
-- The coding flag should not be inherited by other files -- The coding flag should not be inherited by other files
return (addOptions opts (modifyFlags $ \ f -> f{optEncoding=Nothing})) return (addOptions opts (modifyFlags $ \ f -> f{optEncoding=Nothing}))
where
failed _ = raise $ "File " ++ file ++ " does not exist"
getPragmas :: (ErrorMonad m) => BS.ByteString -> m Options getPragmas :: (ErrorMonad m) => BS.ByteString -> m Options
getPragmas = parseModuleOptions . getPragmas = parseModuleOptions .
map (BS.unpack . BS.unwords . BS.words . BS.drop 3) . map (BS.unpack . BS.unwords . BS.words . BS.drop 3) .
filter (BS.isPrefixOf (BS.pack "--#")) . BS.lines filter (BS.isPrefixOf (BS.pack "--#")) .
-- takeWhile (BS.isPrefixOf (BS.pack "--")) .
-- filter (not . BS.null) .
map (BS.dropWhile isSpace) .
BS.lines
getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath) getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
getFilePath paths file = getFilePath paths file = get paths
liftIO $ do --ePutStrLn $ "getFilePath "++show paths++" "++show file
get paths
where where
get [] = return Nothing get [] = return Nothing
get (p:ps) = do get (p:ps) = do let pfile = p </> file
let pfile = p </> file exist <- doesFileExist pfile
exist <- doesFileExist pfile if not exist
if not exist then get ps
then get ps else do pfile <- canonicalizePath pfile
else do pfile <- canonicalizePath pfile return (Just pfile)
return (Just pfile)

218
src/compiler/GF/CompileInParallel.hs Normal file
View File

@@ -0,0 +1,218 @@
module GF.CompileInParallel where
import Control.Monad(join,ap,when,unless)
import Control.Applicative
import Control.Concurrent
import System.FilePath
import System.IO.Unsafe(unsafeInterleaveIO)
import qualified GF.System.Directory as D
import GF.System.Catch(catch)
import Data.List(nub,isPrefixOf,intercalate,partition)
import qualified Data.Map as M
import GF.Compile.ReadFiles(getOptionsFromFile,findFile,gfImports,gfoImports)
import GF.CompileOne(reuseGFO,useTheSource)
import GF.Infra.Option
import GF.Infra.UseIO
import GF.Data.Operations
import GF.Grammar.Grammar(emptySourceGrammar,prependModule,modules)
import GF.Infra.Ident(identS)
import GF.Text.Pretty
import qualified Data.ByteString.Lazy as BS
batchCompile jobs opts rootfiles0 =
do rootfiles <- mapM canonical rootfiles0
lib_dir <- canonical =<< getLibraryDirectory opts
filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
let groups = groupFiles lib_dir filepaths
n = length groups
when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"
(ts,sgrs) <- unzip <$> mapM (batchCompile1 lib_dir) groups
return (maximum ts,sgrs)
where
groupFiles lib_dir filepaths =
if length groups>1 then groups else [(opts,filepaths)]
where
groups = filter (not.null.snd) [(opts_p,present),(opts_a,alltenses)]
(present,alltenses) = partition usesPresent filepaths
gfoDir = flag optGFODir opts
gfo = maybe "" id gfoDir
opts_p = setGFO "present"
opts_a = setGFO "alltenses"
setGFO d = addOptions opts
(modifyFlags $ \ f->f{optGFODir=Just (gfo</>d)})
usesPresent (_,paths) = take 1 libs==["present"]
where
libs = [p|path<-paths,
let (d,p0) = splitAt n path
p = dropSlash p0,
d==lib_dir,p `elem` all_modes]
n = length lib_dir
all_modes = ["alltenses","present"]
dropSlash ('/':p) = p
dropSlash p = p
batchCompile1 lib_dir (opts,filepaths) =
do cwd <- D.getCurrentDirectory
let rel = relativeTo lib_dir cwd
prelude_dir = lib_dir</>"prelude"
gfoDir = flag optGFODir opts
maybe (return ()) (D.createDirectoryIfMissing True) gfoDir
prelude_files <- maybe [] id <$>
maybeIO (D.getDirectoryContents prelude_dir)
let fromPrelude f = lib_dir `isPrefixOf` f &&
takeFileName f `elem` prelude_files
ppPath ps = "-path="<>intercalate ":" (map rel ps)
logchan <- liftIO newChan
liftIO $ forkIO (mapM_ runIOE =<< getChanContents logchan)
let logStrLn = writeChan logchan . ePutStrLn
ok :: CollectOutput IOE a -> IO a
ok (CO m) = err bad good =<< appIOE m
where
good (o,r) = do writeChan logchan o; return r
bad e = do writeChan logchan (redPutStrLn e); fail "failed"
redPutStrLn s = do ePutStr "\ESC[31m";ePutStr s;ePutStrLn "\ESC[m"
sgr <- liftIO $ newMVar emptySourceGrammar
let extendSgr sgr m =
modifyMVar_ sgr $ \ gr ->
do let gr' = prependModule gr m
-- logStrLn $ "Finished "++show (length (modules gr'))++" modules."
return gr'
fcache <- liftIO $ newIOCache $ \ _ (imp,Hide (f,ps)) ->
do (file,_,_) <- runIOE $ findFile gfoDir ps imp
return (file,(f,ps))
let find f ps imp =
do (file',(f',ps')) <- liftIO $ readIOCache fcache (imp,Hide (f,ps))
when (ps'/=ps) $
do (file,_,_) <- findFile gfoDir ps imp
unless (file==file' || any fromPrelude [file,file']) $
do eq <- liftIO $ (==) <$> BS.readFile file <*> BS.readFile file'
unless eq $
fail $ render $
hang ("Ambiguous import of"<+>imp<>":") 4
(hang (rel file<+>"from"<+>rel f) 4 (ppPath ps)
$$
hang (rel file'<+>"from"<+>rel f') 4 (ppPath ps'))
return file'
compile cache (file,paths) = readIOCache cache (file,Hide paths)
compile' cache (f,Hide ps) =
do let compileImport f = compile cache (f,ps)
findImports (f,ps) = mapM (find f ps) . nub . snd
=<< getImports opts f
tis <- parMapM compileImport =<< ok (findImports (f,ps))
let reuse gfo = do t <- D.getModificationTime gfo
gr <- readMVar sgr
r <- lazyIO $ ok (reuseGFO opts gr gfo)
return (t,snd r)
compileSrc f =
do gr <- readMVar sgr
(Just gfo,mo) <- ok (useTheSource opts gr f)
t <- D.getModificationTime gfo
return (t,mo)
(t,mo) <- if isGFO f
then reuse f
else do ts <- D.getModificationTime f
let gfo = gf2gfo' gfoDir f
to <- maybeIO (D.getModificationTime gfo)
if to>=Just (maximum (ts:tis))
then reuse gfo
else compileSrc f
extendSgr sgr mo
return (maximum (t:tis))
cache <- liftIO $ newIOCache compile'
ts <- liftIO $ parMapM (compile cache) filepaths
gr <- liftIO $ readMVar sgr
let cnc = identS (justModuleName (fst (last filepaths)))
return (maximum ts,(cnc,gr))
parMapM f xs =
do vs <- mapM (const newEmptyMVar) xs
sequence_ [ forkIO (putMVar v =<< f x) | (v,x) <- zip vs xs]
mapM takeMVar vs
lazyIO = unsafeInterleaveIO
canonical path = liftIO $ D.canonicalizePath path `catch` const (return path)
getPathFromFile lib_dir cmdline_opts file =
do --file <- getRealFile file
file_opts <- getOptionsFromFile file
let file_dir = dropFileName file
opts = addOptions (fixRelativeLibPaths file_dir lib_dir file_opts)
cmdline_opts
paths <- mapM canonical . nub . (file_dir :) =<< extendPathEnv opts
return (file,nub paths)
getImports opts file =
if isGFO file then gfoImports' file else gfImports opts file
where
gfoImports' file = maybe bad return =<< gfoImports file
where bad = raise $ file++": bad .gfo file"
relativeTo lib_dir cwd path =
if length librel<length cwdrel then librel else cwdrel
where
librel = "%"</>makeRelative lib_dir path
cwdrel = makeRelative cwd path
--------------------------------------------------------------------------------
data IOCache arg res
= IOCache { op::arg->IO res,
cache::MVar (M.Map arg (MVar res)) }
newIOCache op =
do v <- newMVar M.empty
let cache = IOCache (op cache) v
return cache
readIOCache (IOCache op cacheVar) arg =
join $ modifyMVar cacheVar $ \ cache ->
case M.lookup arg cache of
Nothing -> do v <- newEmptyMVar
let doit = do res <- op arg
putMVar v res
return res
return (M.insert arg v cache,doit)
Just v -> do return (cache,readMVar v)
newtype Hide a = Hide {reveal::a}
instance Eq (Hide a) where _ == _ = True
instance Ord (Hide a) where compare _ _ = EQ
--------------------------------------------------------------------------------
newtype CollectOutput m a = CO {unCO::m (m (),a)}
{-
runCO (CO m) = do (o,x) <- m
o
return x
-}
instance Functor m => Functor (CollectOutput m) where
fmap f (CO m) = CO (fmap (fmap f) m)
instance (Functor m,Monad m) => Applicative (CollectOutput m) where
pure = return
(<*>) = ap
instance Monad m => Monad (CollectOutput m) where
return x = CO (return (return (),x))
CO m >>= f = CO $ do (o1,x) <- m
let CO m2 = f x
(o2,y) <- m2
return (o1>>o2,y)
instance MonadIO m => MonadIO (CollectOutput m) where
liftIO io = CO $ do x <- liftIO io
return (return (),x)
instance Output m => Output (CollectOutput m) where
ePutStr s = CO (return (ePutStr s,()))
ePutStrLn s = CO (return (ePutStrLn s,()))
putStrLnE s = CO (return (putStrLnE s,()))
putStrE s = CO (return (putStrE s,()))
instance ErrorMonad m => ErrorMonad (CollectOutput m) where
raise e = CO (raise e)
handle (CO m) h = CO $ handle m (unCO . h)

49
src/compiler/GF/CompileOne.hs
View File

@@ -1,8 +1,7 @@
module GF.CompileOne(OneOutput,CompiledModule, module GF.CompileOne(OneOutput,CompiledModule,
compileOne --, CompileSource, compileSourceModule compileOne,reuseGFO,useTheSource
--, CompileSource, compileSourceModule
) where ) where
import Prelude hiding (catch)
import GF.System.Catch
-- The main compiler passes -- The main compiler passes
import GF.Compile.GetGrammar(getSourceModule) import GF.Compile.GetGrammar(getSourceModule)
@@ -19,7 +18,7 @@ import GF.Grammar.Printer(ppModule,TermPrintQual(..))
import GF.Grammar.Binary(decodeModule,encodeModule) import GF.Grammar.Binary(decodeModule,encodeModule)
import GF.Infra.Option import GF.Infra.Option
import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,liftIO,ePutStrLn,putPointE,putStrE) import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,liftIO,Output(..),putPointE)
import GF.Infra.CheckM(runCheck') import GF.Infra.CheckM(runCheck')
import GF.Data.Operations(liftErr,(+++)) import GF.Data.Operations(liftErr,(+++))
@@ -33,27 +32,13 @@ type CompiledModule = SourceModule
-- | Compile a given source file (or just load a .gfo file), -- | Compile a given source file (or just load a .gfo file),
-- given a 'SourceGrammar' containing everything it depends on. -- given a 'SourceGrammar' containing everything it depends on.
compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput --compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
compileOne opts srcgr file = compileOne opts srcgr file =
if isGFO file if isGFO file
then reuseGFO opts srcgr file then reuseGFO opts srcgr file
else do b1 <- doesFileExist file else do b1 <- doesFileExist file
if b1 then useTheSource if b1 then useTheSource opts srcgr file
else reuseGFO opts srcgr (gf2gfo opts file) else reuseGFO opts srcgr (gf2gfo opts file)
where
-- | For gf source, do full compilation and generate code
useTheSource =
do sm <- putpOpt ("- parsing" +++ file)
("- compiling" +++ file ++ "... ")
(getSourceModule opts file)
idump opts Source sm
cwd <- getCurrentDirectory
compileSourceModule opts cwd (Just file) srcgr sm
putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v act
| verbAtLeast opts Normal = putStrE m >> act
| otherwise = putPointE Verbose opts v act
-- | For compiled gf, read the file and update environment -- | For compiled gf, read the file and update environment
-- also undo common subexp optimization, to enable normal computations -- also undo common subexp optimization, to enable normal computations
@@ -76,9 +61,24 @@ reuseGFO opts srcgr file =
return (Just file,sm) return (Just file,sm)
-- | For gf source, do full compilation and generate code
--useTheSource :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
useTheSource opts srcgr file =
do sm <- putpOpt ("- parsing" +++ file)
("- compiling" +++ file ++ "... ")
(getSourceModule opts file)
idump opts Source sm
cwd <- getCurrentDirectory
compileSourceModule opts cwd (Just file) srcgr sm
where
putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v act
| verbAtLeast opts Normal = putStrE m >> act
| otherwise = putPointE Verbose opts v act
type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput
compileSourceModule :: Options -> FilePath -> Maybe FilePath -> CompileSource --compileSourceModule :: Options -> FilePath -> Maybe FilePath -> CompileSource
compileSourceModule opts cwd mb_gfFile gr = compileSourceModule opts cwd mb_gfFile gr =
if flag optTagsOnly opts if flag optTagsOnly opts
then generateTags <=< ifComplete middle <=< frontend then generateTags <=< ifComplete middle <=< frontend
@@ -128,7 +128,7 @@ compileSourceModule opts cwd mb_gfFile gr =
maybeM f = maybe (return ()) f maybeM f = maybe (return ()) f
writeGFO :: Options -> FilePath -> SourceModule -> IOE () --writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
writeGFO opts file mo = writeGFO opts file mo =
putPointE Normal opts (" write file" +++ file) $ putPointE Normal opts (" write file" +++ file) $
liftIO $ encodeModule file mo2 liftIO $ encodeModule file mo2
@@ -139,7 +139,7 @@ writeGFO opts file mo =
notAnyInd x = case x of AnyInd{} -> False; _ -> True notAnyInd x = case x of AnyInd{} -> False; _ -> True
-- to output an intermediate stage -- to output an intermediate stage
intermOut :: Options -> Dump -> Doc -> IOE () --intermOut :: Options -> Dump -> Doc -> IOE ()
intermOut opts d doc intermOut opts d doc
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc)) | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
| otherwise = return () | otherwise = return ()
@@ -148,9 +148,8 @@ idump opts pass = intermOut opts (Dump pass) . ppModule Internal
warnOut opts warnings warnOut opts warnings
| null warnings = return () | null warnings = return ()
| otherwise = liftIO $ ePutStrLn ws `catch` oops | otherwise = do ePutStr "\ESC[34m";ePutStr ws;ePutStrLn "\ESC[m"
where where
oops _ = ePutStrLn "" -- prevent crash on character encoding problem
ws = if flag optVerbosity opts == Normal ws = if flag optVerbosity opts == Normal
then '\n':warnings then '\n':warnings
else warnings else warnings

9
src/compiler/GF/Infra/Option.hs
View File

@@ -172,8 +172,8 @@ data Flags = Flags {
optTagsOnly :: Bool, optTagsOnly :: Bool,
optHeuristicFactor :: Maybe Double, optHeuristicFactor :: Maybe Double,
optMetaProb :: Maybe Double, optMetaProb :: Maybe Double,
optMetaToknProb :: Maybe Double{-, optMetaToknProb :: Maybe Double,
optNewComp :: Bool-} optJobs :: Maybe (Maybe String)
} }
deriving (Show) deriving (Show)
@@ -284,7 +284,8 @@ defaultFlags = Flags {
optTagsOnly = False, optTagsOnly = False,
optHeuristicFactor = Nothing, optHeuristicFactor = Nothing,
optMetaProb = Nothing, optMetaProb = Nothing,
optMetaToknProb = Nothing optMetaToknProb = Nothing,
optJobs = Nothing
} }
-- | Option descriptions -- | Option descriptions
@@ -297,6 +298,7 @@ optDescr =
Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.", Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.",
Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.", Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
Option [] ["server"] (OptArg modeServer "port") $ Option [] ["server"] (OptArg modeServer "port") $
@@ -387,6 +389,7 @@ optDescr =
ms = mode . ModeServer ms = mode . ModeServer
readPort p = maybe err ms (readMaybe p) readPort p = maybe err ms (readMaybe p)
where err = fail $ "Bad server port: "++p where err = fail $ "Bad server port: "++p
jobs mv = set $ \ o -> o { optJobs = Just mv }
verbosity mv = case mv of verbosity mv = case mv of
Nothing -> set $ \o -> o { optVerbosity = Verbose } Nothing -> set $ \o -> o { optVerbosity = Verbose }
Just v -> case readMaybe v >>= toEnumBounded of Just v -> case readMaybe v >>= toEnumBounded of

76
src/compiler/GF/Infra/UseIO.hs
View File

@@ -1,4 +1,3 @@
{-# OPTIONS -cpp #-}
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | -- |
-- Module : UseIO -- Module : UseIO
@@ -22,7 +21,7 @@ import GF.Infra.Option
import GF.System.Catch import GF.System.Catch
import Paths_gf(getDataDir) import Paths_gf(getDataDir)
import System.Directory import GF.System.Directory
import System.FilePath import System.FilePath
import System.IO import System.IO
import System.IO.Error(isUserError,ioeGetErrorString) import System.IO.Error(isUserError,ioeGetErrorString)
@@ -36,24 +35,9 @@ import Control.Monad
import Control.Monad.Trans(MonadIO(..)) import Control.Monad.Trans(MonadIO(..))
import Control.Exception(evaluate) import Control.Exception(evaluate)
--putShow' :: Show a => (c -> a) -> c -> IO () --putIfVerb :: MonadIO io => Options -> String -> io ()
--putShow' f = putStrLn . show . length . show . f putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg
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
-}
type FileName = String type FileName = String
type InitPath = String -- ^ the directory portion of a pathname type InitPath = String -- ^ the directory portion of a pathname
type FullPath = String type FullPath = String
@@ -68,8 +52,8 @@ getLibraryDirectory opts =
Nothing -> liftIO $ catch (getEnv gfLibraryPath) Nothing -> liftIO $ catch (getEnv gfLibraryPath)
(\ex -> fmap (</> "lib") getDataDir) (\ex -> fmap (</> "lib") getDataDir)
getGrammarPath :: FilePath -> IO [FilePath] getGrammarPath :: MonadIO io => FilePath -> io [FilePath]
getGrammarPath lib_dir = do getGrammarPath lib_dir = liftIO $ do
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) catch (fmap splitSearchPath $ getEnv gfGrammarPathVar)
(\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"]) -- e.g. GF_GRAMMAR_PATH (\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"]) -- e.g. GF_GRAMMAR_PATH
@@ -110,15 +94,14 @@ getSubdirs dir = do
justModuleName :: FilePath -> String justModuleName :: FilePath -> String
justModuleName = dropExtension . takeFileName justModuleName = dropExtension . takeFileName
isGFO :: FilePath -> Bool isGF,isGFO :: FilePath -> Bool
isGF = (== ".gf") . takeExtensions
isGFO = (== ".gfo") . takeExtensions isGFO = (== ".gfo") . takeExtensions
gfoFile :: FilePath -> FilePath gfFile,gfoFile :: FilePath -> FilePath
gfFile f = addExtension f "gf"
gfoFile f = addExtension f "gfo" gfoFile f = addExtension f "gfo"
gfFile :: FilePath -> FilePath
gfFile f = addExtension f "gf"
gf2gfo :: Options -> FilePath -> FilePath gf2gfo :: Options -> FilePath -> FilePath
gf2gfo = gf2gfo' . flag optGFODir gf2gfo = gf2gfo' . flag optGFODir
@@ -143,6 +126,8 @@ newtype IOE a = IOE { appIOE :: IO (Err a) }
ioe :: IO (Err a) -> IOE a ioe :: IO (Err a) -> IOE a
ioe = IOE ioe = IOE
runIOE m = err fail return =<< appIOE m
instance MonadIO IOE where liftIO io = ioe (io >>= return . return) instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
instance ErrorMonad IOE where instance ErrorMonad IOE where
@@ -162,11 +147,11 @@ instance Monad IOE where
appIOE $ err raise f x -- f :: a -> IOE a appIOE $ err raise f x -- f :: a -> IOE a
fail = raise fail = raise
maybeIO io = either (const Nothing) Just `fmap` liftIO (try io)
useIOE :: a -> IOE a -> IO a useIOE :: a -> IOE a -> IO a
useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return 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 :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
foldIOE f s xs = case xs of foldIOE f s xs = case xs of
[] -> return (s,Nothing) [] -> return (s,Nothing)
@@ -180,27 +165,42 @@ die :: String -> IO a
die s = do hPutStrLn stderr s die s = do hPutStrLn stderr s
exitFailure exitFailure
ePutStr, ePutStrLn, putStrE, putStrLnE :: MonadIO m => String -> m () class Monad m => Output m where
ePutStr s = liftIO $ hPutStr stderr s ePutStr, ePutStrLn, putStrE, putStrLnE :: String -> m ()
ePutStrLn s = liftIO $ hPutStrLn stderr s
putStrLnE s = liftIO $ putStrLn s >> hFlush stdout
putStrE s = liftIO $ putStr s >> hFlush stdout
putPointE :: MonadIO m => Verbosity -> Options -> String -> m a -> m a 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
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 putPointE v opts msg act = do
when (verbAtLeast opts v) $ putStrE msg when (verbAtLeast opts v) $ putStrE msg
t1 <- liftIO $ getCPUTime (t,a) <- timeIt act
a <- act >>= liftIO . evaluate
t2 <- liftIO $ getCPUTime
if flag optShowCPUTime opts if flag optShowCPUTime opts
then do let msec = (t2 - t1) `div` 1000000000 then do let msec = t `div` 1000000000
putStrLnE (printf " %5d msec" msec) putStrLnE (printf " %5d msec" msec)
else when (verbAtLeast opts v) $ putStrLnE "" else when (verbAtLeast opts v) $ putStrLnE ""
return a return a
timeIt act =
do t1 <- liftIO $ getCPUTime
a <- liftIO . evaluate =<< act
t2 <- liftIO $ getCPUTime
return (t2-t1,a)
-- * File IO -- * File IO
writeUTF8File :: FilePath -> String -> IO () writeUTF8File :: FilePath -> String -> IO ()

9
src/compiler/GF/System/Directory.hs
View File

@@ -4,10 +4,14 @@ module GF.System.Directory(module GF.System.Directory,module D) where
import Control.Monad.Trans(MonadIO(..)) import Control.Monad.Trans(MonadIO(..))
import qualified System.Directory as D import qualified System.Directory as D
import System.Directory as D import System.Directory as D
hiding (doesDirectoryExist,doesFileExist,getModificationTime, hiding (canonicalizePath,createDirectoryIfMissing,
getCurrentDirectory,getDirectoryContents,removeFile) doesDirectoryExist,doesFileExist,getModificationTime,
getCurrentDirectory,getDirectoryContents,getPermissions,
removeFile)
import Data.Time.Compat import Data.Time.Compat
canonicalizePath path = liftIO $ D.canonicalizePath path
createDirectoryIfMissing b = liftIO . D.createDirectoryIfMissing b
doesDirectoryExist path = liftIO $ D.doesDirectoryExist path doesDirectoryExist path = liftIO $ D.doesDirectoryExist path
doesFileExist path = liftIO $ D.doesFileExist path doesFileExist path = liftIO $ D.doesFileExist path
getModificationTime path = liftIO $ fmap toUTCTime (D.getModificationTime path) getModificationTime path = liftIO $ fmap toUTCTime (D.getModificationTime path)
@@ -15,5 +19,6 @@ getDirectoryContents path = liftIO $ D.getDirectoryContents path
getCurrentDirectory :: MonadIO io => io FilePath getCurrentDirectory :: MonadIO io => io FilePath
getCurrentDirectory = liftIO D.getCurrentDirectory getCurrentDirectory = liftIO D.getCurrentDirectory
getPermissions path = liftIO $ D.getPermissions path
removeFile path = liftIO $ D.removeFile path removeFile path = liftIO $ D.removeFile path

13
src/compiler/GFC.hs
View File

@@ -4,7 +4,8 @@ module GFC (mainGFC, writePGF) where
import PGF import PGF
import PGF.Internal(concretes,optimizePGF,unionPGF) import PGF.Internal(concretes,optimizePGF,unionPGF)
import PGF.Internal(putSplitAbs,encodeFile,runPut) import PGF.Internal(putSplitAbs,encodeFile,runPut)
import GF.Compile import GF.Compile as S(batchCompile,link,srcAbsName)
import qualified GF.CompileInParallel as P(batchCompile)
import GF.Compile.Export import GF.Compile.Export
import GF.Compile.CFGtoPGF import GF.Compile.CFGtoPGF
import GF.Compile.GetGrammar import GF.Compile.GetGrammar
@@ -41,7 +42,7 @@ mainGFC opts fs = do
compileSourceFiles :: Options -> [FilePath] -> IOE () compileSourceFiles :: Options -> [FilePath] -> IOE ()
compileSourceFiles opts fs = compileSourceFiles opts fs =
do cnc_gr@(cnc,t_src,gr) <- batchCompile opts fs do (t_src,~cnc_grs@(~(cnc,gr):_)) <- batchCompile opts fs
unless (flag optStopAfterPhase opts == Compile) $ unless (flag optStopAfterPhase opts == Compile) $
do let abs = showIdent (srcAbsName gr cnc) do let abs = showIdent (srcAbsName gr cnc)
pgfFile = outputPath opts (grammarName' opts abs<.>"pgf") pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -50,9 +51,15 @@ compileSourceFiles opts fs =
else return Nothing else return Nothing
if t_pgf >= Just t_src if t_pgf >= Just t_src
then putIfVerb opts $ pgfFile ++ " is up-to-date." then putIfVerb opts $ pgfFile ++ " is up-to-date."
else do pgf <- link opts cnc_gr else do pgfs <- mapM (link opts)
[(cnc,t_src,gr)|(cnc,gr)<-cnc_grs]
let pgf = foldl1 unionPGF pgfs
writePGF opts pgf writePGF opts pgf
writeOutputs opts pgf writeOutputs opts pgf
where
batchCompile = maybe batchCompile' P.batchCompile (flag optJobs opts)
batchCompile' opts fs = do (cnc,t,gr) <- S.batchCompile opts fs
return (t,[(cnc,gr)])
compileCFFiles :: Options -> [FilePath] -> IOE () compileCFFiles :: Options -> [FilePath] -> IOE ()
compileCFFiles opts fs = do compileCFFiles opts fs = do