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

Refactor compileSourceModule

Browse Source 
There was 55 lines of rather repetitive code with calls to 6 compiler passes.
They have been replaced with 19 lines that call the 6 compiler passes
plus 26 lines of helper functions.
This commit is contained in:
hallgren
2012-10-19 20:14:11 +00:00
parent 885aaca6de
commit d0e1187b10
3 changed files with 52 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -4,7 +4,7 @@ module GF.Compile (batchCompile, link, compileToPGF, compileSourceGrammar) where
import GF.Compile.GetGrammar import GF.Compile.GetGrammar
import GF.Compile.Rename import GF.Compile.Rename
import GF.Compile.CheckGrammar import GF.Compile.CheckGrammar
import GF.Compile.Optimize import GF.Compile.Optimize(optimizeModule)
import GF.Compile.SubExOpt import GF.Compile.SubExOpt
import GF.Compile.GeneratePMCFG import GF.Compile.GeneratePMCFG
import GF.Compile.GrammarToPGF import GF.Compile.GrammarToPGF
@@ -146,7 +146,7 @@ compileOne opts env@(_,srcgr,_) file = do
sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ ioeIO (decodeModule file) sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ ioeIO (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 DumpSource (ppModule Internal sm0) intermOut opts (Dump Source) (ppModule Internal sm0)
let sm1 = unsubexpModule sm0 let sm1 = unsubexpModule sm0
(sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ runCheck $ extendModule srcgr sm1 (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ runCheck $ extendModule srcgr sm1
@@ -171,7 +171,7 @@ compileOne opts env@(_,srcgr,_) file = do
enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00)))) enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00))))
let sm = decodeStringsInModule enc sm00 let sm = decodeStringsInModule enc sm00
intermOut opts DumpSource (ppModule Internal sm) intermOut opts (Dump Source) (ppModule Internal sm)
compileSourceModule opts env (Just file) sm compileSourceModule opts env (Just file) sm
where where
@@ -180,60 +180,53 @@ compileOne opts env@(_,srcgr,_) file = do
compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
let putpp = putPointE Verbose opts mo1 <- runPass Rebuild "" (rebuildModule gr mo)
mo1b <- runPass Extend "" (extendModule gr mo1)
(mo1,warnings) <- ioeErr $ runCheck $ rebuildModule gr mo
warnOut opts warnings
intermOut opts DumpRebuild (ppModule Internal mo1)
(mo1b,warnings) <- ioeErr $ runCheck $ extendModule gr mo1
warnOut opts warnings
intermOut opts DumpExtend (ppModule Internal mo1b)
case mo1b of case mo1b of
(_,n) | not (isCompleteModule n) -> (_,n) | not (isCompleteModule n) ->
if not (flag optTagsOnly opts) if tagsFlag then generateTags k mo1b else generateGFO k mo1b
then do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
case mb_gfo of
Just gfo -> writeGFO opts gfo mo1b
Nothing -> return ()
extendCompileEnvInt env k mb_gfo mo1b
else do case mb_gfFile of
Just gfFile -> writeTags opts gr (gf2gftags opts gfFile) mo1b
Nothing -> return ()
extendCompileEnvInt env k Nothing mo1b
_ -> do _ -> do
mo2 <- runPass Rename "renaming" $ renameModule gr mo1b
mo3 <- runPass TypeCheck "type checking" $ checkModule opts gr mo2
if tagsFlag then generateTags k mo3 else compileCompleteModule k mo3
where
compileCompleteModule k mo3 = do
(k',mo3r:_) <- runPass2 (head.snd) Refresh "refreshing" $
refreshModule (k,gr) mo3
mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3r
mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
then runPass2' "generating PMCFG" $ generatePMCFG opts gr mo4
else runPass2' "" $ return mo4
generateGFO k' mo5
(mo2,warnings) <- putpp " renaming " $ ioeErr $ runCheck (renameModule gr mo1b) ------------------------------
warnOut opts warnings tagsFlag = flag optTagsOnly opts
intermOut opts DumpRename (ppModule Internal mo2)
(mo3,warnings) <- putpp " type checking" $ ioeErr $ runCheck (checkModule opts gr mo2) generateGFO k mo =
warnOut opts warnings do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
intermOut opts DumpTypeCheck (ppModule Internal mo3) maybeM (flip (writeGFO opts) mo) mb_gfo
extendCompileEnvInt env k mb_gfo mo
if not (flag optTagsOnly opts) generateTags k mo =
then do (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,gr) mo3 do maybeM (flip (writeTags opts gr) mo . gf2gftags opts) mb_gfFile
intermOut opts DumpRefresh (ppModule Internal mo3r) extendCompileEnvInt env k Nothing mo
mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts gr mo3r putpp s = if null s then id else putPointE Verbose opts (" "++s++" ")
intermOut opts DumpOptimize (ppModule Internal mo4) idump pass = intermOut opts (Dump pass) . ppModule Internal
mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts runPass = runPass' fst fst snd (ioeErr . runCheck)
then putpp " generating PMCFG " $ ioeIO $ generatePMCFG opts gr mo4 runPass2 = runPass2e ioeErr
else return mo4 runPass2' = runPass2e ioeIO id Canon
intermOut opts DumpCanon (ppModule Internal mo5) runPass2e lift f = runPass' id f (const "") lift
let mb_gfo = fmap (gf2gfo opts) mb_gfFile runPass' ret dump warn lift pass pp m =
case mb_gfo of do out <- putpp pp $ lift m
Just gfo -> writeGFO opts gfo mo5 warnOut opts (warn out)
Nothing -> return () idump pass (dump out)
return (ret out)
extendCompileEnvInt env k' mb_gfo mo5 maybeM f = maybe (return ()) f
else do case mb_gfFile of
Just gfFile -> writeTags opts gr (gf2gftags opts gfFile) mo3
Nothing -> return ()
extendCompileEnvInt env k Nothing mo3
writeGFO :: Options -> FilePath -> SourceModule -> IOE () writeGFO :: Options -> FilePath -> SourceModule -> IOE ()

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

@@ -17,7 +17,7 @@ module GF.Compile.GetGrammar (getSourceModule) where
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option(Options,optPreprocessors,addOptions,flag)
import GF.Grammar.Lexer import GF.Grammar.Lexer
import GF.Grammar.Parser import GF.Grammar.Parser
import GF.Grammar.Grammar import GF.Grammar.Grammar

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

@@ -6,7 +6,7 @@ module GF.Infra.Option
Mode(..), Phase(..), Verbosity(..), Mode(..), Phase(..), Verbosity(..),
OutputFormat(..), OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..), SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Recomp(..), Dump(..), Pass(..), Recomp(..),
outputFormatsExpl, outputFormatsExpl,
-- * Option parsing -- * Option parsing
parseOptions, parseModuleOptions, fixRelativeLibPaths, parseOptions, parseModuleOptions, fixRelativeLibPaths,
@@ -131,7 +131,8 @@ data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
data Warning = WarnMissingLincat data Warning = WarnMissingLincat
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Dump = DumpSource | DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon newtype Dump = Dump Pass deriving (Show,Eq,Ord)
data Pass = Source | Rebuild | Extend | Rename | TypeCheck | Refresh | Optimize | Canon
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
@@ -351,14 +352,14 @@ optDescr =
Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).", Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...", Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
Option [] ["new-comp"] (NoArg (set $ \o -> o{optNewComp = True})) "Use the new experimental compiler.", Option [] ["new-comp"] (NoArg (set $ \o -> o{optNewComp = True})) "Use the new experimental compiler.",
dumpOption "source" DumpSource, dumpOption "source" Source,
dumpOption "rebuild" DumpRebuild, dumpOption "rebuild" Rebuild,
dumpOption "extend" DumpExtend, dumpOption "extend" Extend,
dumpOption "rename" DumpRename, dumpOption "rename" Rename,
dumpOption "tc" DumpTypeCheck, dumpOption "tc" TypeCheck,
dumpOption "refresh" DumpRefresh, dumpOption "refresh" Refresh,
dumpOption "opt" DumpOptimize, dumpOption "opt" Optimize,
dumpOption "canon" DumpCanon dumpOption "canon" Canon
] ]
where phase x = set $ \o -> o { optStopAfterPhase = x } where phase x = set $ \o -> o { optStopAfterPhase = x }
@@ -422,7 +423,7 @@ optDescr =
Nothing -> fail $ "Unknown CFG transformation: " ++ x' Nothing -> fail $ "Unknown CFG transformation: " ++ x'
++ " Known: " ++ show (map fst cfgTransformNames) ++ " Known: " ++ show (map fst cfgTransformNames)
dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.") dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = Dump d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
set = return . Options set = return . Options