From ec5a362179b53c70b3a97599ea135bd08730b386 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 05:27:31 +0100 Subject: [PATCH] Add AsyncSymbolDb to fix runGhcMod race condition for good --- Language/Haskell/GhcMod/Find.hs | 73 ++++++++++++++++++++++++++------- ghc-mod.cabal | 3 +- src/GHCMod.hs | 18 ++++---- src/Misc.hs | 48 ---------------------- 4 files changed, 66 insertions(+), 76 deletions(-) delete mode 100644 src/Misc.hs diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 3962b01..5723a65 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} +{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, MultiWayIf #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -10,34 +10,42 @@ module Language.Haskell.GhcMod.Find , findSymbol , lookupSym , isOutdated + -- * Load 'SymbolDb' asynchronously + , AsyncSymbolDb + , newAsyncSymbolDb + , getAsyncSymbolDb ) #endif where -import Control.Applicative -import Control.Monad (when, void) -import Data.Function (on) -import Data.List (groupBy, sort) -import qualified GHC as G import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Gap (listVisibleModules) +import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World (timedPackageCaches) -import Language.Haskell.GhcMod.Output -import Name (getOccString) -import Module (moduleName) -import System.Directory (doesFileExist) +import Language.Haskell.GhcMod.World + +import qualified GHC as G +import Name +import Module +import Exception + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Control +import Control.Concurrent +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import System.Directory import System.Directory.ModTime import System.FilePath (()) import System.IO import Prelude -import Data.Map (Map) -import qualified Data.Map as M - ---------------------------------------------------------------- -- | Type of function and operation names. @@ -147,3 +155,38 @@ collectModules :: [(Symbol, ModuleString)] collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x) + +---------------------------------------------------------------- + +data AsyncSymbolDb = AsyncSymbolDb FilePath (MVar (Either SomeException SymbolDb)) + +asyncLoadSymbolDb :: IOish m + => FilePath + -> MVar (Either SomeException SymbolDb) + -> GhcModT m () +asyncLoadSymbolDb tmpdir mv = void $ + liftBaseWith $ \run -> forkIO $ void $ run $ do + edb <- gtry $ loadSymbolDb tmpdir + liftIO $ putMVar mv edb + +newAsyncSymbolDb :: IOish m => FilePath -> GhcModT m AsyncSymbolDb +newAsyncSymbolDb tmpdir = do + mv <- liftIO newEmptyMVar + asyncLoadSymbolDb tmpdir mv + return $ AsyncSymbolDb tmpdir mv + +getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb +getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = go 0 + where + go :: Integer -> GhcModT m SymbolDb + go i = do + edb <- liftIO $ takeMVar mv + case edb of + Left ex -> throw ex + Right db -> do + outdated <- isOutdated db + if | i > 2 -> error "getAsyncSymbolDb: outdated loop" + | outdated -> asyncLoadSymbolDb tmpdir mv >> go (i + 1) + | otherwise -> do + liftIO $ putMVar mv (Right db) + return db diff --git a/ghc-mod.cabal b/ghc-mod.cabal index dea4938..1b12725 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -206,7 +206,6 @@ Executable ghc-mod Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base < 5 && >= 4.0 - , async < 2.1 , directory < 1.3 , filepath < 1.5 , pretty < 1.2 @@ -214,6 +213,7 @@ Executable ghc-mod , split < 0.3 , mtl < 2.3 && >= 2.0 , ghc < 7.11 + , monad-control ==1.0.* , fclabels ==2.0.* , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod @@ -222,7 +222,6 @@ Executable ghc-modi Default-Language: Haskell2010 Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod - Misc Utils GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 09c5036..40340fc 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -11,6 +11,7 @@ import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb) import System.FilePath (()) import System.Directory (setCurrentDirectory, getAppUserDataDirectory, removeDirectoryRecursive) @@ -20,8 +21,6 @@ import Text.PrettyPrint hiding ((<>)) import GHCMod.Options import Prelude -import Misc - ghcModStyle :: Style ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } @@ -49,17 +48,14 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $ -- ghc-modi legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do - opt <- options prepareCabalHelper tmpdir <- cradleTempDir <$> cradle - gmo <- gmoAsk - symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir + asyncSymbolDb <- newAsyncSymbolDb tmpdir world <- getCurrentWorld - legacyInteractiveLoop symdbreq world + legacyInteractiveLoop asyncSymbolDb world -legacyInteractiveLoop :: IOish m - => SymDbReq -> World -> GhcModT m () -legacyInteractiveLoop symdbreq world = do +legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m () +legacyInteractiveLoop asyncSymbolDb world = do liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle -- blocking @@ -80,12 +76,12 @@ legacyInteractiveLoop symdbreq world = do $ parseArgsInteractive cmdArg case pargs of CmdFind symbol -> - lookupSymbol symbol =<< checkDb symdbreq =<< getDb symdbreq + lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb -- other commands are handled here x -> ghcCommands x gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) - legacyInteractiveLoop symdbreq world' + legacyInteractiveLoop asyncSymbolDb world' where interactiveHandlers = [ GHandler $ \(e :: ExitCode) -> throw e diff --git a/src/Misc.hs b/src/Misc.hs deleted file mode 100644 index 98e8f39..0000000 --- a/src/Misc.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Misc ( - SymDbReq - , newSymDbReq - , getDb - , checkDb - ) where - -import Control.Concurrent.Async (Async, async, wait) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Prelude - -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad - ----------------------------------------------------------------- - -type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) -data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) - -newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq -newSymDbReq opt gmo tmpdir = do - let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir - req <- async act - ref <- newIORef req - return $ SymDbReq ref act - -getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb -getDb (SymDbReq ref _) = do - req <- liftIO $ readIORef ref - -- 'wait' really waits for the asynchronous action at the fist time. - -- Then it reads a cached value from the second time. - hoistGhcModT =<< liftIO (wait req) - -checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb -checkDb (SymDbReq ref act) db = do - outdated <- isOutdated db - if outdated then do - -- async and wait here is unnecessary because this is essentially - -- synchronous. But Async can be used a cache. - req <- liftIO $ async act - liftIO $ writeIORef ref req - hoistGhcModT =<< liftIO (wait req) - else - return db