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

1 files changed, 24 insertions, 18 deletions

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