Add AsyncSymbolDb to fix runGhcMod race condition for good
This commit is contained in:
parent
d2f7df21df
commit
ec5a362179
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
|
{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, MultiWayIf #-}
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.Find
|
module Language.Haskell.GhcMod.Find
|
||||||
#ifndef SPEC
|
#ifndef SPEC
|
||||||
@ -10,34 +10,42 @@ module Language.Haskell.GhcMod.Find
|
|||||||
, findSymbol
|
, findSymbol
|
||||||
, lookupSym
|
, lookupSym
|
||||||
, isOutdated
|
, isOutdated
|
||||||
|
-- * Load 'SymbolDb' asynchronously
|
||||||
|
, AsyncSymbolDb
|
||||||
|
, newAsyncSymbolDb
|
||||||
|
, getAsyncSymbolDb
|
||||||
)
|
)
|
||||||
#endif
|
#endif
|
||||||
where
|
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.Convert
|
||||||
import Language.Haskell.GhcMod.Gap (listVisibleModules)
|
import Language.Haskell.GhcMod.Gap
|
||||||
import Language.Haskell.GhcMod.Monad
|
import Language.Haskell.GhcMod.Monad
|
||||||
|
import Language.Haskell.GhcMod.Output
|
||||||
import Language.Haskell.GhcMod.PathsAndFiles
|
import Language.Haskell.GhcMod.PathsAndFiles
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
import Language.Haskell.GhcMod.Utils
|
import Language.Haskell.GhcMod.Utils
|
||||||
import Language.Haskell.GhcMod.World (timedPackageCaches)
|
import Language.Haskell.GhcMod.World
|
||||||
import Language.Haskell.GhcMod.Output
|
|
||||||
import Name (getOccString)
|
import qualified GHC as G
|
||||||
import Module (moduleName)
|
import Name
|
||||||
import System.Directory (doesFileExist)
|
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.Directory.ModTime
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import System.IO
|
import System.IO
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Data.Map (Map)
|
|
||||||
import qualified Data.Map as M
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
-- | Type of function and operation names.
|
-- | Type of function and operation names.
|
||||||
@ -147,3 +155,38 @@ collectModules :: [(Symbol, ModuleString)]
|
|||||||
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
||||||
where
|
where
|
||||||
tieup x = (head (map fst x), map snd x)
|
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
|
||||||
|
@ -206,7 +206,6 @@ Executable ghc-mod
|
|||||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||||
HS-Source-Dirs: src
|
HS-Source-Dirs: src
|
||||||
Build-Depends: base < 5 && >= 4.0
|
Build-Depends: base < 5 && >= 4.0
|
||||||
, async < 2.1
|
|
||||||
, directory < 1.3
|
, directory < 1.3
|
||||||
, filepath < 1.5
|
, filepath < 1.5
|
||||||
, pretty < 1.2
|
, pretty < 1.2
|
||||||
@ -214,6 +213,7 @@ Executable ghc-mod
|
|||||||
, split < 0.3
|
, split < 0.3
|
||||||
, mtl < 2.3 && >= 2.0
|
, mtl < 2.3 && >= 2.0
|
||||||
, ghc < 7.11
|
, ghc < 7.11
|
||||||
|
, monad-control ==1.0.*
|
||||||
, fclabels ==2.0.*
|
, fclabels ==2.0.*
|
||||||
, optparse-applicative >=0.11.0 && <0.13.0
|
, optparse-applicative >=0.11.0 && <0.13.0
|
||||||
, ghc-mod
|
, ghc-mod
|
||||||
@ -222,7 +222,6 @@ Executable ghc-modi
|
|||||||
Default-Language: Haskell2010
|
Default-Language: Haskell2010
|
||||||
Main-Is: GHCModi.hs
|
Main-Is: GHCModi.hs
|
||||||
Other-Modules: Paths_ghc_mod
|
Other-Modules: Paths_ghc_mod
|
||||||
Misc
|
|
||||||
Utils
|
Utils
|
||||||
GHC-Options: -Wall -threaded -fno-warn-deprecations
|
GHC-Options: -Wall -threaded -fno-warn-deprecations
|
||||||
if os(windows)
|
if os(windows)
|
||||||
|
@ -11,6 +11,7 @@ import Language.Haskell.GhcMod
|
|||||||
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
import Language.Haskell.GhcMod.Monad
|
import Language.Haskell.GhcMod.Monad
|
||||||
|
import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb)
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
||||||
removeDirectoryRecursive)
|
removeDirectoryRecursive)
|
||||||
@ -20,8 +21,6 @@ import Text.PrettyPrint hiding ((<>))
|
|||||||
import GHCMod.Options
|
import GHCMod.Options
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Misc
|
|
||||||
|
|
||||||
ghcModStyle :: Style
|
ghcModStyle :: Style
|
||||||
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
|
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
|
||||||
|
|
||||||
@ -49,17 +48,14 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $
|
|||||||
-- ghc-modi
|
-- ghc-modi
|
||||||
legacyInteractive :: IOish m => GhcModT m ()
|
legacyInteractive :: IOish m => GhcModT m ()
|
||||||
legacyInteractive = do
|
legacyInteractive = do
|
||||||
opt <- options
|
|
||||||
prepareCabalHelper
|
prepareCabalHelper
|
||||||
tmpdir <- cradleTempDir <$> cradle
|
tmpdir <- cradleTempDir <$> cradle
|
||||||
gmo <- gmoAsk
|
asyncSymbolDb <- newAsyncSymbolDb tmpdir
|
||||||
symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir
|
|
||||||
world <- getCurrentWorld
|
world <- getCurrentWorld
|
||||||
legacyInteractiveLoop symdbreq world
|
legacyInteractiveLoop asyncSymbolDb world
|
||||||
|
|
||||||
legacyInteractiveLoop :: IOish m
|
legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()
|
||||||
=> SymDbReq -> World -> GhcModT m ()
|
legacyInteractiveLoop asyncSymbolDb world = do
|
||||||
legacyInteractiveLoop symdbreq world = do
|
|
||||||
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
|
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
|
||||||
|
|
||||||
-- blocking
|
-- blocking
|
||||||
@ -80,12 +76,12 @@ legacyInteractiveLoop symdbreq world = do
|
|||||||
$ parseArgsInteractive cmdArg
|
$ parseArgsInteractive cmdArg
|
||||||
case pargs of
|
case pargs of
|
||||||
CmdFind symbol ->
|
CmdFind symbol ->
|
||||||
lookupSymbol symbol =<< checkDb symdbreq =<< getDb symdbreq
|
lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb
|
||||||
-- other commands are handled here
|
-- other commands are handled here
|
||||||
x -> ghcCommands x
|
x -> ghcCommands x
|
||||||
|
|
||||||
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
|
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
|
||||||
legacyInteractiveLoop symdbreq world'
|
legacyInteractiveLoop asyncSymbolDb world'
|
||||||
where
|
where
|
||||||
interactiveHandlers =
|
interactiveHandlers =
|
||||||
[ GHandler $ \(e :: ExitCode) -> throw e
|
[ GHandler $ \(e :: ExitCode) -> throw e
|
||||||
|
48
src/Misc.hs
48
src/Misc.hs
@ -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
|
|
Loading…
Reference in New Issue
Block a user