Exfiltrate compilation artifacts

* Move pipeline creation into local code
* Return ModIface and the bytecode Linkable instead of discarding the entire HomeModInfo
* Extract ABI hash from that ModIface
* Add an override for FinderCache that records some statistics

buck-multiplex-worker/Main.hs

@@ -2,7 +2,6 @@
 
 module Main where
 
-import Internal.Log (dbg)
 import BuckArgs (BuckArgs (..), CompileResult (..), parseBuckArgs, toGhcArgs, writeResult)
 import BuckWorker (
   ExecuteCommand (..),
@@ -20,6 +19,7 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
 import Control.Monad.Trans.Reader (runReaderT)
 import Data.Foldable (traverse_)
+import Data.Functor ((<&>))
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (maybeToList)
@@ -31,7 +31,7 @@ import qualified Data.Vector as Vector
 import GHC (getSession)
 import Internal.AbiHash (readAbiHash)
 import Internal.Args (Args (..))
-import Internal.Cache (Cache (..), emptyCache)
+import Internal.Cache (Cache (..), ModuleArtifacts (..), emptyCache)
 import Internal.Log (newLog)
 import Internal.Session (Env (..), withGhc)
 import Message
@@ -63,8 +63,8 @@ abiHashIfSuccess env args code
   | 0 == code
   = withGhc env \ _ -> do
     hsc_env <- getSession
-    abiHash <- readAbiHash hsc_env args.abiOut
-    pure (Just CompileResult {abiHash})
+    readAbiHash hsc_env args.abiOut <&> fmap \ (iface, abiHash) ->
+      CompileResult {artifacts = ModuleArtifacts {iface, bytecode = Nothing}, abiHash = Just abiHash}
   | otherwise
   = pure Nothing
 
@@ -89,8 +89,6 @@ processRequest pool buckArgs env@Env {args} = do
           }
       Response {responseResult = code, ..} <- runReaderT (work req) (j, i, hset, pool)
       result <- abiHashIfSuccess env buckArgs code
-      dbg ("Code: " ++ show code)
-      dbg ("Result: " ++ show result)
       when (requestWorkerClose req) do
         traverse_ (removeWorker pool) requestWorkerTargetId
       dumpStatus pool

buck-worker/Main.hs

@@ -13,16 +13,17 @@ import BuckWorker (
   )
 import Control.Concurrent.MVar (MVar)
 import Control.Exception (SomeException (SomeException), throwIO, try)
+import Control.Monad (when)
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
 import Data.String (fromString)
 import qualified Data.Text as Text
 import Data.Text.Encoding (decodeUtf8Lenient)
 import qualified Data.Text.Lazy as LazyText
 import qualified Data.Vector as Vector
-import GHC (Ghc, Phase, getSession)
-import Internal.AbiHash (readAbiHash)
-import Internal.Cache (Cache (..), emptyCache)
+import GHC (Ghc, getSession)
+import Internal.AbiHash (AbiHash (..), showAbiHash)
+import Internal.Cache (Cache (..), ModuleArtifacts (..), Target, emptyCache)
 import Internal.Compile (compile)
 import Internal.Log (logFlush, newLog)
 import Internal.Session (Env (..), withGhc)
@@ -46,19 +47,24 @@ commandEnv =
   where
     fromBs = Text.unpack . decodeUtf8Lenient
 
