[commit: ghc] master: Add -fkeep-cafs (df67f95)
git at git.haskell.org
git at git.haskell.org
Fri Sep 28 15:19:10 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/df67f95b2fc1c8b7200d98643e76c5feab4ed876/ghc
>---------------------------------------------------------------
commit df67f95b2fc1c8b7200d98643e76c5feab4ed876
Author: Simon Marlow <marlowsd at gmail.com>
Date: Fri Sep 28 14:27:22 2018 +0200
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
>---------------------------------------------------------------
df67f95b2fc1c8b7200d98643e76c5feab4ed876
compiler/main/DynFlags.hs | 4 +++-
compiler/main/SysTools/ExtraObj.hs | 4 ++++
docs/users_guide/phases.rst | 14 ++++++++++++
testsuite/tests/rts/KeepCafs1.hs | 9 ++++++++
testsuite/tests/rts/KeepCafs2.hs | 9 ++++++++
testsuite/tests/rts/KeepCafsBase.hs | 4 ++++
testsuite/tests/rts/KeepCafsMain.hs | 25 ++++++++++++++++++++++
testsuite/tests/rts/Makefile | 10 +++++++++
testsuite/tests/rts/all.T | 22 +++++++++++++++++++
testsuite/tests/rts/keep-cafs-fail.stdout | 5 +++++
.../tests/rts/keep-cafs.stdout | 1 +
11 files changed, 106 insertions(+), 1 deletion(-)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e7e541b..7726001 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 bbcb1b6..774884a 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 531f8c0..788b9be 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 0000000..f654bfb
--- /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 0000000..ac57430
--- /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 0000000..184db3d
--- /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 0000000..2f6ad5a
--- /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 bf7e163..496e04e 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 eb06dcc..a537ee4 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 0000000..6eaf652
--- /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/libraries/base/tests/dynamic004.stdout b/testsuite/tests/rts/keep-cafs.stdout
similarity index 50%
copy from libraries/base/tests/dynamic004.stdout
copy to testsuite/tests/rts/keep-cafs.stdout
index 83b33d2..b5b9afd 100644
--- a/libraries/base/tests/dynamic004.stdout
+++ b/testsuite/tests/rts/keep-cafs.stdout
@@ -1 +1,2 @@
1000
+1001
More information about the ghc-commits
mailing list