diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index 4dbbae26a..c5e7fe866 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -2,9 +2,8 @@ module GF.CompileInParallel where import Prelude hiding (catch) import Control.Monad(join,ap,when,unless) import Control.Applicative -import Control.Concurrent +import GF.Infra.Concurrency import System.FilePath -import System.IO.Unsafe(unsafeInterleaveIO) import qualified GF.System.Directory as D import GF.System.Catch(catch) import Data.List(nub,isPrefixOf,intercalate,partition) @@ -14,7 +13,7 @@ import GF.CompileOne(reuseGFO,useTheSource) import GF.Infra.Option import GF.Infra.UseIO import GF.Data.Operations -import GF.Grammar.Grammar(emptySourceGrammar,prependModule,modules) +import GF.Grammar.Grammar(emptySourceGrammar,prependModule) import GF.Infra.Ident(identS) import GF.Text.Pretty import qualified Data.ByteString.Lazy as BS @@ -60,19 +59,23 @@ batchCompile1 lib_dir (opts,filepaths) = prelude_dir = lib_dir"prelude" gfoDir = flag optGFODir opts maybe (return ()) (D.createDirectoryIfMissing True) gfoDir +{- + liftIO $ writeFile (maybe "" id gfoDir"paths") + (unlines . map (unwords . map rel) . nub $ map snd filepaths) +-} prelude_files <- maybe [] id <$> maybeIO (D.getDirectoryContents prelude_dir) let fromPrelude f = lib_dir `isPrefixOf` f && takeFileName f `elem` prelude_files ppPath ps = "-path="<>intercalate ":" (map rel ps) - logchan <- liftIO newChan - liftIO $ forkIO (mapM_ runIOE =<< getChanContents logchan) - let logStrLn = writeChan logchan . ePutStrLn + deps <- newMVar M.empty + toLog <- newLog runIOE + let --logStrLn = toLog . ePutStrLn ok :: CollectOutput IOE a -> IO a ok (CO m) = err bad good =<< appIOE m where - good (o,r) = do writeChan logchan o; return r - bad e = do writeChan logchan (redPutStrLn e); fail "failed" + good (o,r) = do toLog o; return r + bad e = do toLog (redPutStrLn e); fail "failed" redPutStrLn s = do ePutStr "\ESC[31m";ePutStr s;ePutStrLn "\ESC[m" sgr <- liftIO $ newMVar emptySourceGrammar let extendSgr sgr m = @@ -101,7 +104,9 @@ batchCompile1 lib_dir (opts,filepaths) = do let compileImport f = compile cache (f,ps) findImports (f,ps) = mapM (find f ps) . nub . snd =<< getImports opts f - tis <- parMapM compileImport =<< ok (findImports (f,ps)) + imps <- ok (findImports (f,ps)) + modifyMVar_ deps (return . M.insert f imps) + tis <- parMapM compileImport imps let reuse gfo = do t <- D.getModificationTime gfo gr <- readMVar sgr r <- lazyIO $ ok (reuseGFO opts gr gfo) @@ -123,17 +128,19 @@ batchCompile1 lib_dir (opts,filepaths) = return (maximum (t:tis)) cache <- liftIO $ newIOCache compile' ts <- liftIO $ parMapM (compile cache) filepaths - gr <- liftIO $ readMVar sgr + gr <- readMVar sgr let cnc = identS (justModuleName (fst (last filepaths))) + ds <- M.toList <$> readMVar deps +{- + liftIO $ writeFile (maybe "" id gfoDir"dependencies") + (unlines [rel f++": "++unwords (map rel imps) + | (f,imps)<-ds]) +-} + putStrLnE $ render $ + length ds<+>"modules in" + <+>length (nub (map (dropFileName.fst) ds))<+>"directories." return (maximum ts,(cnc,gr)) -parMapM f xs = - do vs <- mapM (const newEmptyMVar) xs - sequence_ [ forkIO (putMVar v =<< f x) | (v,x) <- zip vs xs] - mapM takeMVar vs - -lazyIO = unsafeInterleaveIO - canonical path = liftIO $ D.canonicalizePath path `catch` const (return path) getPathFromFile lib_dir cmdline_opts file = @@ -184,7 +191,6 @@ instance Eq (Hide a) where _ == _ = True instance Ord (Hide a) where compare _ _ = EQ -------------------------------------------------------------------------------- - newtype CollectOutput m a = CO {unCO::m (m (),a)} {- runCO (CO m) = do (o,x) <- m diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs index 0a6fcb56a..f182f66d0 100644 --- a/src/compiler/GF/CompileOne.hs +++ b/src/compiler/GF/CompileOne.hs @@ -18,13 +18,13 @@ import GF.Grammar.Printer(ppModule,TermPrintQual(..)) import GF.Grammar.Binary(decodeModule,encodeModule) import GF.Infra.Option -import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,liftIO,Output(..),putPointE) +import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,Output(..),putPointE) import GF.Infra.CheckM(runCheck') import GF.Data.Operations(liftErr,(+++)) -import GF.System.Directory(doesFileExist,getCurrentDirectory) +import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile) import qualified Data.Map as Map -import GF.Text.Pretty(Doc,render,(<+>),($$)) +import GF.Text.Pretty(render,(<+>),($$)) --Doc, import Control.Monad((<=<)) type OneOutput = (Maybe FullPath,CompiledModule) @@ -44,7 +44,7 @@ compileOne opts srcgr file = -- also undo common subexp optimization, to enable normal computations reuseGFO opts srcgr file = do sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ - liftIO (decodeModule file) + decodeModule file let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts}) idump opts Source sm0 @@ -131,8 +131,10 @@ compileSourceModule opts cwd mb_gfFile gr = --writeGFO :: Options -> FilePath -> SourceModule -> IOE () writeGFO opts file mo = putPointE Normal opts (" write file" +++ file) $ - liftIO $ encodeModule file mo2 + do encodeModule tmp mo2 + renameFile tmp file where + tmp = file++".tmp" mo2 = (m,mi{jments=Map.filter notAnyInd (jments mi)}) (m,mi) = subexpModule mo diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index ad9df8b92..1bdadabd6 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -21,6 +21,7 @@ import qualified Data.ByteString.Char8 as BS import GF.Data.Operations import GF.Infra.Ident import GF.Infra.Option +import GF.Infra.UseIO(MonadIO(..)) import GF.Grammar.Grammar import PGF() -- Binary instances @@ -314,8 +315,8 @@ gfoBinVersion = (b1,b2,b3,b4) where [b1,b2,b3,b4] = map (toEnum.fromEnum) gfoVersion :: [Word8] -decodeModule :: FilePath -> IO SourceModule -decodeModule fpath = check =<< decodeFile' fpath +decodeModule :: MonadIO io => FilePath -> io SourceModule +decodeModule fpath = liftIO $ check =<< decodeFile' fpath where check (Tagged m) = return m check _ = fail ".gfo file version mismatch" @@ -336,8 +337,8 @@ decodeModuleHeader fpath = fmap check $ decodeFile' fpath (Just (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)) check _ = Nothing --} -encodeModule :: FilePath -> SourceModule -> IO () -encodeModule fpath mo = encodeFile fpath (Tagged mo) +encodeModule :: MonadIO io => FilePath -> SourceModule -> io () +encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo) -- | like 'decodeFile' but adds file name to error message if there was an error decodeFile' fpath = addFPath fpath (decodeFile fpath) diff --git a/src/compiler/GF/Infra/Concurrency.hs b/src/compiler/GF/Infra/Concurrency.hs new file mode 100644 index 000000000..5fc15ead7 --- /dev/null +++ b/src/compiler/GF/Infra/Concurrency.hs @@ -0,0 +1,48 @@ +-- | Lifted concurrency operators and a some useful concurrency abstractions +module GF.Infra.Concurrency( + module GF.Infra.Concurrency, + C.forkIO, + C.MVar,C.modifyMVar,C.modifyMVar_, + C.Chan + ) where +import qualified Control.Concurrent as C +import System.IO.Unsafe(unsafeInterleaveIO) +import Control.Monad((<=<)) +import Control.Monad.Trans(MonadIO(..)) + +-- * Futures + +newtype Future a = Future {now::IO a} + +spawn io = do v <- newEmptyMVar + C.forkIO $ putMVar v =<< io + return (Future (readMVar v)) + +parMapM f = mapM now <=< mapM (spawn . f) + +-- * Single-threaded logging + +newLog put = + do logchan <- newChan + liftIO $ C.forkIO (mapM_ put =<< getChanContents logchan) + return (writeChan logchan) + +-- * Lifted concurrency operators + +newMVar x = liftIO $ C.newMVar x +readMVar v = liftIO $ C.readMVar v +putMVar v = liftIO . C.putMVar v + +newEmptyMVar :: MonadIO io => io (C.MVar a) +newEmptyMVar = liftIO C.newEmptyMVar + +newChan :: MonadIO io => io (C.Chan a) +newChan = liftIO C.newChan + +getChanContents ch = liftIO $ C.getChanContents ch +writeChan ch = liftIO . C.writeChan ch + + +-- * Delayed IO + +lazyIO = unsafeInterleaveIO diff --git a/src/compiler/GF/System/Directory.hs b/src/compiler/GF/System/Directory.hs index 306c5fbcb..898646063 100644 --- a/src/compiler/GF/System/Directory.hs +++ b/src/compiler/GF/System/Directory.hs @@ -7,7 +7,7 @@ import System.Directory as D hiding (canonicalizePath,createDirectoryIfMissing, doesDirectoryExist,doesFileExist,getModificationTime, getCurrentDirectory,getDirectoryContents,getPermissions, - removeFile) + removeFile,renameFile) import Data.Time.Compat canonicalizePath path = liftIO $ D.canonicalizePath path @@ -21,4 +21,5 @@ getCurrentDirectory :: MonadIO io => io FilePath getCurrentDirectory = liftIO D.getCurrentDirectory getPermissions path = liftIO $ D.getPermissions path -removeFile path = liftIO $ D.removeFile path \ No newline at end of file +removeFile path = liftIO $ D.removeFile path +renameFile path = liftIO . D.renameFile path diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs index 6f909b511..4b88bd998 100644 --- a/src/compiler/GFC.hs +++ b/src/compiler/GFC.hs @@ -83,7 +83,7 @@ unionPGFFiles opts fs = where checkFirst name = do let pgfFile = outputPath opts (name <.> "pgf") - sourceTime <- liftIO $ maximum `fmap` mapM getModificationTime fs + sourceTime <- maximum `fmap` mapM getModificationTime fs targetTime <- maybeIO $ getModificationTime pgfFile if targetTime >= Just sourceTime then putIfVerb opts $ pgfFile ++ " is up-to-date." diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index a74167b9a..fbcca3d94 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -23,7 +23,7 @@ import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory, import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink, createSymbolicLink) #endif -import Control.Concurrent(forkIO,newMVar,modifyMVar,newChan,writeChan,getChanContents) +import GF.Infra.Concurrency(newMVar,modifyMVar,newLog) import Network.URI(URI(..)) import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache) --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi @@ -65,9 +65,7 @@ server port optroot execute1 state0 = where -- | HTTP server http_server execute1 state0 state cache root = - do log <- newChan -- to avoid intertwined log messages - forkIO $ mapM_ ePutStrLn =<< getChanContents log - let logLn = writeChan log + do logLn <- newLog ePutStrLn -- to avoid intertwined log messages logLn gf_version logLn $ "Document root = "++root logLn $ "Starting HTTP server, open http://localhost:"