summaryrefslogtreecommitdiff
path: root/src/compiler/GF/CompileOne.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/CompileOne.hs')
-rw-r--r--src/compiler/GF/CompileOne.hs113
1 files changed, 56 insertions, 57 deletions
diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs
index 45c1f5b84..31a0f81df 100644
--- a/src/compiler/GF/CompileOne.hs
+++ b/src/compiler/GF/CompileOne.hs
@@ -1,5 +1,5 @@
module GF.CompileOne(OneOutput,CompiledModule,
- compileOne --, compileSourceModule
+ compileOne --, CompileSource, compileSourceModule
) where
import Prelude hiding (catch)
import GF.System.Catch
@@ -19,15 +19,14 @@ import GF.Grammar.Printer(ppModule,TermPrintQual(..))
import GF.Grammar.Binary(decodeModule,encodeModule)
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.Data.Operations(liftErr,(+++))
import GF.System.Directory(doesFileExist,getCurrentDirectory)
-import System.FilePath(dropFileName,dropExtension,takeExtensions)
import qualified Data.Map as Map
import GF.Text.Pretty(Doc,render,(<+>),($$))
-
+import Control.Monad((<=<))
type OneOutput = (Maybe FullPath,CompiledModule)
type CompiledModule = SourceModule
@@ -35,31 +34,27 @@ type CompiledModule = SourceModule
-- | Compile a given source file (or just load a .gfo file),
-- given a 'SourceGrammar' containing everything it depends on.
compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
-compileOne opts srcgr file = do
-
- let putpOpt v m act
+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
+
+ 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
-
- 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
-- also undo common subexp optimization, to enable normal computations
reuseGFO opts srcgr file =
@@ -67,7 +62,7 @@ reuseGFO opts srcgr file =
liftIO (decodeModule file)
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
cwd <- liftIO getCurrentDirectory
@@ -81,30 +76,31 @@ reuseGFO opts srcgr file =
return (Just file,sm)
-compileSourceModule :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE OneOutput
-compileSourceModule opts gr mb_gfFile mo0 = do
-
- cwd <- liftIO getCurrentDirectory
- mo1 <- runPass Extend "" . extendModule cwd gr
- =<< runPass Rebuild "" (rebuildModule cwd gr mo0)
+type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput
- 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
+compileSourceModule :: Options -> FilePath -> Maybe FilePath -> CompileSource
+compileSourceModule opts cwd mb_gfFile gr =
+ if flag optTagsOnly opts
+ then generateTags <=< ifComplete middle <=< frontend
+ else generateGFO <=< ifComplete (backend <=< middle) <=< frontend
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
+ -- Apply to all modules
+ frontend = runPass Extend "" . extendModule cwd gr
+ <=< runPass Rebuild "" . rebuildModule cwd gr
+
+ -- Apply to complete modules
+ middle = runPass TypeCheck "type checking" . checkModule opts cwd gr
+ <=< runPass Rename "renaming" . renameModule cwd gr
- ------------------------------
- generateTagsOr compile =
- if flag optTagsOnly opts then generateTags else compile
+ -- 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 =
do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
@@ -116,30 +112,31 @@ compileSourceModule opts gr mb_gfFile mo0 = do
return (Nothing,mo)
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)
- runPass2 = runPass2e liftErr
- runPass2' = runPass2e id id Canon
+ runPassE = runPass2e liftErr
+ runPassI = 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)
+ idump opts 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
+writeGFO opts file mo =
+ putPointE Normal opts (" write file" +++ file) $
+ liftIO $ encodeModule file mo2
+ where
+ 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
intermOut :: Options -> Dump -> Doc -> IOE ()
@@ -147,6 +144,8 @@ intermOut opts d doc
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
| otherwise = return ()
+idump opts pass = intermOut opts (Dump pass) . ppModule Internal
+
warnOut opts warnings
| null warnings = return ()
| otherwise = liftIO $ ePutStrLn ws `catch` oops
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:40:20 +0000