(1) Refactor concurrency, (2) write to .gfo.tmp then rename to .gfo

(1) introduces the module GF.Infra.Concurreny with lifted concurrency
    operators (to reduce uses of liftIO) and some additional concurrency
    utilities, e.g. a function for sequential logging that is used in
    both GF.CompileInParallel and GFServer.
(2) avoids leaving broken .gfo files behind if compilation is aborted.

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
+     deps <- newMVar M.empty
-     liftIO $ forkIO (mapM_ runIOE =<< getChanContents logchan)
+     toLog <- newLog runIOE
-     let logStrLn = writeChan logchan . ePutStrLn
+     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
+              good (o,r) = do toLog o; return r
-              bad e = do writeChan logchan (redPutStrLn e); fail "failed"
+              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

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
 

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 :: MonadIO io => FilePath -> io SourceModule
-decodeModule fpath = check =<< decodeFile' fpath
+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 :: MonadIO io => FilePath -> SourceModule -> io ()
-encodeModule fpath mo = encodeFile fpath (Tagged mo)
+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)

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

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
+removeFile path = liftIO $ D.removeFile path
+renameFile path = liftIO . D.renameFile path

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."

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
+      do logLn <- newLog ePutStrLn -- to avoid intertwined log messages
-         forkIO $ mapM_ ePutStrLn =<< getChanContents log
-         let logLn = writeChan log
          logLn gf_version
          logLn $ "Document root = "++root
          logLn $ "Starting HTTP server, open http://localhost:"