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

7 files changed, 107 insertions, 0 deletions

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"