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

GF.CompileOne: refactoring to reduce code duplication and improve readability

Browse Source 
I prefer small functions with descriptive names over large monilithic chunks
of code, so I grouped the compiler passes called from compileSourceModule
into funcitons named frontend, middle and backend. This also makes decisions
about which passes to run clearly visible up front.

Also made some small changes in GF.Compile.
This commit is contained in:
hallgren
2014-08-20 17:04:15 +00:00
parent be301d8a5e
commit ff960a27b8
2 changed files with 67 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
src/compiler/GF/Compile.hs
View File

@@ -14,7 +14,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
justModuleName,extendPathEnv,putStrE,putPointE) justModuleName,extendPathEnv,putStrE,putPointE)
import GF.Data.Operations(raise,(+++),err) import GF.Data.Operations(raise,(+++),err)
import Control.Monad(foldM,when) import Control.Monad(foldM,when,(<=<))
import GF.System.Directory(doesFileExist,getModificationTime) import GF.System.Directory(doesFileExist,getModificationTime)
import System.FilePath((</>),isRelative,dropFileName) import System.FilePath((</>),isRelative,dropFileName)
import qualified Data.Map as Map(empty,insert,elems) --lookup import qualified Data.Map as Map(empty,insert,elems) --lookup
@@ -69,7 +69,7 @@ compileModule opts1 env@(_,rfs) file =
do file <- getRealFile file do file <- getRealFile file
opts0 <- getOptionsFromFile file opts0 <- getOptionsFromFile file
let curr_dir = dropFileName file let curr_dir = dropFileName file
lib_dir <- liftIO $ getLibraryDirectory (addOptions opts0 opts1) lib_dir <- getLibraryDirectory (addOptions opts0 opts1)
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1 let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
ps0 <- extendPathEnv opts ps0 <- extendPathEnv opts
let ps = nub (curr_dir : ps0) let ps = nub (curr_dir : ps0)
@@ -85,7 +85,7 @@ compileModule opts1 env@(_,rfs) file =
if exists if exists
then return file then return file
else if isRelative file else if isRelative file
then do lib_dir <- liftIO $ getLibraryDirectory opts1 then do lib_dir <- getLibraryDirectory opts1
let file1 = lib_dir </> file let file1 = lib_dir </> file
exists <- liftIO $ doesFileExist file1 exists <- liftIO $ doesFileExist file1
if exists if exists
@@ -94,24 +94,21 @@ compileModule opts1 env@(_,rfs) file =
else raise (render ("File" <+> file <+> "does not exist.")) else raise (render ("File" <+> file <+> "does not exist."))
compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne' opts env@(srcgr,_) file = compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr
extendCompileEnv env =<< compileOne opts srcgr file
-- auxiliaries -- auxiliaries
--reverseModules (MGrammar ms) = MGrammar $ reverse ms
-- | The environment -- | The environment
type CompileEnv = (SourceGrammar,ModEnv) type CompileEnv = (SourceGrammar,ModEnv)
emptyCompileEnv :: CompileEnv emptyCompileEnv :: CompileEnv
emptyCompileEnv = (emptySourceGrammar,Map.empty) emptyCompileEnv = (emptySourceGrammar,Map.empty)
extendCompileEnv (gr,menv) (mfile,mo) = do extendCompileEnv (gr,menv) (mfile,mo) =
menv2 <- case mfile of do menv2 <- case mfile of
Just file -> do Just file ->
let (mod,imps) = importsOfModule mo do let (mod,imps) = importsOfModule mo
t <- liftIO $ getModificationTime file t <- liftIO $ getModificationTime file
return $ Map.insert mod (t,imps) menv return $ Map.insert mod (t,imps) menv
_ -> return menv _ -> return menv
return (prependModule gr mo,menv2) --- reverse later return (prependModule gr mo,menv2)

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

