Add -fkeep-cafs

Summary:
I noticed while playing around with
https://github.com/fbsamples/ghc-hotswap/ that the main binary needs to
have a custom main function to set `config.keep_cafs = true` when
initialising the runtime. This is pretty annoying, it means an extra
C file with some cryptic incantations in it, and a `-no-hs-main` flag.

So I've replaced this with a link-time flag to GHC, `-fkeep-cafs` that
does the same thing.

Test Plan:
New unit test that tests for the RTS's GC'd CAFs assertion, and also
the -keep-cafs flag.

Reviewers: bgamari, osa1, erikd, noamz

Reviewed By: osa1

Subscribers: rwbarton, carter

Differential Revision: https://phabricator.haskell.org/D5183

11 files changed, 107 insertions, 1 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e7e541b312..7726001a47 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -564,6 +564,7 @@ data GeneralFlag
    -- forwards all -L flags to the collect2 command without using a
    -- response file and as such breaking apart.
    | Opt_SingleLibFolder
+   | Opt_KeepCAFs
 
    -- output style opts
    | Opt_ErrorSpans -- Include full span info in error messages,
@@ -4003,7 +4004,8 @@ fFlagsDeps = [
   flagSpec "show-warning-groups"              Opt_ShowWarnGroups,
   flagSpec "hide-source-paths"                Opt_HideSourcePaths,
   flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,
-  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs
+  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,
+  flagSpec "keep-cafs"                        Opt_KeepCAFs
   ]
   ++ fHoleFlags
 
diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs
index bbcb1b6a7a..774884a0d7 100644
--- a/compiler/main/SysTools/ExtraObj.hs
+++ b/compiler/main/SysTools/ExtraObj.hs
@@ -104,6 +104,10 @@ mkExtraObjToLinkIntoBinary dflags = do
             <> text (if rtsOptsSuggestions dflags
                         then "true"
                         else "false") <> semi,
+        text "__conf.keep_cafs = "
+            <> text (if gopt Opt_KeepCAFs dflags
+                       then "true"
+                       else "false") <> semi,
         case rtsOpts dflags of
             Nothing   -> Outputable.empty
             Just opts -> text "    __conf.rts_opts= " <>
diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst
index 531f8c0bf6..788b9befcd 100644
--- a/docs/users_guide/phases.rst
+++ b/docs/users_guide/phases.rst
@@ -1169,3 +1169,17 @@ for example).
 
     Also, you may need to use the :ghc-flag:`-rdynamic` flag to ensure that
     that symbols are not dropped from your PIE objects.
+
+.. ghc-flag:: -keep-cafs
+    :shortdesc: Do not garbage-collect CAFs (top-level expressions) at runtime
+    :type: dynamic
+    :category: linking
+
+    :since: 8.8.1
+
+    Disables the RTS's normal behaviour of garbage-collecting CAFs
+    (Constant Applicative Forms, in other words top-level
+    expressions). This option is useful for specialised applications
+    that do runtime dynamic linking, where code dynamically linked in
+    the future might require the value of a CAF that would otherwise
+    be garbage-collected.
diff --git a/testsuite/tests/rts/KeepCafs1.hs b/testsuite/tests/rts/KeepCafs1.hs
new file mode 100644
index 0000000000..f654bfbf3b
--- /dev/null
+++ b/testsuite/tests/rts/KeepCafs1.hs
@@ -0,0 +1,9 @@
+module KeepCafs1 where
+
+import KeepCafsBase
+
+foreign export ccall "getX"
+  getX :: IO Int
+
+getX :: IO Int
+getX = return x
diff --git a/testsuite/tests/rts/KeepCafs2.hs b/testsuite/tests/rts/KeepCafs2.hs
new file mode 100644
index 0000000000..ac57430c18
--- /dev/null
+++ b/testsuite/tests/rts/KeepCafs2.hs
@@ -0,0 +1,9 @@
+module KeepCafs2 where
+
+import KeepCafsBase
+
+foreign export ccall "getX"
+  getX :: IO Int
+
+getX :: IO Int
+getX = return (x + 1)
diff --git a/testsuite/tests/rts/KeepCafsBase.hs b/testsuite/tests/rts/KeepCafsBase.hs
new file mode 100644
index 0000000000..184db3dcf0
--- /dev/null
+++ b/testsuite/tests/rts/KeepCafsBase.hs
@@ -0,0 +1,4 @@
+module KeepCafsBase (x) where
+
+x :: Int
+x = last [1..1000]
diff --git a/testsuite/tests/rts/KeepCafsMain.hs b/testsuite/tests/rts/KeepCafsMain.hs
new file mode 100644
index 0000000000..2f6ad5a4f9
--- /dev/null
+++ b/testsuite/tests/rts/KeepCafsMain.hs
@@ -0,0 +1,25 @@
+module Main (main) where
+
+import Foreign
+import GHCi.ObjLink
+import System.Mem
+import System.Exit
+
+foreign import ccall "dynamic"
+  callGetX :: FunPtr (IO Int) -> IO Int
+
+main :: IO ()
+main = do
+  initObjLinker DontRetainCAFs
+  let
+    loadAndCall obj = do
+      loadObj obj
+      resolveObjs
+      r <- lookupSymbol "getX"
+      case r of
+        Nothing -> die "cannot find getX"
+        Just ptr -> callGetX (castPtrToFunPtr ptr) >>= print
+      unloadObj obj
+      performGC
+  loadAndCall "KeepCafs1.o"
+  loadAndCall "KeepCafs2.o"
diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile
index bf7e163cf3..496e04e825 100644
--- a/testsuite/tests/rts/Makefile
+++ b/testsuite/tests/rts/Makefile
@@ -190,3 +190,13 @@ T14695:
 InternalCounters:
 	"$(TEST_HC)" +RTS -s --internal-counters -RTS 2>&1 | grep "Internal Counters"
 	-"$(TEST_HC)" +RTS -s -RTS 2>&1 | grep "Internal Counters"
