From 83e70b14c70de5e0c59c55deac43b0b9b7b54203 Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Tue, 27 Aug 2024 20:18:25 +0200
Subject: [PATCH] Build foreign objects for TH with interpreter's way when
 loading from iface

Fixes #25211

When linking bytecode for TH from interface core bindings with
`-fprefer-byte-code`, foreign sources are loaded from the interface as
well and compiled to object code in an ad-hoc manner.

The results are then loaded by the interpreter, whose way may differ
from the current build's target way.

This patch ensures that foreign objects are compiled with the
interpreter's way.
---
 compiler/GHC/Driver/Main.hs                   | 31 ++++++++++++++++---
 compiler/GHC/Unit/Module/WholeCoreBindings.hs | 10 ++----
 2 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 68c9750555e..96b8f810d26 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE LambdaCase #-}
-
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -295,13 +294,13 @@ import Data.Time
 
 import System.IO.Unsafe ( unsafeInterleaveIO )
 import GHC.Iface.Env ( trace_if )
+import GHC.Platform.Ways
 import GHC.Stg.InferTags.TagSig (seqTagSig)
 import GHC.StgToCmm.Utils (IPEStats)
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.DFM
 import GHC.Cmm.Config (CmmConfig)
 
-
 {- **********************************************************************
 %*                                                                      *
                 Initialisation
@@ -990,6 +989,27 @@ initModDetails hsc_env iface =
     -- in make mode, since this HMI will go into the HPT.
     genModDetails hsc_env' iface
 
+-- | Modify flags such that objects are compiled for the interpreter's way.
+-- This is necessary when building foreign objects for Template Haskell, since
+-- those are object code built outside of the pipeline, which means they aren't
+-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build
+-- outputs for dependencies when the interpreter used for TH is dynamic but the
+-- main outputs aren't.
+-- Furthermore, the HPT only stores one set of objects with different names for
+-- bytecode linking in 'HomeModLinkable', so the usual hack for switching
+-- between ways in 'get_link_deps' doesn't work.
+compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a
+compile_for_interpreter hsc_env use =
+  use (hscUpdateFlags update hsc_env)
+  where
+    update dflags = dflags {
+      targetWays_ = adapt_way interpreterDynamic WayDyn $
+                    adapt_way interpreterProfiled WayProf $
+                    targetWays_ dflags
+      }
+
+    adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay
+
 -- | If the 'Linkable' contains Core bindings loaded from an interface, replace
 -- them with a lazy IO thunk that compiles them to bytecode and foreign objects.
 --
@@ -2063,9 +2083,10 @@ generateByteCode :: HscEnv
   -> IO (CompiledByteCode, [FilePath])
 generateByteCode hsc_env cgguts mod_location = do
   (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
-  stub_o <- traverse (compileForeign hsc_env LangC) hasStub
-  foreign_files_o <- traverse (uncurry (compileForeign hsc_env)) (cgi_foreign_files cgguts)
-  pure (comp_bc, maybeToList stub_o ++ foreign_files_o)
+  compile_for_interpreter hsc_env $ \ i_env -> do
+    stub_o <- traverse (compileForeign i_env LangC) hasStub
+    foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
+    pure (comp_bc, maybeToList stub_o ++ foreign_files_o)
 
 generateFreshByteCode :: HscEnv
   -> ModuleName
diff --git a/compiler/GHC/Unit/Module/WholeCoreBindings.hs b/compiler/GHC/Unit/Module/WholeCoreBindings.hs
index 2b1f716133d..5f9058239ce 100644
--- a/compiler/GHC/Unit/Module/WholeCoreBindings.hs
+++ b/compiler/GHC/Unit/Module/WholeCoreBindings.hs
@@ -190,13 +190,9 @@ Even if that wasn't an issue, they are compiled for the session's 'Way', not its
 associated module's, so the dynamic variant wouldn't be available when building
 only static outputs.
 
-For now, this doesn't have much of an impact, since we're only supporting
-foreign imports initially, which produce very simple objects that can easily be
-handled by the linker when 'GHC.Linker.Loader.dynLoadObjs' creates a shared
-library from all object file inputs.
-However, for more complex circumstances, we should compile foreign stubs
-specially for TH according to the interpreter 'Way', or request dynamic products
-for TH dependencies like it happens for the conventional case.
+To mitigate this, we instead build foreign objects specially for the
+interpreter, updating the build flags in 'compile_for_interpreter' to use the
+interpreter's way.
 
 Problem 4:
 
-- 
GitLab