mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-03 00:02:50 -06:00
Refactoring in GF.Compile and GF.ReadFiles with an eye to parallel compilation
In particular, the function compileOne has been moved to the new module
GF.CompileOne and its type has been changed from
compileOne :: ... -> CompileEnv -> FilePath -> IOE CompileEnv
to
compileOne :: ... -> SourceGrammar -> FilePath -> IOE OneCompiledModule
making it more suitable for use in a parallel compiler.
This commit is contained in:
hallgren
@@ -1,41 +1,29 @@
|
||||
module GF.Compile (batchCompile, link, srcAbsName, compileToPGF) where
|
||||
import Prelude hiding (catch)
|
||||
import GF.System.Catch
|
||||
|
||||
-- the main compiler passes
|
||||
import GF.Compile.GetGrammar
|
||||
import GF.Compile.Rename
|
||||
import GF.Compile.CheckGrammar
|
||||
import GF.Compile.Optimize(optimizeModule)
|
||||
import GF.Compile.SubExOpt
|
||||
import GF.Compile.GeneratePMCFG
|
||||
import GF.Compile.GrammarToPGF
|
||||
import GF.Compile.ReadFiles
|
||||
import GF.Compile.Update
|
||||
--import GF.Compile.Refresh
|
||||
import GF.Compile.Tags
|
||||
import GF.Compile.GrammarToPGF(mkCanon2pgf)
|
||||
import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
|
||||
importsOfModule)
|
||||
import GF.CompileOne(compileOne)
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Printer
|
||||
import GF.Grammar.Binary
|
||||
import GF.Grammar.Grammar(SourceGrammar,msrc,modules,emptySourceGrammar,
|
||||
abstractOfConcrete,prependModule)
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Ident(Ident,identS,showIdent)
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.UseIO
|
||||
import GF.Infra.CheckM
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
|
||||
justModuleName,extendPathEnv,putStrE,putPointE)
|
||||
import GF.Data.Operations(raise,(+++),err)
|
||||
|
||||
import Control.Monad
|
||||
import GF.System.Directory
|
||||
import System.FilePath
|
||||
import qualified Data.Map as Map
|
||||
--import qualified Data.Set as Set
|
||||
import Control.Monad(foldM,when)
|
||||
import GF.System.Directory(doesFileExist,getModificationTime)
|
||||
import System.FilePath((</>),isRelative,dropFileName)
|
||||
import qualified Data.Map as Map(empty,insert,lookup,elems)
|
||||
import Data.List(nub)
|
||||
import Data.Time(UTCTime)
|
||||
import GF.Text.Pretty
|
||||
import GF.Text.Pretty(render,($$),(<+>),nest)
|
||||
|
||||
import PGF.Internal(optimizePGF)
|
||||
import PGF
|
||||
import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
|
||||
|
||||
-- | Compiles a number of source files and builds a 'PGF' structure for them.
|
||||
compileToPGF :: Options -> [FilePath] -> IOE PGF
|
||||
@@ -70,21 +58,6 @@ compileSourceGrammar opts gr = do
|
||||
return gr'
|
||||
-}
|
||||
|
||||
-- to output an intermediate stage
|
||||
intermOut :: Options -> Dump -> Doc -> IOE ()
|
||||
intermOut opts d doc
|
||||
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
|
||||
| otherwise = return ()
|
||||
|
||||
warnOut opts warnings
|
||||
| null warnings = return ()
|
||||
| otherwise = liftIO $ ePutStrLn ws `catch` oops
|
||||
where
|
||||
oops _ = ePutStrLn "" -- prevent crash on character encoding problem
|
||||
ws = if flag optVerbosity opts == Normal
|
||||
then '\n':warnings
|
||||
else warnings
|
||||
|
||||
-- | compile with one module as starting point
|
||||
-- command-line options override options (marked by --#) in the file
|
||||
-- As for path: if it is read from file, the file path is prepended to each name.
|
||||
@@ -92,21 +65,20 @@ warnOut opts warnings
|
||||
|
||||
compileModule :: Options -- ^ Options from program command line and shell command.
|
||||
-> CompileEnv -> FilePath -> IOE CompileEnv
|
||||
compileModule opts1 env file = do
|
||||
file <- getRealFile file
|
||||
opts0 <- getOptionsFromFile file
|
||||
let curr_dir = dropFileName file
|
||||
lib_dir <- liftIO $ getLibraryDirectory (addOptions opts0 opts1)
|
||||
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
|
||||
ps0 <- extendPathEnv opts
|
||||
let ps = nub (curr_dir : ps0)
|
||||
putIfVerb opts $ "module search path:" +++ show ps ----
|
||||
let (sgr,rfs) = env
|
||||
files <- getAllFiles opts ps rfs file
|
||||
putIfVerb opts $ "files to read:" +++ show files ----
|
||||
let names = map justModuleName files
|
||||
putIfVerb opts $ "modules to include:" +++ show names ----
|
||||
foldM (compileOne opts) (sgr,rfs) files
|
||||
compileModule opts1 env@(_,rfs) file =
|
||||
do file <- getRealFile file
|
||||
opts0 <- getOptionsFromFile file
|
||||
let curr_dir = dropFileName file
|
||||
lib_dir <- liftIO $ getLibraryDirectory (addOptions opts0 opts1)
|
||||
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
|
||||
ps0 <- extendPathEnv opts
|
||||
let ps = nub (curr_dir : ps0)
|
||||
putIfVerb opts $ "module search path:" +++ show ps ----
|
||||
files <- getAllFiles opts ps rfs file
|
||||
putIfVerb opts $ "files to read:" +++ show files ----
|
||||
let names = map justModuleName files
|
||||
putIfVerb opts $ "modules to include:" +++ show names ----
|
||||
foldM (compileOne' opts) env files
|
||||
where
|
||||
getRealFile file = do
|
||||
exists <- liftIO $ doesFileExist file
|
||||
@@ -121,112 +93,9 @@ compileModule opts1 env file = do
|
||||
else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
|
||||
else raise (render ("File" <+> file <+> "does not exist."))
|
||||
|
||||
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
|
||||
compileOne opts env@(srcgr,_) file = do
|
||||
|
||||
let putpOpt v m act
|
||||
| verbAtLeast opts Verbose = putPointE Normal opts v act
|
||||
| verbAtLeast opts Normal = putStrE m >> act
|
||||
| otherwise = putPointE Verbose opts v act
|
||||
|
||||
let path = dropFileName file
|
||||
let name = dropExtension file
|
||||
cwd <- liftIO getCurrentDirectory
|
||||
|
||||
case takeExtensions file of
|
||||
|
||||
-- for compiled gf, read the file and update environment
|
||||
-- also undo common subexp optimization, to enable normal computations
|
||||
".gfo" -> do
|
||||
sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ liftIO (decodeModule file)
|
||||
let sm0 = (fst sm00, (snd sm00) {mflags = mflags (snd sm00) `addOptions` opts})
|
||||
|
||||
intermOut opts (Dump Source) (ppModule Internal sm0)
|
||||
|
||||
let sm1 = unsubexpModule sm0
|
||||
(sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -}
|
||||
runCheck $ extendModule cwd srcgr sm1
|
||||
warnOut opts warnings
|
||||
|
||||
if flag optTagsOnly opts
|
||||
then writeTags opts srcgr (gf2gftags opts file) sm1
|
||||
else return ()
|
||||
|
||||
extendCompileEnv env (Just file) sm
|
||||
|
||||
-- for gf source, do full compilation and generate code
|
||||
_ -> do
|
||||
|
||||
b1 <- liftIO $ doesFileExist file
|
||||
if not b1
|
||||
then compileOne opts env $ (gf2gfo opts file)
|
||||
else do
|
||||
|
||||
sm <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ")
|
||||
$ getSourceModule opts file
|
||||
intermOut opts (Dump Source) (ppModule Internal sm)
|
||||
|
||||
compileSourceModule opts cwd env (Just file) sm
|
||||
where
|
||||
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
|
||||
|
||||
compileSourceModule :: Options -> FilePath -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
|
||||
compileSourceModule opts cwd env@(gr,_) mb_gfFile mo0 = do
|
||||
|
||||
mo1 <- runPass Extend "" . extendModule cwd gr
|
||||
=<< runPass Rebuild "" (rebuildModule cwd gr mo0)
|
||||
|
||||
case mo1 of
|
||||
(_,n) | not (isCompleteModule n) -> generateTagsOr generateGFO mo1
|
||||
_ -> do
|
||||
mo2 <- runPass Rename "renaming" $ renameModule cwd gr mo1
|
||||
mo3 <- runPass TypeCheck "type checking" $ checkModule opts cwd gr mo2
|
||||
generateTagsOr compileCompleteModule mo3
|
||||
where
|
||||
compileCompleteModule mo3 = do
|
||||
mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3
|
||||
mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
|
||||
then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
|
||||
else runPass2' "" $ return mo4
|
||||
generateGFO mo5
|
||||
|
||||
------------------------------
|
||||
generateTagsOr compile =
|
||||
if flag optTagsOnly opts then generateTags else compile
|
||||
|
||||
generateGFO mo =
|
||||
do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
|
||||
maybeM (flip (writeGFO opts) mo) mb_gfo
|
||||
extendCompileEnv env mb_gfo mo
|
||||
|
||||
generateTags mo =
|
||||
do maybeM (flip (writeTags opts gr) mo . gf2gftags opts) mb_gfFile
|
||||
extendCompileEnv env Nothing mo
|
||||
|
||||
putpp s = if null s then id else putPointE Verbose opts (" "++s++" ")
|
||||
idump pass = intermOut opts (Dump pass) . ppModule Internal
|
||||
|
||||
-- * Impedance matching
|
||||
runPass = runPass' fst fst snd (liftErr . runCheck)
|
||||
runPass2 = runPass2e liftErr
|
||||
runPass2' = runPass2e id id Canon
|
||||
runPass2e lift f = runPass' id f (const "") lift
|
||||
|
||||
runPass' ret dump warn lift pass pp m =
|
||||
do out <- putpp pp $ lift m
|
||||
warnOut opts (warn out)
|
||||
idump pass (dump out)
|
||||
return (ret out)
|
||||
|
||||
maybeM f = maybe (return ()) f
|
||||
|
||||
|
||||
writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
|
||||
writeGFO opts file mo = do
|
||||
let mo1 = subexpModule mo
|
||||
mo2 = case mo1 of
|
||||
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
|
||||
putPointE Normal opts (" write file" +++ file) $ liftIO $ encodeModule file mo2
|
||||
compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
|
||||
compileOne' opts env@(srcgr,_) file =
|
||||
extendCompileEnv env =<< compileOne opts srcgr file
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
@@ -238,7 +107,7 @@ type CompileEnv = (SourceGrammar,ModEnv)
|
||||
emptyCompileEnv :: CompileEnv
|
||||
emptyCompileEnv = (emptySourceGrammar,Map.empty)
|
||||
|
||||
extendCompileEnv (gr,menv) mfile mo = do
|
||||
extendCompileEnv (gr,menv) (mfile,mo) = do
|
||||
menv2 <- case mfile of
|
||||
Just file -> do
|
||||
let (mod,imps) = importsOfModule mo
|
||||
|
||||
Reference in New Issue
Block a user