Use object files rather than bytecode for Template Haskell

exe/Main.hs

@@ -246,6 +246,7 @@ targetToFile _ (TargetFile f _) = do
 setNameCache :: IORef NameCache -> HscEnv -> HscEnv
 setNameCache nc hsc = hsc { hsc_NC = nc }
 
+
 -- This is the key function which implements multi-component support. All
 -- components mapping to the same hie,yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
@@ -505,6 +506,7 @@ setCacheDir prefix hscComponents comps dflags = do
     pure $ dflags
           & setHiDir cacheDir
           & setDefaultHieDir cacheDir
+          & setODir cacheDir
 
 
 renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic
@@ -576,7 +578,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
           -- also, it can confuse the interface stale check
           dontWriteHieFiles $
           setIgnoreInterfacePragmas $
-          setLinkerOptions $
+          --setLinkerOptions $
           disableOptimisation dflags'
     -- initPackages parses the -package flags and
     -- sets up the visibility for each component.
@@ -588,12 +590,14 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
 -- we don't want to generate object code so we compile to bytecode
 -- (HscInterpreted) which implies LinkInMemory
 -- HscInterpreted
+{-
 setLinkerOptions :: DynFlags -> DynFlags
 setLinkerOptions df = df {
     ghcLink   = LinkInMemory
   , hscTarget = HscNothing
   , ghcMode = CompManager
   }
+  -}
 
 setIgnoreInterfacePragmas :: DynFlags -> DynFlags
 setIgnoreInterfacePragmas df =
@@ -607,6 +611,11 @@ setHiDir f d =
     -- override user settings to avoid conflicts leading to recompilation
     d { hiDir      = Just f}
 
+setODir :: FilePath -> DynFlags -> DynFlags
+setODir f d =
+    -- override user settings to avoid conflicts leading to recompilation
+    d { objectDir      = Just f}
+
 getCacheDir :: String -> [String] -> IO FilePath
 getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
     where

src/Development/IDE/Core/Compile.hs

@@ -17,15 +17,18 @@ module Development.IDE.Core.Compile
   , addRelativeImport
   , mkTcModuleResult
   , generateByteCode
+  , generateObjectCode
   , generateAndWriteHieFile
   , generateAndWriteHiFile
   , getModSummaryFromImports
   , loadHieFile
+  , generateAndWriteOFile
   , loadInterface
   , loadDepModule
   , loadModuleHome
   ) where
 
+import Data.ByteString as BS (ByteString, readFile)
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Preprocessor
 import Development.IDE.Core.Shake
@@ -37,7 +40,10 @@ import Development.IDE.GHC.Util
 import qualified GHC.LanguageExtensions.Type as GHC
 import Development.IDE.Types.Options
 import Development.IDE.Types.Location
+import DriverPhases
 import Outputable
+import HscTypes
+import DriverPipeline hiding (unP)
 
 #if MIN_GHC_API_VERSION(8,6,0)
 import           DynamicLoading (initializePlugins)
@@ -57,13 +63,13 @@ import qualified Development.IDE.GHC.Compat     as Compat
 import           GhcMonad
 import           GhcPlugins                     as GHC hiding (fst3, (<>))
 import qualified HeaderInfo                     as Hdr
-import           HscMain                        (hscInteractive, hscSimplify)
+import           HscMain                        (hscInteractive, hscSimplify, hscGenHardCode)
 import           LoadIface                      (readIface)
 import qualified Maybes
 import           MkIface
 import           NameCache
 import           StringBuffer                   as SB
-import           TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
+import           TcRnMonad
 import           TcIface                        (typecheckIface)
 import           TidyPgm
 
@@ -165,15 +171,12 @@ newtype RunSimplifier = RunSimplifier Bool
 compileModule
     :: RunSimplifier
     -> HscEnv
-    -> [(ModSummary, HomeModInfo)]
     -> TcModuleResult
     -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