+
+.PHONY: KeepCafsFail
+KeepCafsFail:
+	"$(TEST_HC)" -c -g -v0 KeepCafsBase.hs KeepCafs1.hs KeepCafs2.hs
+	"$(TEST_HC)" -g -v0 KeepCafsMain.hs KeepCafsBase.o -debug -rdynamic -fwhole-archive-hs-libs $(KEEPCAFS)
+	./KeepCafsMain 2>&1 || echo "exit($$?)"
+
+.PHONY: KeepCafs
+KeepCafs:
+	"${MAKE}" KeepCafsFail KEEPCAFS=-fkeep-cafs
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index eb06dcc0c0..a537ee449b 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -431,3 +431,25 @@ test('nursery-chunks1',
   ],
   compile_and_run,
   [''])
+
+# Test for the "Evaluated a CAF that was GC'd" assertion in the debug
+# runtime, by dynamically loading code that re-evaluates the CAF.
+# Also tests the -rdynamic and -fwhole-archive-hs-libs flags for constructing
+# binaries that support runtime dynamic loading.
+test('keep-cafs-fail',
+  [ extra_files(['KeepCafsBase.hs', 'KeepCafs1.hs',
+                 'KeepCafs2.hs', 'KeepCafsMain.hs']),
+    filter_stdout_lines('Evaluated a CAF|exit.*'),
+    ignore_stderr, # on OS X the shell emits an "Abort trap" message to stderr
+  ],
+  run_command,
+  ['$MAKE -s --no-print-directory KeepCafsFail'])
+
+# Test the -fkeep-cafs flag
+test('keep-cafs',
+  [ extra_files(['KeepCafsBase.hs', 'KeepCafs1.hs',
+                 'KeepCafs2.hs', 'KeepCafsMain.hs'])
+  ],
+  run_command,
+  ['$MAKE -s --no-print-directory KeepCafs'])
+
diff --git a/testsuite/tests/rts/keep-cafs-fail.stdout b/testsuite/tests/rts/keep-cafs-fail.stdout
new file mode 100644
index 0000000000..6eaf652de0
--- /dev/null
+++ b/testsuite/tests/rts/keep-cafs-fail.stdout
@@ -0,0 +1,5 @@
+KeepCafsMain: internal error: Evaluated a CAF (0xaac9d8) that was GC'd!
+    (GHC version 8.7.20180910 for x86_64_unknown_linux)
+    Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug
+Aborted (core dumped)
+exit(134)
diff --git a/testsuite/tests/rts/keep-cafs.stdout b/testsuite/tests/rts/keep-cafs.stdout
new file mode 100644
index 0000000000..b5b9afd887
--- /dev/null
+++ b/testsuite/tests/rts/keep-cafs.stdout
@@ -0,0 +1,2 @@
+1000
+1001