Add -fwhole-archive-hs-libs

We're building a demo to show how to hot-swap Haskell code in a
running process, and unfortunately it wasn't possible to convince GHC
to generate the correct linker command line without this extra knob.

Test Plan:
Tested it on a hot-swapping demo (which is not released yet, but will
be shortly)

Reviewers: niteria, austin, erikd, JonCoens, bgamari

Reviewed By: bgamari

Subscribers: Phyx, rwbarton, thomie

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

10 files changed, 146 insertions, 6 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index ca82e73f87..57a50827b6 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1815,15 +1815,28 @@ linkBinary' staticLink dflags o_files dep_packages = do
               in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
          | otherwise = ["-L" ++ l]
 
-    let dead_strip = if osSubsectionsViaSymbols (platformOS platform)
-                      then ["-Wl,-dead_strip"]
-                      else []
+    let
+      dead_strip
+        | gopt Opt_WholeArchiveHsLibs dflags = []
+        | otherwise = if osSubsectionsViaSymbols (platformOS platform)
+                        then ["-Wl,-dead_strip"]
+                        else []
     let lib_paths = libraryPaths dflags
     let lib_path_opts = map ("-L"++) lib_paths
 
     extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
     noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
 
+    let
+      (pre_hs_libs, post_hs_libs)
+        | gopt Opt_WholeArchiveHsLibs dflags
+        = if platformOS platform == OSDarwin
+            then (["-Wl,-all_load"], [])
+              -- OS X does not have a flag to turn off -all_load
+            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
+        | otherwise
+        = ([],[])
+
     pkg_link_opts <- do
         (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
         return $ if staticLink
@@ -1832,7 +1845,9 @@ linkBinary' staticLink dflags o_files dep_packages = do
                                  -- HS packages, because libtool doesn't accept other options.
                                  -- In the case of iOS these need to be added by hand to the
                                  -- final link in Xcode.
-            else other_flags ++ dead_strip ++ package_hs_libs ++ extra_libs
+            else other_flags ++ dead_strip
+                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
+                  ++ extra_libs
                  -- -Wl,-u,<sym> contained in other_flags
                  -- needs to be put before -l<package>,
                  -- otherwise Solaris linker fails linking
@@ -1934,7 +1949,8 @@ linkBinary' staticLink dflags o_files dep_packages = do
                           then ["-Wl,-read_only_relocs,suppress"]
                           else [])
 
-                      ++ (if sLdIsGnuLd mySettings
+                      ++ (if sLdIsGnuLd mySettings &&
+                             not (gopt Opt_WholeArchiveHsLibs dflags)
                           then ["-Wl,--gc-sections"]
                           else [])
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 442bbb984c..e96bf69d31 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -515,6 +515,7 @@ data GeneralFlag
    | Opt_ExternalInterpreter
    | Opt_OptimalApplicativeDo
    | Opt_VersionMacros
+   | Opt_WholeArchiveHsLibs
 
    -- PreInlining is on by default. The option is there just to see how
    -- bad things get if you turn it off!
@@ -3705,7 +3706,8 @@ fFlagsDeps = [
   flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,
   flagSpec "show-warning-groups"              Opt_ShowWarnGroups,
   flagSpec "hide-source-paths"                Opt_HideSourcePaths,
-  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints
+  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,
+  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs
   ]
 
 -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst
index b1a6310e6d..6bc97675f5 100644
--- a/docs/users_guide/phases.rst
+++ b/docs/users_guide/phases.rst
@@ -853,3 +853,18 @@ for example).
     the dynamic symbol table. Currently Linux and Windows/MinGW32 only.
     This is equivalent to using ``-optl -rdynamic`` on Linux, and
     ``-optl -export-all-symbols`` on Windows.