@@ -1,5 +1,5 @@
module GF.CompileOne(OneOutput,CompiledModule, module GF.CompileOne(OneOutput,CompiledModule,
compileOne --, compileSourceModule compileOne --, CompileSource, compileSourceModule
) where ) where
import Prelude hiding (catch) import Prelude hiding (catch)
import GF.System.Catch import GF.System.Catch
@@ -19,15 +19,14 @@ 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,gf2gfo,liftIO,ePutStrLn,putPointE,putStrE) import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,liftIO,ePutStrLn,putPointE,putStrE)
import GF.Infra.CheckM(runCheck) import GF.Infra.CheckM(runCheck)
import GF.Data.Operations(liftErr,(+++)) import GF.Data.Operations(liftErr,(+++))
import GF.System.Directory(doesFileExist,getCurrentDirectory) import GF.System.Directory(doesFileExist,getCurrentDirectory)
import System.FilePath(dropFileName,dropExtension,takeExtensions)
import qualified Data.Map as Map import qualified Data.Map as Map
import GF.Text.Pretty(Doc,render,(<+>),($$)) import GF.Text.Pretty(Doc,render,(<+>),($$))
import Control.Monad((<=<))
type OneOutput = (Maybe FullPath,CompiledModule) type OneOutput = (Maybe FullPath,CompiledModule)
type CompiledModule = SourceModule type CompiledModule = SourceModule
@@ -35,31 +34,27 @@ 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 = do compileOne opts srcgr file =
if isGFO file
then reuseGFO opts srcgr file
else do b1 <- liftIO $ doesFileExist file
if b1 then useTheSource
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 <- liftIO getCurrentDirectory
compileSourceModule opts cwd (Just file) srcgr sm
let putpOpt v m act putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v act | verbAtLeast opts Verbose = putPointE Normal opts v act
| verbAtLeast opts Normal = putStrE m >> act | verbAtLeast opts Normal = putStrE m >> act
| otherwise = putPointE Verbose opts v act | otherwise = putPointE Verbose opts v act
let path = dropFileName file
let name = dropExtension file
case takeExtensions file of
".gfo" -> reuseGFO opts srcgr file
_ -> do
-- for gf source, do full compilation and generate code
b1 <- liftIO $ doesFileExist file
if not b1
then compileOne opts srcgr $ (gf2gfo opts file)
else do
sm <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ")
$ getSourceModule opts file
intermOut opts (Dump Source) (ppModule Internal sm)
compileSourceModule opts srcgr (Just file) sm
-- | 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
reuseGFO opts srcgr file = reuseGFO opts srcgr file =
@@ -67,7 +62,7 @@ reuseGFO opts srcgr file =
liftIO (decodeModule file) liftIO (decodeModule file)
let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts}) let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts})
intermOut opts (Dump Source) (ppModule Internal sm0) idump opts Source sm0
let sm1 = unsubexpModule sm0 let sm1 = unsubexpModule sm0
cwd <- liftIO getCurrentDirectory cwd <- liftIO getCurrentDirectory
@@ -81,30 +76,31 @@ reuseGFO opts srcgr file =
return (Just file,sm) return (Just file,sm)
compileSourceModule :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE OneOutput type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput
compileSourceModule opts gr mb_gfFile mo0 = do
cwd <- liftIO getCurrentDirectory compileSourceModule :: Options -> FilePath -> Maybe FilePath -> CompileSource
mo1 <- runPass Extend "" . extendModule cwd gr compileSourceModule opts cwd mb_gfFile gr =
=<< runPass Rebuild "" (rebuildModule cwd gr mo0) if flag optTagsOnly opts
then generateTags <=< ifComplete middle <=< frontend
case mo1 of else generateGFO <=< ifComplete (backend <=< middle) <=< frontend
(_,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 where
compileCompleteModule mo3 = do -- Apply to all modules
mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3 frontend = runPass Extend "" . extendModule cwd gr
mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts <=< runPass Rebuild "" . rebuildModule cwd gr
then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
else runPass2' "" $ return mo4
generateGFO mo5
------------------------------ -- Apply to complete modules
generateTagsOr compile = middle = runPass TypeCheck "type checking" . checkModule opts cwd gr
if flag optTagsOnly opts then generateTags else compile <=< runPass Rename "renaming" . renameModule cwd gr
-- Apply to complete modules when not generating tags
backend mo3 =
do mo4 <- runPassE id Optimize "optimizing" $ optimizeModule opts gr mo3
if isModCnc (snd mo4) && flag optPMCFG opts
then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
else runPassI "" $ return mo4
ifComplete yes mo@(_,mi) =
if isCompleteModule mi then yes mo else return mo
generateGFO mo = generateGFO mo =
do let mb_gfo = fmap (gf2gfo opts) mb_gfFile do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
@@ -116,30 +112,31 @@ compileSourceModule opts gr mb_gfFile mo0 = do
return (Nothing,mo) return (Nothing,mo)
putpp s = if null s then id else putPointE Verbose opts (" "++s++" ") putpp s = if null s then id else putPointE Verbose opts (" "++s++" ")
idump pass = intermOut opts (Dump pass) . ppModule Internal
-- * Impedance matching -- * Running a compiler pass, with impedance matching
runPass = runPass' fst fst snd (liftErr . runCheck) runPass = runPass' fst fst snd (liftErr . runCheck)
runPass2 = runPass2e liftErr runPassE = runPass2e liftErr
runPass2' = runPass2e id id Canon runPassI = runPass2e id id Canon
runPass2e lift f = runPass' id f (const "") lift runPass2e lift f = runPass' id f (const "") lift
runPass' ret dump warn lift pass pp m = runPass' ret dump warn lift pass pp m =
do out <- putpp pp $ lift m do out <- putpp pp $ lift m
warnOut opts (warn out) warnOut opts (warn out)
idump pass (dump out) idump opts pass (dump out)
return (ret out) return (ret out)
maybeM f = maybe (return ()) f maybeM f = maybe (return ()) f
writeGFO :: Options -> FilePath -> SourceModule -> IOE () writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
writeGFO opts file mo = do writeGFO opts file mo =
let mo1 = subexpModule mo putPointE Normal opts (" write file" +++ file) $
mo2 = case mo1 of liftIO $ encodeModule file mo2
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)}) where
putPointE Normal opts (" write file" +++ file) $ liftIO $ encodeModule file mo2 mo2 = (m,mi{jments=Map.filter notAnyInd (jments mi)})
(m,mi) = subexpModule mo
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 ()
@@ -147,6 +144,8 @@ 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 ()
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 = liftIO $ ePutStrLn ws `catch` oops