-compileModule (RunSimplifier simplify) packageState deps tmr =
+compileModule (RunSimplifier simplify) packageState tmr =
     fmap (either (, Nothing) (second Just)) $
     evalGhcEnv packageState $
         catchSrcErrors "compile" $ do
-            setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
-
             let tm = tmrModule tmr
             session <- getSession
             (warnings,desugar) <- withWarnings "compile" $ \tweak -> do
@@ -210,6 +213,28 @@ generateByteCode hscEnv deps tmr guts =
           let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
           pure (map snd warnings, linkable)
 
+generateObjectCode :: HscEnv -> TcModuleResult -> IO (IdeResult Linkable)
+generateObjectCode hscEnv tmr = do
+    (compile_diags, Just (_, guts, _)) <- compileModule (RunSimplifier True) hscEnv tmr
+    fmap (either (, Nothing) (second Just)) $
+        evalGhcEnv hscEnv $
+          catchSrcErrors "object" $ do
+              session <- getSession
+              let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
+              let dot_o =  ml_obj_file (ms_location summary)
+              let session' = session { hsc_dflags = (hsc_dflags session) { outputFile = Just dot_o }}
+                  fp = replaceExtension dot_o "s"
+              liftIO $ createDirectoryIfMissing True (takeDirectory fp)
+              (warnings, dot_o_fp) <-
+                withWarnings "object" $ \tweak -> liftIO $ do
+                      _ <- hscGenHardCode session guts
+                                (tweak $ summary)
+                                fp
+                      compileFile session' StopLn (fp, Just (As False))
+              let unlinked = DotO dot_o_fp
+              let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
+              pure (compile_diags ++ map snd warnings, linkable)
+
 demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
 demoteTypeErrorsToWarnings =
   (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where
@@ -324,6 +349,11 @@ handleGenerationErrors dflags source action =
     ]
 
 
+generateAndWriteOFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
+generateAndWriteOFile hscEnv tc = do
+    (diags, _) <- generateObjectCode hscEnv tc
+    return diags
+
 -- | Setup the environment that GHC needs according to our
 -- best understanding (!)
 --

src/Development/IDE/Core/RuleTypes.hs

@@ -109,6 +109,9 @@ type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
 -- | Generate byte code for template haskell.
 type instance RuleResult GenerateByteCode = Linkable
 
+-- | Generate object file for template haskell.
+type instance RuleResult GetObjectFile = Linkable
+
 -- | A GHC session that we reuse.
 type instance RuleResult GhcSession = HscEnvEq
 
@@ -205,6 +208,12 @@ instance Hashable GenerateByteCode
 instance NFData   GenerateByteCode
 instance Binary   GenerateByteCode
 
+data GetObjectFile = GetObjectFile
+   deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetObjectFile
+instance NFData   GetObjectFile
+instance Binary   GetObjectFile
+
 data GhcSession = GhcSession
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GhcSession

src/Development/IDE/Core/Rules.hs

@@ -25,7 +25,6 @@ module Development.IDE.Core.Rules(
     highlightAtPoint,
     getDependencies,
     getParsedModule,
-    generateCore,
     ) where
 
 import Fingerprint
@@ -66,6 +65,7 @@ import Development.IDE.Core.RuleTypes
 import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Core.PositionMapping
 import           Language.Haskell.LSP.Types
+import Data.Ord
 
 import qualified GHC.LanguageExtensions as LangExt
 import HscTypes
@@ -509,13 +509,14 @@ typeCheckRuleDefinition file pm generateArtifacts = do
   deps <- use_ GetDependencies file
   hsc  <- hscEnv <$> use_ GhcSession file
   -- Figure out whether we need TemplateHaskell or QuasiQuotes support
+  -- hsc_mod_graph is never populated, this is bogus
   let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
       file_uses_th_qq   = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
       any_uses_th_qq    = graph_needs_th_qq || file_uses_th_qq
   mirs      <- uses_ GetModIface (transitiveModuleDeps deps)
   bytecodes <- if any_uses_th_qq
     then -- If we use TH or QQ, we must obtain the bytecode