-compileAndReadAbiHash :: BuckArgs -> [(String, Maybe Phase)] -> Ghc (Maybe CompileResult)
-compileAndReadAbiHash args srcs = do
-  compile srcs
-  hsc_env <- getSession
-  abiHash <- readAbiHash hsc_env args.abiOut
-  pure (Just CompileResult {abiHash})
+compileAndReadAbiHash :: BuckArgs -> Target -> Ghc (Maybe CompileResult)
+compileAndReadAbiHash args target = do
+  compile target >>= traverse \ artifacts -> do
+    hsc_env <- getSession
+    let
+      abiHash :: Maybe AbiHash
+      abiHash = do
+        path <- args.abiOut
+        Just AbiHash {path, hash = showAbiHash hsc_env artifacts.iface}
+    pure CompileResult {artifacts, abiHash}
 
 executeHandler ::
   MVar Cache ->
   ServerRequest 'Normal ExecuteCommand ExecuteResponse ->
   IO (ServerResponse 'Normal ExecuteResponse)
 executeHandler cache (ServerNormalRequest _ ExecuteCommand {executeCommandArgv, executeCommandEnv}) = do
-  -- hPutStrLn stderr (unlines argv)
+  when False do
+    hPutStrLn stderr (unlines argv)
   response <- either exceptionResponse successResponse =<< try run
   pure (ServerNormalResponse response [] StatusOk "")
   where

buck-worker/lib/BuckArgs.hs

@@ -1,5 +1,3 @@
-{-# language OverloadedLists #-}
-
 module BuckArgs where
 
 import Control.Applicative ((<|>))
@@ -12,14 +10,16 @@ import Data.Maybe (fromMaybe)
 import Internal.AbiHash (AbiHash (..))
 import qualified Internal.Args
 import Internal.Args (Args (Args))
+import Internal.Cache (ModuleArtifacts)
 
 -- | Right now the 'Maybe' just corresponds to the presence of the CLI argument @--abi-out@ – errors occuring while
 -- reading the iface are thrown.
 data CompileResult =
   CompileResult {
+    artifacts :: ModuleArtifacts,
     abiHash :: Maybe AbiHash
   }
-  deriving stock (Eq, Show)
+  deriving stock (Show)
 
 data BuckArgs =
   BuckArgs {

plugin/src/Internal/AbiHash.hs

@@ -5,7 +5,7 @@ import GHC.Driver.Config.Logger (initLogFlags)
 import GHC.Driver.Env (HscEnv (..))
 import GHC.Driver.Session (targetProfile)
 import GHC.Iface.Binary (CheckHiWay (IgnoreHiWay), TraceBinIFace (QuietBinIFace), readBinIface)
-import GHC.Unit.Module.ModIface (mi_final_exts, mi_mod_hash)
+import GHC.Unit.Module.ModIface (mi_final_exts, mi_mod_hash, ModIface)
 import GHC.Utils.Logger (LogFlags (..), log_default_dump_context)
 import GHC.Utils.Outputable (ppr, renderWithContext)
 import System.FilePath (dropExtension)
@@ -17,16 +17,20 @@ data AbiHash =
   }
   deriving stock (Eq, Show)
 
+showAbiHash :: HscEnv -> ModIface -> String
+showAbiHash HscEnv {hsc_dflags} iface =
+  dump hsc_dflags (mi_mod_hash (mi_final_exts iface))
+  where
+    dump dflags = renderWithContext (log_default_dump_context (initLogFlags dflags)) . ppr
+
 readAbiHash ::
   MonadIO m =>
   HscEnv ->
   Maybe String ->
-  m (Maybe AbiHash)
-readAbiHash HscEnv {hsc_dflags, hsc_NC} (Just path) = do
+  m (Maybe (ModIface, AbiHash))
+readAbiHash hsc_env@HscEnv {hsc_dflags, hsc_NC} (Just path) = do
   let hi_file = dropExtension path
   iface <- liftIO $ readBinIface (targetProfile hsc_dflags) hsc_NC IgnoreHiWay QuietBinIFace hi_file
-  pure (Just (AbiHash {path, hash = dump hsc_dflags (mi_mod_hash (mi_final_exts iface))}))
-  where
-    dump dflags = renderWithContext (log_default_dump_context (initLogFlags dflags)) . ppr
+  pure (Just (iface, AbiHash {path, hash = showAbiHash hsc_env iface}))
 
 readAbiHash _ _ = pure Nothing