diff --git a/buck-worker/Main.hs b/buck-worker/Main.hs index d3f21d69..d56a6c70 100644 --- a/buck-worker/Main.hs +++ b/buck-worker/Main.hs @@ -5,7 +5,7 @@ import Internal.Log (dbg) import Orchestration (envServerSocket) import Run (parseOptions, runWorker) import System.Environment (getArgs) -import System.IO (BufferMode (..), hPutStrLn, hSetBuffering, stderr, stdout) +import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) main :: IO () main = do @@ -13,7 +13,6 @@ main = do hSetBuffering stderr LineBuffering options <- parseOptions =<< getArgs socket <- envServerSocket - hPutStrLn stderr $ "using worker socket: " <> show socket try (runWorker socket options) >>= \case Right () -> dbg "Worker terminated without cancellation." diff --git a/buck-worker/buck-worker.cabal b/buck-worker/buck-worker.cabal index b6e11c8c..2e1250a9 100644 --- a/buck-worker/buck-worker.cabal +++ b/buck-worker/buck-worker.cabal @@ -52,7 +52,9 @@ library ghc, ghc-persistent-worker-plugin, grapesy ^>=1.0.1, + hashable, lens-family, + process, proto-lens, text, vector @@ -61,7 +63,7 @@ executable worker import: all main-is: Main.hs hs-source-dirs: . - ghc-options: -O2 -threaded -with-rtsopts=-N -with-rtsopts=-T + ghc-options: -O2 -threaded "-with-rtsopts=-N -T" build-depends: async, @@ -81,7 +83,7 @@ test-suite worker-test other-modules: CompileHptTest, TestSetup - ghc-options: -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" build-depends: directory, filepath, diff --git a/buck-worker/lib/BUCK b/buck-worker/lib/BUCK new file mode 100644 index 00000000..baf462cf --- /dev/null +++ b/buck-worker/lib/BUCK @@ -0,0 +1,13 @@ +[export_file(f, visibility = ["PUBLIC"]) for f in [ + "BuckArgs.hs", + "BuckWorker.hs", + "GhcHandler.hs", + "Grpc.hs", + "Instrumentation.hs", + "Orchestration.hs", + "Proto/Instrument.hs", + "Proto/Instrument_Fields.hs", + "Proto/Worker.hs", + "Proto/Worker_Fields.hs", + "Run.hs", + ]] diff --git a/buck-worker/lib/Orchestration.hs b/buck-worker/lib/Orchestration.hs index 66259b37..61516c74 100644 --- a/buck-worker/lib/Orchestration.hs +++ b/buck-worker/lib/Orchestration.hs @@ -2,29 +2,49 @@ module Orchestration where +import qualified BuckWorker as Worker import BuckWorker (ExecuteCommand, ExecuteResponse) +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (async, cancel, wait) -import Control.Exception (finally, onException, try) -import Control.Monad (void) +import Control.DeepSeq (force) +import Control.Exception (bracket_, finally, onException, throwIO, try) +import Control.Monad (void, when) +import Data.Hashable (hash) import Data.List (dropWhileEnd) +import Data.Maybe (isJust) import Data.Traversable (for) -import GHC.IO.Handle.FD (withFileBlocking) +import GHC.IO.Handle.Lock (LockMode (..), hLock, hUnlock) import Grpc (streamingNotImplemented) import Internal.Log (dbg) import Network.GRPC.Client (Connection, Server (..), recvNextOutput, sendFinalInput, withConnection, withRPC) import Network.GRPC.Common (Proxy (..), def) -import Network.GRPC.Common.Protobuf (Proto, Protobuf, (%~), (&)) +import Network.GRPC.Common.Protobuf (Proto, Protobuf, defMessage, (%~), (&)) import Network.GRPC.Server.Protobuf (ProtobufMethodsOf) import Network.GRPC.Server.Run (InsecureConfig (..), ServerConfig (..), runServerWithHandlers) import Network.GRPC.Server.StreamType (Methods (..), fromMethods, mkClientStreaming, mkNonStreaming) import Proto.Instrument (Instrument (..)) import Proto.Worker (Worker (..)) import Proto.Worker_Fields qualified as Fields -import System.Directory (createDirectory, removeFile) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory, removeFile) import System.Environment (getEnv) import System.Exit (exitFailure) import System.FilePath (takeDirectory, ()) -import System.IO (IOMode (..), hGetLine, hPutStr) +import System.IO (IOMode (..), hGetLine, hPutStr, withFile) +import System.Process (ProcessHandle, getProcessExitCode, spawnProcess) + +-- | Determine how GHC servers should be started in relation to Buck worker processes. +data Orchestration = + -- | Each worker process starts its own GHC server. + Multi + | + -- | One worker process starts a GHC server, the others start a proxy server that forwards requests to the central + -- GHC. + Single + | + -- | One worker process spawns a new child process that runs the GHC server, and all workers then proxy this GHC. + -- GHC. + Spawn + deriving stock (Eq, Show) -- | The file system path of the socket on which the worker running in this process is supposed to listen. newtype ServerSocketPath = @@ -35,18 +55,40 @@ newtype ServerSocketPath = envServerSocket :: IO ServerSocketPath envServerSocket = ServerSocketPath <$> getEnv "WORKER_SOCKET" +-- | The base dir for sockets, usually a dir in @/tmp@ created by Buck or ourselves. +newtype SocketDirectory = + SocketDirectory { path :: FilePath } + deriving stock (Eq, Show) + +-- | Derive the socket base dir from the socket path provided by Buck. +spawnedSocketDirectory :: ServerSocketPath -> SocketDirectory +spawnedSocketDirectory (ServerSocketPath path) = + SocketDirectory (takeDirectory path) + +-- | Use the current directory's hash to create a socket directory independent of Buck. +-- This is a hack that should eventually be replaced by a proper system. +projectSocketDirectory :: IO SocketDirectory +projectSocketDirectory = do + cwd <- getCurrentDirectory + pure (SocketDirectory ("/tmp/ghc-persistent-worker/" ++ show (hash cwd))) + -- | The file system path of the socket on which the primary worker running the GHC server is listening. newtype PrimarySocketPath = PrimarySocketPath { path :: FilePath } deriving stock (Eq, Show) +-- | For the case where the primary server is spawned, rather than reusing the socket on which communication with Buck +-- is happening. +primarySocketIn :: SocketDirectory -> PrimarySocketPath +primarySocketIn dir = PrimarySocketPath (dir.path "server") + -- | The file system path of the socket on which the primary worker outputs instrumentation information. newtype InstrumentSocketPath = InstrumentSocketPath { path :: FilePath } deriving stock (Eq, Show) -instrumentSocketIn :: FilePath -> InstrumentSocketPath -instrumentSocketIn dir = InstrumentSocketPath (dir "instrument") +instrumentSocketIn :: SocketDirectory -> InstrumentSocketPath +instrumentSocketIn dir = InstrumentSocketPath (dir.path "instrument") -- | The file system path in which the primary worker running the GHC server stores its socket path for clients to -- discover. @@ -54,8 +96,14 @@ newtype PrimarySocketDiscoveryPath = PrimarySocketDiscoveryPath { path :: FilePath } deriving stock (Eq, Show) -primarySocketDiscoveryIn :: FilePath -> PrimarySocketDiscoveryPath -primarySocketDiscoveryIn dir = PrimarySocketDiscoveryPath (dir "primary") +primarySocketDiscoveryIn :: SocketDirectory -> PrimarySocketDiscoveryPath +primarySocketDiscoveryIn dir = PrimarySocketDiscoveryPath (dir.path "primary") + +-- | Path to the worker executable, i.e. this program. +-- Used to spawn the GHC server process. +newtype WorkerExe = + WorkerExe { path :: FilePath } + deriving stock (Eq, Show) -- | The implementation of an app consisting of two gRPC servers, implementing the protocols 'Worker' and 'Instrument'. -- The 'Instrument' component is intended to be optional. @@ -145,38 +193,122 @@ proxyServer primary socket = do dbg ("Starting proxy for " ++ primary.path ++ " on " ++ socket.path) runServerWithHandlers def (grpcServerConfig socket.path) $ fromMethods methods --- | Start a gRPC server that either runs GHC (primary server) or a proxy that forwards requests to the primary. +messageExecute :: Proto Worker.ExecuteCommand +messageExecute = defMessage + +-- | How often the process should wait for 100ms and retry connecting to the GHC server after spawning a process. +maxRetries :: Int +maxRetries = 30 + +-- | Attempt to connect and send a gRPC message to the server starting up at the given socket. +waitPoll :: PrimarySocketPath -> IO () +waitPoll socket = + check maxRetries + where + check 0 = throwIO (userError "GHC server didn't respond within 3 seconds") + check n = + try connect >>= \case + Right () -> pure () + Left (_ :: IOError) -> do + threadDelay 100_000 + check (n - 1) + + -- The part that throws is in @withConnection@, so this has to be executed every time. + connect = + withConnection def (ServerUnix socket.path) \ connection -> + withRPC connection def (Proxy @(Protobuf Worker "execute")) \ call -> + sendFinalInput call messageExecute <* recvNextOutput call + +-- | Wait for a GHC server process to respond and check its exit code. +waitForCentralGhc :: ProcessHandle -> PrimarySocketPath -> IO () +waitForCentralGhc proc socket = do + dbg "Waiting for server" + waitPoll socket + dbg "Server is up" + exitCode <- getProcessExitCode proc + when (isJust exitCode) do + dbg "Spawned process for the GHC server exited after starting up." + +-- | Spawn a child process executing the worker executable (which usually is the same as this process), for the purpose +-- of running a GHC server to which all worker processes then forward their requests. +-- Afterwards, wait for the server to be responsive. +forkCentralGhc :: WorkerExe -> SocketDirectory -> IO PrimarySocketPath +forkCentralGhc exe socketDir = do + dbg ("Forking GHC server at " ++ primary.path) + proc <- spawnProcess exe.path ["--make", "--serve", primary.path] + waitForCentralGhc proc primary + pure primary + where + primary = primarySocketIn socketDir + +-- | Run a GHC server synchronously. +runCentralGhcSpawned :: CreateMethods -> ServerSocketPath -> IO () +runCentralGhcSpawned methods socket = + runCentralGhc methods primaryFile socket instr + where + instr = Just (instrumentSocketIn dir) + + primaryFile = primarySocketDiscoveryIn dir + + dir = spawnedSocketDirectory socket + +-- | Run a server if this process is the primary worker, otherwise return the primary's socket path. -- Since multiple workers are started in separate processes, we negotiate using file system locks. -- There are two major scenarios: -- -- - When the build is started, multiple workers are spawned concurrently, and no primary exists. --- We use the common prefix of the worker sockets (something like `/tmp/buck2_worker/`) to create a lock file. +-- We create a lock file in the provided socket directory. -- The first worker that wins the lock in `withFileBlocking` gets to be primary, and writes its socket path to --- `/tmp/buck2_worker//primary`. +-- `$socket_dir/primary`. -- All other workers then own the lock in sequence and proceed with the second scenario. -- -- - When the build is running and a primary exists, either because the worker lost the inital lock race or was started -- later in the build due to dependencies and/or parallelism limits, the contents of the `primary` file are read to -- obtain the primary's socket path. -- A gRPC server is started that resends all requests to that socket. -runOrProxyCentralGhc :: CreateMethods -> ServerSocketPath -> IO () -runOrProxyCentralGhc mode socket = do - void $ try @IOError (createDirectory dir) - result <- withFileBlocking primaryFile.path ReadWriteMode \ handle -> do - try @IOError (hGetLine handle) >>= \case - -- If the file didn't exist, `hGetLine` will still return the empty string. - -- File IO is buffered/lazy, so we have to force the pattern to avoid read after close (though this is already - -- achieved by calling `null`). - Right !primary | not (null primary) -> do - pure (Left (PrimarySocketPath primary)) - _ -> do - thread <- async (runCentralGhc mode primaryFile socket instr) - hPutStr handle socket.path - pure (Right thread) - case result of - Right thread -> onException (wait thread) (cancel thread) +runOrProxyCentralGhc :: + SocketDirectory -> + (PrimarySocketDiscoveryPath -> IO (PrimarySocketPath, a)) -> + IO (Either PrimarySocketPath (PrimarySocketPath, a)) +runOrProxyCentralGhc socketDir runServer = do + void $ try @IOError (createDirectoryIfMissing True socketDir.path) + withFile primaryFile.path ReadWriteMode \ handle -> do + bracket_ (hLock handle ExclusiveLock) (hUnlock handle) do + try @IOError (hGetLine handle) >>= \case + -- If the file didn't exist, `hGetLine` will still return the empty string in some GHC versions. + -- File IO is buffered/lazy, so we have to force the string to avoid read after close. + Right !primary | not (null (force primary)) -> do + pure (Left (PrimarySocketPath primary)) + _ -> do + (primary, resource) <- runServer primaryFile + hPutStr handle primary.path + pure (Right (primary, resource)) + where + primaryFile = primarySocketDiscoveryIn socketDir + +-- | Start a gRPC server that either runs GHC (primary server) or a proxy that forwards requests to the primary. +serveOrProxyCentralGhc :: CreateMethods -> ServerSocketPath -> IO () +serveOrProxyCentralGhc mode socket = do + runOrProxyCentralGhc socketDir run >>= \case + Right (_, thread) -> onException (wait thread) (cancel thread) Left primary -> proxyServer primary socket where - primaryFile = primarySocketDiscoveryIn dir - instr = Just (instrumentSocketIn dir) - dir = init (dropWhileEnd ('-' /=) (takeDirectory socket.path)) + run primaryFile = do + let primary = PrimarySocketPath socket.path + thread <- async (runCentralGhc mode primaryFile socket instr) + waitPoll primary + pure (primary, thread) + + instr = Just (instrumentSocketIn socketDir) + + socketDir = SocketDirectory (init (dropWhileEnd ('-' /=) (takeDirectory socket.path))) + +-- | Start a proxy gRPC server that forwards requests to the central GHC server. +-- If that server isn't running, spawn a process and wait for it to boot up. +spawnOrProxyCentralGhc :: WorkerExe -> ServerSocketPath -> IO () +spawnOrProxyCentralGhc exe socket = do + socketDir <- projectSocketDirectory + primary <- runOrProxyCentralGhc socketDir \ _ -> do + primary <- forkCentralGhc exe socketDir + pure (primary, ()) + proxyServer (either id fst primary) socket diff --git a/buck-worker/lib/Run.hs b/buck-worker/lib/Run.hs index 1c8fc582..4d31f702 100644 --- a/buck-worker/lib/Run.hs +++ b/buck-worker/lib/Run.hs @@ -4,7 +4,6 @@ import BuckWorker (Instrument, Worker) import Control.Concurrent (MVar, newChan, newMVar) import Control.Concurrent.Chan (Chan) import Control.Exception (throwIO) -import Control.Monad (foldM) import GhcHandler (WorkerMode (..), ghcHandler) import Grpc (ghcServerMethods, instrumentMethods) import Instrumentation (WorkerStatus (..), toGrpcHandler) @@ -12,7 +11,16 @@ import Internal.Cache (Cache (..), CacheFeatures (..), emptyCache, emptyCacheWit import Network.GRPC.Common.Protobuf (Proto) import Network.GRPC.Server.Protobuf (ProtobufMethodsOf) import Network.GRPC.Server.StreamType (Methods) -import Orchestration (CreateMethods (..), ServerSocketPath, runLocalGhc, runOrProxyCentralGhc) +import Orchestration ( + CreateMethods (..), + Orchestration (..), + ServerSocketPath (..), + WorkerExe (..), + runCentralGhcSpawned, + runLocalGhc, + serveOrProxyCentralGhc, + spawnOrProxyCentralGhc, + ) import qualified Proto.Instrument as Instr -- | Global options for the worker, passed when the process is started, in contrast to request options stored in @@ -20,22 +28,42 @@ import qualified Proto.Instrument as Instr data CliOptions = CliOptions { -- | Should only a single central GHC server be run, with all other worker processes proxying it? - single :: Bool, + orchestration :: Orchestration, -- | The worker implementation: Make mode or oneshot mode. - workerMode :: WorkerMode + workerMode :: WorkerMode, + + -- | The path to the @buck-worker@ executable. + -- Usually this is the same executable that started the process, but we cannot access it reliably. + -- Used to spawn the GHC server, provided by Buck. + workerExe :: Maybe WorkerExe, + + -- | If this is given, the app should start a GHC server synchronously, listening on the given path. + serve :: Maybe ServerSocketPath } deriving stock (Eq, Show) defaultCliOptions :: CliOptions -defaultCliOptions = CliOptions {single = False, workerMode = WorkerOneshotMode} +defaultCliOptions = + CliOptions { + orchestration = Multi, + workerMode = WorkerOneshotMode, + workerExe = Nothing, + serve = Nothing + } parseOptions :: [String] -> IO CliOptions parseOptions = - flip foldM defaultCliOptions \ z -> \case - "--single" -> pure z {single = True} - "--make" -> pure z {workerMode = WorkerMakeMode} - arg -> throwIO (userError ("Invalid worker CLI arg: " ++ arg)) + spin defaultCliOptions + where + spin z = \case + [] -> pure z + "--single" : rest -> spin z {orchestration = Single} rest + "--spawn" : rest -> spin z {orchestration = Spawn} rest + "--make" : rest -> spin z {workerMode = WorkerMakeMode} rest + "--exe" : exe : rest -> spin z {workerExe = Just (WorkerExe exe)} rest + "--serve" : socket : rest -> spin z {serve = Just (ServerSocketPath socket)} rest + arg -> throwIO (userError ("Invalid worker CLI args: " ++ unwords arg)) -- | Allocate a communication channel for instrumentation events and construct a gRPC server handler that streams said -- events to a client. @@ -58,7 +86,7 @@ createGhcMethods cache workerMode status instrChan = -- | Main function for running the default persistent worker using the provided server socket path and CLI options. runWorker :: ServerSocketPath -> CliOptions -> IO () -runWorker socket CliOptions {single, workerMode} = do +runWorker socket CliOptions {orchestration, workerMode, workerExe, serve} = do cache <- case workerMode of WorkerMakeMode -> @@ -77,6 +105,15 @@ runWorker socket CliOptions {single, workerMode} = do createInstrumentation = createInstrumentMethods, createGhc = createGhcMethods cache workerMode status } - if single - then runOrProxyCentralGhc methods socket - else runLocalGhc methods socket Nothing + runSpawn = do + exe <- case workerExe of + Just exe -> pure exe + Nothing -> throwIO (userError "Spawn mode requires specifying the worker executable with '--exe'") + spawnOrProxyCentralGhc exe socket + case serve of + Just serverSocket -> runCentralGhcSpawned methods serverSocket + Nothing -> + case orchestration of + Single -> serveOrProxyCentralGhc methods socket + Multi -> runLocalGhc methods socket Nothing + Spawn -> runSpawn diff --git a/buck-worker/test/CompileHptTest.hs b/buck-worker/test/CompileHptTest.hs index 817806ed..8b151a14 100644 --- a/buck-worker/test/CompileHptTest.hs +++ b/buck-worker/test/CompileHptTest.hs @@ -8,6 +8,7 @@ import Data.Char (toUpper) import Data.Foldable (for_, traverse_) import Data.Functor (void, (<&>)) import Data.List (intercalate) +import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe, isNothing) import qualified Data.Set as Set import Data.Set (Set) @@ -41,11 +42,12 @@ import Internal.Cache (Cache (..), Target (..), mergeHugs, newFinderCache, updat import Internal.CompileHpt (adaptHp, compileModuleWithDepsInHpt, initUnit) import Internal.Debug (showHugShort, showModGraph) import Internal.Log (dbg, dbgp, dbgs, newLog) -import Internal.Session (Env (..), dummyLocation, withGhcMhu, withGhcInSession, withUnitSpecificOptions) +import Internal.Session (Env (..), dummyLocation, withGhcInSession, withGhcMhu, withUnitSpecificOptions) import Prelude hiding (log) -import System.Directory (listDirectory) -import System.FilePath (dropExtension, takeDirectory, takeExtension, takeFileName, ()) +import System.Directory (listDirectory, removeDirectoryRecursive, createDirectoryIfMissing) +import System.FilePath (dropExtension, takeDirectory, takeExtension, takeFileName, (), takeBaseName) import TestSetup (Conf (..), UnitConf (..), UnitMod (..), withProject) +import Data.List.NonEmpty (NonEmpty) debugState :: Bool debugState = False @@ -91,7 +93,8 @@ loadModuleGraph env UnitMod {src} specific = do -- running downsweep, and merging the resulting module graph into the persisted state. makeModule :: Conf -> [UnitConf] -> UnitMod -> StateT (Set String) IO () makeModule Conf {..} units umod@UnitMod {unit, src, deps} = do - log <- newLog False + log <- newLog True + liftIO $ createDirectoryIfMissing False sessionTmpDir let env = Env {log, cache, args} envC = env {args = env.args {ghcOptions = env.args.ghcOptions}} firstTime <- state \ seen -> @@ -138,11 +141,6 @@ makeModule Conf {..} units umod@UnitMod {unit, src, deps} = do dbg "" dbg (">>> compiling " ++ takeFileName target.get) modifySession $ hscUpdateFlags \ d -> d {ghcMode = CompManager} - when False do - cache' <- liftIO $ readMVar env.cache - modifySessionM \ hsc_env -> do - hsc_FC <- liftIO $ newFinderCache env.cache cache' target - pure hsc_env {hsc_FC} compileModuleWithDepsInHpt specific target when (isNothing result) do liftIO $ throwGhcExceptionIO (ProgramError "Compile failed") @@ -150,9 +148,13 @@ makeModule Conf {..} units umod@UnitMod {unit, src, deps} = do where args = args0 { - ghcOptions = args0.ghcOptions ++ fileOptions + ghcOptions = args0.ghcOptions ++ fileOptions, + -- Ensure that each module gets a separate temp directory, to resemble circumstances in a Buck build + tempDir = Just sessionTmpDir } + sessionTmpDir = tmp "tmp" takeBaseName src + fileOptions = [ "-i", @@ -238,7 +240,7 @@ main = print $(bug) -} -targets1 :: Conf -> [UnitMod] +targets1 :: Conf -> NonEmpty UnitMod targets1 conf = [ unitMod conf [] "Err" "unit-a" errContent, @@ -313,7 +315,7 @@ mainContent deps = where names = [c : show i | (c, i) <- deps] -targets2 :: Conf -> [UnitMod] +targets2 :: Conf -> NonEmpty UnitMod targets2 conf = [ unitMod conf [] "Err" "unit-b" errContent, @@ -335,11 +337,28 @@ targets2 conf = m1d = modType1 conf -testWorker :: (Conf -> [UnitMod]) -> IO () +removeGhcTmpDir :: Conf -> IO () +removeGhcTmpDir conf = do + dirs <- liftIO (listDirectory (conf.tmp "tmp")) + for_ dirs \ ghcTmpRel -> do + let ghcTmp = conf.tmp "tmp" ghcTmpRel + liftIO $ removeDirectoryRecursive ghcTmp + +testWorker :: (Conf -> NonEmpty UnitMod) -> IO () testWorker mkTargets = - withProject (pure . mkTargets) \ conf units targets -> do - evalStateT (traverse_ (makeModule conf units) targets) Set.empty + withProject (pure . mkTargets) \ conf units targets -> + flip evalStateT Set.empty do + traverse_ (makeModule conf units) targets + -- Simulate the case of Buck deleting the temp dir and recompiling a module, which goes unnoticed by GHC because + -- it tracks all created temp dirs in an @IORef@ that the worker shares across sessions. + -- When initializing a new module session, all dirs already present in the state are assumed to exist on disk and + -- not recreated. + -- As a consequence, it will try to write the assembly files @ghc_1.s@ to a nonexistent directory, so we have to + -- ensure that each session gets its own @TmpFs@. + liftIO (removeGhcTmpDir conf) + makeModule conf units (NonEmpty.last targets) -- | A very simple test consisting of two home units, using a transitive TH dependency across unit boundaries. test_compileHpt :: IO () -test_compileHpt = testWorker targets1 +test_compileHpt = + testWorker targets1 diff --git a/buck-worker/test/TestSetup.hs b/buck-worker/test/TestSetup.hs index 620d0b2c..7ed5232c 100644 --- a/buck-worker/test/TestSetup.hs +++ b/buck-worker/test/TestSetup.hs @@ -77,7 +77,7 @@ baseArgs topdir tmp = workerTargetId = Just "test", env = mempty, binPath = [], - tempDir = Just (tmp "tmp"), + tempDir = Nothing, ghcPath = Nothing, ghcOptions = (artifactDir =<< ["o", "hie", "dump"]) ++ [ "-fwrite-ide-info", @@ -145,8 +145,8 @@ createDbUnitMod conf mods@(mod0 :| _) = do -- | Set up an environment with dummy package DBs for the set of modules returned by the first argument, then run the -- second argument with the resulting unit configurations. withProject :: - (Conf -> IO [UnitMod]) -> - (Conf -> [UnitConf] -> [UnitMod] -> IO a) -> + (Conf -> IO (NonEmpty UnitMod)) -> + (Conf -> [UnitConf] -> NonEmpty UnitMod -> IO a) -> IO a withProject mkTargets use = withSystemTempDirectory "buck-worker-test" \ tmp -> do @@ -170,6 +170,6 @@ withProject mkTargets use = for_ targets \ UnitMod {src, content} -> do createDirectoryIfMissing False (takeDirectory src) writeFile src content - let unitMods = NonEmpty.groupAllWith (.unit) targets + let unitMods = NonEmpty.groupAllWith (.unit) (toList targets) units <- traverse (createDbUnitMod conf) unitMods use conf units targets diff --git a/cabal.project b/cabal.project index a3151259..e60be93c 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,12 @@ packages: ./plugin -- For MWB-customized GHC, turn this on. -- flags: +mwb +package buck-worker + executable-dynamic: true + +package buck-multiplex-worker + executable-dynamic: true + allow-newer: proto-lens:base diff --git a/plugin/src/Internal/Cache.hs b/plugin/src/Internal/Cache.hs index 7f044c21..5e98cc60 100644 --- a/plugin/src/Internal/Cache.hs +++ b/plugin/src/Internal/Cache.hs @@ -66,8 +66,6 @@ import GHC.Unit.Module.Graph (ModuleGraphNode (..), mgModSummaries', mkModuleGra #endif -import GHC.Unit.Module.Graph (ModuleGraph, unionMG) - data ModuleArtifacts = ModuleArtifacts { iface :: ModIface, diff --git a/plugin/src/Internal/MakeFile.hs b/plugin/src/Internal/MakeFile.hs index 53235081..03ca8588 100644 --- a/plugin/src/Internal/MakeFile.hs +++ b/plugin/src/Internal/MakeFile.hs @@ -67,7 +67,7 @@ import GHC.Unit (homeUnitId) import GHC.Utils.Panic.Plain #endif -#if !defined(MWB) +#if !defined(MWB) && !defined(TCR) depJSON :: DynFlags -> Maybe FilePath depJSON _ = Nothing diff --git a/plugin/src/Internal/MakeFile/JSON.hs b/plugin/src/Internal/MakeFile/JSON.hs index 15370304..be42ab7e 100644 --- a/plugin/src/Internal/MakeFile/JSON.hs +++ b/plugin/src/Internal/MakeFile/JSON.hs @@ -36,7 +36,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import System.FilePath (normalise) -#if !defined(MWB) +#if !defined(MWB) && !defined(TCR) import GHC.Data.FastString (lexicalCompareFS) instance Ord PackageId where diff --git a/plugin/src/Internal/Session.hs b/plugin/src/Internal/Session.hs index 8ff0f2b8..a3c73b65 100644 --- a/plugin/src/Internal/Session.hs +++ b/plugin/src/Internal/Session.hs @@ -20,7 +20,7 @@ import GHC ( prettyPrintGhcErrors, pushLogHookM, setSessionDynFlags, - withSignalHandlers, + withSignalHandlers, gopt, GeneralFlag (Opt_KeepTmpFiles), ) import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) import GHC.Driver.Config.Logger (initLogFlags) @@ -33,13 +33,14 @@ import GHC.Runtime.Loader (initializeSessionPlugins) import GHC.Types.SrcLoc (Located, mkGeneralLocated, unLoc) import GHC.Utils.Logger (Logger, getLogger, setLogFlags) import GHC.Utils.Panic (GhcException (UsageError), panic, throwGhcException) -import GHC.Utils.TmpFs (TempDir (..)) +import GHC.Utils.TmpFs (TempDir (..), initTmpFs, cleanTempFiles, cleanTempDirs) import Internal.Args (Args (..)) import Internal.Cache (BinPath (..), Cache (..), CacheFeatures (..), ModuleArtifacts, Target (..), withCache) import Internal.Error (handleExceptions) import Internal.Log (Log (..), logToState) import Prelude hiding (log) import System.Environment (setEnv) +import Control.Exception (finally) -- | Worker state. data Env = @@ -119,27 +120,46 @@ withGhcInSession env prog argv = do -- | Create a base session and store it in the cache. -- On subsequent calls, return the cached session, unless the cache is disabled or @reuse@ is true. -- This will at some point be replaced by more deliberate methods. +-- +-- When reusing the base session, create a new @TmpFs@ to avoid keeping old entries around after Buck deletes the +-- directories. ensureSession :: Bool -> MVar Cache -> Args -> IO HscEnv ensureSession reuse cacheVar args = modifyMVar cacheVar \ cache -> do if cache.features.enable && reuse then do - newEnv <- maybe (initHscEnv args.topdir) pure cache.baseSession + newEnv <- maybe (initHscEnv args.topdir) prepReused cache.baseSession pure (cache {baseSession = Just newEnv}, newEnv) else do newEnv <- initHscEnv args.topdir pure (cache, newEnv) + where + prepReused hsc_env = do + hsc_tmpfs <- initTmpFs + pure hsc_env {hsc_tmpfs} -- | Run a @Ghc@ program to completion with a fresh clone of the base session. -- See 'ensureSession' for @reuse@. +-- +-- Delete all temporary files on completion. runSession :: Bool -> Env -> ([Located String] -> Ghc (Maybe a)) -> IO (Maybe a) runSession reuse Env {log, args, cache} prog = do modifyMVar_ cache (setupPath args) hsc_env <- ensureSession reuse cache args session <- Session <$> newIORef hsc_env - flip unGhc session $ withSignalHandlers do - traverse_ (modifySession . setTempDir) args.tempDir - handleExceptions log Nothing (prog (map dummyLocation args.ghcOptions)) + finally (run session) (cleanup hsc_env) + where + run session = + flip unGhc session $ withSignalHandlers do + traverse_ (modifySession . setTempDir) args.tempDir + handleExceptions log Nothing (prog (map dummyLocation args.ghcOptions)) + + cleanup hsc_env = + unless (gopt Opt_KeepTmpFiles (hsc_dflags hsc_env)) do + let tmpfs = hsc_tmpfs hsc_env + logger = hsc_logger hsc_env + cleanTempFiles logger tmpfs + cleanTempDirs logger tmpfs -- | When compiling a module, the leftover arguments from parsing @DynFlags@ should be a single source file path. -- Wrap it in 'Target' or terminate.