summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/CompileInParallel.hs42
-rw-r--r--src/compiler/GF/CompileOne.hs12
-rw-r--r--src/compiler/GF/Grammar/Binary.hs9
-rw-r--r--src/compiler/GF/Infra/Concurrency.hs48
-rw-r--r--src/compiler/GF/System/Directory.hs5
-rw-r--r--src/compiler/GFC.hs2
-rw-r--r--src/compiler/GFServer.hs6
7 files changed, 90 insertions, 34 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
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:"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-24 17:25:25 +0000