-      fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
+      fmap Just <$> uses_ GetObjectFile (transitiveModuleDeps deps)
     else
       pure $ repeat Nothing
 
@@ -528,21 +529,21 @@ typeCheckRuleDefinition file pm generateArtifacts = do
       (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do
         (diagsHie,hf) <- generateAndWriteHieFile hsc (tmrModule tcm)
         diagsHi  <- generateAndWriteHiFile hsc tcm
-        return (diags <> diagsHi <> diagsHie, Just tcm{tmrHieFile=hf})
+        diagsO <- liftIO $ generateAndWriteOFile hsc tcm
+        return (diags <> diagsHi <> diagsHie <> diagsO, Just tcm { tmrHieFile = hf })
       (diags, res) -> return (diags, snd <$> res)
  where
   unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
   uses_th_qq dflags =
     xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
 
-
 generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
 generateCore runSimplifier file = do
-    deps <- use_ GetDependencies file
-    (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
+    -- deps <- use_ GetDependencies file
+    tm <- use_ TypeCheck file
     setPriority priorityGenerateCore
     packageState <- hscEnv <$> use_ GhcSession file
-    liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
+    liftIO $ compileModule runSimplifier packageState tm
 
 generateCoreRule :: Rules ()
 generateCoreRule =
@@ -557,6 +558,55 @@ generateByteCodeRule =
       (_, guts, _) <- use_ GenerateCore file
       liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
 
+
+getObjectFileRule :: Rules ()
+getObjectFileRule = define $ \GetObjectFile f -> do
+  -- get all dependencies interface files, to check for freshness
+  (deps,_) <- use_ GetLocatedImports f
+  depOs  <- traverse (use GetObjectFile) (mapMaybe (fmap artifactFilePath . snd) deps)
+
+  ms      <- use_ GetModSummary f
+  let oFile = case ms_hsc_src ms of
+                HsBootFile -> addBootSuffix (ml_obj_file $ ms_location ms)
+                _ -> ml_obj_file $ ms_location ms
+
+      mkDiag = pure . ideErrorWithSource (Just "object file loading") (Just DsInfo) f . T.pack
+
+  res <-
+    case sequence depOs of
+        Nothing -> do
+              let d = mkDiag $ "Missing dependencies for object file: " <> oFile
+              pure (d, Nothing)
+        Just _deps -> do
+          gotOFile <- getFileExists $ toNormalizedFilePath oFile
+          if not gotOFile
+            then do
+              let d = mkDiag ("Missing object file: " <> oFile)
+              pure (d, Nothing)
+            else do
+              oVersion  <- use_ GetModificationTime $ toNormalizedFilePath oFile
+              modVersion <- use_ GetModificationTime f
+              let sourceModified = LT == comparing modificationTime oVersion modVersion
+              if sourceModified
+                then do
+                  let d = mkDiag ("Stale o file: " <> oFile)
+                  pure (d, Nothing)
+                else do
+                  let linkable = LM (error "don'tlook") (ms_mod ms) ([DotO oFile])
+                  return ([], Just linkable)
+  let raw_diags = fst res
+  case snd res of
+    Just o -> return (raw_diags, Just o)
+    -- Need to regenerate it for some reason
+    Nothing -> do
+      pm <- use_ GetParsedModule f
+      (diags, mtmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles
+      case mtmr of
+        Nothing -> return (raw_diags ++ diags, Nothing)
+        Just _tmr -> do
+          let linkable = LM (error "don't check") (ms_mod ms) [DotO oFile]
+          return (diags, Just $ linkable)
+
 -- A local rule type to get caching. We want to use newCache, but it has
 -- thread killed exception issues, so we lift it to a full rule.
 -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
@@ -715,6 +765,7 @@ mainRule = do
     getDocMapRule
     generateCoreRule
     generateByteCodeRule
+    getObjectFileRule
     loadGhcSession
     getHiFileRule
     getModIfaceRule