ghc-the-library: Retain cafs in both static in dynamic builds.

We use keepCAFsForGHCi.c to force -fkeep-cafs behaviour by using a
__attribute__((constructor)) function.

This broke for static builds where the linker discarded the object file
since it was not reverenced from any exported code. We fix this by
asserting that the flag is enabled using a function in the same module
as the constructor. Which causes the object file to be retained by the
linker, which in turn causes the constructor the be run in static builds.

This changes nothing for dynamic builds using the ghc library. But causes
static to also retain CAFs (as we expect them to).

Fixes #22417.

-------------------------
Metric Decrease:
    T21839r
-------------------------

3 files changed, 42 insertions, 4 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index dfa5bf5ff2..e079a08cdd 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE TupleSections, NamedFieldPuns #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -ddump-stg-final -ddump-to-file #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -357,6 +358,7 @@ import GHC.Utils.Monad
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
 import GHC.Utils.Logger
 import GHC.Utils.Fingerprint
 
@@ -556,7 +558,16 @@ withCleanupSession ghc = ghc `MC.finally` cleanup
 -- <http://hackage.haskell.org/package/ghc-paths>.
 
 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
-initGhcMonad mb_top_dir = setSession =<< liftIO (initHscEnv mb_top_dir)
+initGhcMonad mb_top_dir = setSession =<< liftIO ( do
+    -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.
+    -- So we can't use assertM here.
+    -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.
+-- #if MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)
+    !keep_cafs <- c_keepCAFsForGHCi
+    massert keep_cafs
+-- #endif
+    initHscEnv mb_top_dir
+  )
 
 -- %************************************************************************
 -- %*                                                                      *
@@ -1948,3 +1959,8 @@ instance Exception GhcApiError
 
 mkApiErr :: DynFlags -> SDoc -> GhcApiError
 mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
+
+--
+foreign import ccall unsafe "keepCAFsForGHCi"
+    c_keepCAFsForGHCi   :: IO Bool
+
diff --git a/compiler/cbits/keepCAFsForGHCi.c b/compiler/cbits/keepCAFsForGHCi.c
index ba635b0d95..9645f54c9b 100644
--- a/compiler/cbits/keepCAFsForGHCi.c
+++ b/compiler/cbits/keepCAFsForGHCi.c
@@ -1,15 +1,35 @@
 #include <Rts.h>
+#include <ghcversion.h>
 
+// Note [keepCAFsForGHCi]
+// ~~~~~~~~~~~~~~~~~~~~~~
 // This file is only included in the dynamic library.
 // It contains an __attribute__((constructor)) function (run prior to main())
 // which sets the keepCAFs flag in the RTS, before any Haskell code is run.
 // This is required so that GHCi can use dynamic libraries instead of HSxyz.o
 // files.
+//
+// For static builds we have to guarantee that the linker loads this object file
+// to ensure the constructor gets run and not discarded. If the object is part of
+// an archive and not otherwise referenced the linker would ignore the object.
+// To avoid this:
+// * When initializing a GHC session in initGhcMonad we assert keeping cafs has been
+//   enabled by calling keepCAFsForGHCi.
+// * This causes the GHC module from the ghc package to carry a reference to this object
+//   file.
+// * Which in turn ensures the linker doesn't discard this object file, causing
+//   the constructor to be run, allowing the assertion to succeed in the first place
+//   as keepCAFs will have been set already during initialization of constructors.
 
-static void keepCAFsForGHCi(void) __attribute__((constructor));
 
-static void keepCAFsForGHCi(void)
+
+bool keepCAFsForGHCi(void) __attribute__((constructor));
+
+bool keepCAFsForGHCi(void)
 {
-    keepCAFs = 1;
+    bool was_set = keepCAFs;
+    setKeepCAFs();
+    return was_set;
 }
 
+
diff --git a/testsuite/tests/ghci/T16392/T16392.script b/testsuite/tests/ghci/T16392/T16392.script
index 5fdcb17dc0..ca570f0f28 100644
--- a/testsuite/tests/ghci/T16392/T16392.script
+++ b/testsuite/tests/ghci/T16392/T16392.script
@@ -1,5 +1,7 @@
 :set -fobject-code
+import System.Mem
 :load A.hs
 c_two caf
+performMajorGC
 :load A.hs
 c_two caf