+
+.. ghc-flag:: -fwhole-archive-hs-libs
+
+    When linking a binary executable, this inserts the flag
+    ``-Wl,--whole-archive`` before any ``-l`` flags for Haskell
+    libraries, and ``-Wl,--no-whole-archive`` afterwards (on OS X, the
+    flag is ``-Wl,-all_load``, there is no equivalent for
+    ``-Wl,--no-whole-archive``).  This flag also disables the use of
+    ``-Wl,--gc-sections`` (``-Wl,-dead_strip`` on OS X).
+
+    This is for specialist applications that may require symbols
+    defined in these Haskell libraries at runtime even though they
+    aren't referenced by any other code linked into the executable.
+    If you're using ``-fwhole-archive-hs-libs``, you probably also
+    want ``-rdynamic``.
diff --git a/testsuite/tests/driver/linkwhole/Handles.hs b/testsuite/tests/driver/linkwhole/Handles.hs
new file mode 100644
index 0000000000..6e8d22715d
--- /dev/null
+++ b/testsuite/tests/driver/linkwhole/Handles.hs
@@ -0,0 +1,18 @@
+module Handles
+  ( hsNewSOHandle
+  ) where
+
+import Foreign
+
+import Types
+
+import MyCode
+
+foreign export ccall "hs_soHandles"
+  hsNewSOHandle :: SOHandleExport
+
+hsNewSOHandle :: SOHandleExport
+hsNewSOHandle = newStablePtr SOHandles
+  { someData = "I'm a shared object"
+  , someFn = myFunction
+  }
diff --git a/testsuite/tests/driver/linkwhole/Main.hs b/testsuite/tests/driver/linkwhole/Main.hs
new file mode 100644
index 0000000000..46e287ba65
--- /dev/null
+++ b/testsuite/tests/driver/linkwhole/Main.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Main (main) where
+
+import Control.Exception
+import Control.Monad
+
+import Foreign
+
+import Types
+
+import System.Environment
+import System.Posix.DynamicLinker
+import GHCi.ObjLink
+
+rotateSO
+  :: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
+  -> String
+  -> (Maybe FilePath, FilePath)
+  -> IO a
+rotateSO dynamicCall symName (old, newDLL) = do
+  -- initObjLinker is idempotent
+  initObjLinker DontRetainCAFs
+
+  loadObj newDLL
+  resolved <- resolveObjs
+  unless resolved $
+    throwIO (ErrorCall $ "Unable to resolve objects for " ++ newDLL)
+  c_sym <- lookupSymbol symName
+  h <- case c_sym of
+    Nothing -> throwIO (ErrorCall "Could not find symbol")
+    Just p_sym ->
+      bracket (dynamicCall $ castPtrToFunPtr p_sym) freeStablePtr deRefStablePtr
+  purgeObj newDLL
+  forM_ old unloadObj
+  return h
+
+foreign import ccall "dynamic"
+  mkCallable :: FunPtr SOHandleExport -> SOHandleExport
+
+main :: IO ()
+main = do
+  [file] <- getArgs
+  SOHandles{..} <- rotateSO mkCallable "hs_soHandles" (Nothing, file)
+  someFn 7
+  putStrLn $ "someData = " ++ show someData
diff --git a/testsuite/tests/driver/linkwhole/Makefile b/testsuite/tests/driver/linkwhole/Makefile
new file mode 100644
index 0000000000..6f4086f50c
--- /dev/null
+++ b/testsuite/tests/driver/linkwhole/Makefile
@@ -0,0 +1,20 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# Test for -fwhole-archive-hs-libs
+
+ifeq "$(HostOS)" "darwin"
+NO_GC_SECTIONS=
+else
+NO_GC_SECTIONS=-optl-Wl,--no-gc-sections
+endif
+
+linkwhole:
+	"$(TEST_HC)" $(TEST_HC_OPTS) -c Types.hs
+	"$(TEST_HC)" $(TEST_HC_OPTS) -c Main.hs
+	"$(TEST_HC)" $(TEST_HC_OPTS) -o host Main.o Types.o -fwhole-archive-hs-libs -package ghci -rdynamic $(NO_GC_SECTIONS)
+	"$(TEST_HC)" $(TEST_HC_OPTS) -c MyCode.hs
+	"$(TEST_HC)" $(TEST_HC_OPTS) -c Handles.hs
+	ld -r -o lib.so MyCode.o Handles.o
+	./host lib.so
diff --git a/testsuite/tests/driver/linkwhole/MyCode.hs b/testsuite/tests/driver/linkwhole/MyCode.hs
new file mode 100644
index 0000000000..fbf6a63012
--- /dev/null
+++ b/testsuite/tests/driver/linkwhole/MyCode.hs
@@ -0,0 +1,6 @@
+module MyCode
+  ( myFunction
+  ) where
+
+myFunction :: Int -> IO ()
+myFunction i = putStrLn $ "Adding to 20: " ++ show (i + 20)
diff --git a/testsuite/tests/driver/linkwhole/Types.hs b/testsuite/tests/driver/linkwhole/Types.hs
new file mode 100644
index 0000000000..bccf25d957
--- /dev/null
+++ b/testsuite/tests/driver/linkwhole/Types.hs
@@ -0,0 +1,13 @@
+module Types
+  ( SOHandles(..)
+  , SOHandleExport
+  ) where
+
+import Foreign
+
+data SOHandles = SOHandles
+  { someData :: String
+  , someFn :: Int -> IO ()
+  }
+
+type SOHandleExport = IO (StablePtr SOHandles)
diff --git a/testsuite/tests/driver/linkwhole/all.T b/testsuite/tests/driver/linkwhole/all.T
new file mode 100644
index 0000000000..dcef32b9c1
--- /dev/null
+++ b/testsuite/tests/driver/linkwhole/all.T
@@ -0,0 +1,2 @@
+test('linkwhole', [extra_files(['Types.hs','Main.hs','MyCode.hs','Handles.hs'])],
+     run_command, ['$MAKE -s --no-print-directory linkwhole'])
diff --git a/testsuite/tests/driver/linkwhole/linkwhole.stdout b/testsuite/tests/driver/linkwhole/linkwhole.stdout
new file mode 100644
index 0000000000..906827f497
--- /dev/null
+++ b/testsuite/tests/driver/linkwhole/linkwhole.stdout
@@ -0,0 +1,2 @@
+Adding to 20: 27
+someData = "I'm a shared object"