diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index f48396488..8d842e2ca 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -14,7 +14,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb, justModuleName,extendPathEnv,putStrE,putPointE) import GF.Data.Operations(raise,(+++),err) -import Control.Monad(foldM,when) +import Control.Monad(foldM,when,(<=<)) import GF.System.Directory(doesFileExist,getModificationTime) import System.FilePath((),isRelative,dropFileName) import qualified Data.Map as Map(empty,insert,elems) --lookup @@ -69,7 +69,7 @@ compileModule opts1 env@(_,rfs) file = do file <- getRealFile file opts0 <- getOptionsFromFile 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 ps0 <- extendPathEnv opts let ps = nub (curr_dir : ps0) @@ -85,7 +85,7 @@ compileModule opts1 env@(_,rfs) file = if exists then return file else if isRelative file - then do lib_dir <- liftIO $ getLibraryDirectory opts1 + then do lib_dir <- getLibraryDirectory opts1 let file1 = lib_dir file exists <- liftIO $ doesFileExist file1 if exists @@ -94,24 +94,21 @@ compileModule opts1 env@(_,rfs) file = else raise (render ("File" <+> file <+> "does not exist.")) compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv -compileOne' opts env@(srcgr,_) file = - extendCompileEnv env =<< compileOne opts srcgr file +compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr -- auxiliaries ---reverseModules (MGrammar ms) = MGrammar $ reverse ms - -- | The environment type CompileEnv = (SourceGrammar,ModEnv) emptyCompileEnv :: CompileEnv emptyCompileEnv = (emptySourceGrammar,Map.empty) -extendCompileEnv (gr,menv) (mfile,mo) = do - menv2 <- case mfile of - Just file -> do - let (mod,imps) = importsOfModule mo - t <- liftIO $ getModificationTime file - return $ Map.insert mod (t,imps) menv - _ -> return menv - return (prependModule gr mo,menv2) --- reverse later +extendCompileEnv (gr,menv) (mfile,mo) = + do menv2 <- case mfile of + Just file -> + do let (mod,imps) = importsOfModule mo + t <- liftIO $ getModificationTime file + return $ Map.insert mod (t,imps) menv + _ -> return menv + return (prependModule gr mo,menv2) 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 +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 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 +type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput - cwd <- liftIO getCurrentDirectory - 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 +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 - ------------------------------ - generateTagsOr compile = - if flag optTagsOnly opts then generateTags else compile + -- Apply to complete modules + middle = runPass TypeCheck "type checking" . checkModule opts cwd gr + <=< 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 = 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