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

8 files changed, 86 insertions, 0 deletions

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