From a6874e546294173c166859769dd8054887a6ded7 Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Thu, 2 Mar 2017 16:17:12 -0500
Subject: 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
---
testsuite/tests/driver/linkwhole/Handles.hs | 18 +++++++++
testsuite/tests/driver/linkwhole/Main.hs | 46 +++++++++++++++++++++++
testsuite/tests/driver/linkwhole/Makefile | 20 ++++++++++
testsuite/tests/driver/linkwhole/MyCode.hs | 6 +++
testsuite/tests/driver/linkwhole/Types.hs | 13 +++++++
testsuite/tests/driver/linkwhole/all.T | 2 +
testsuite/tests/driver/linkwhole/linkwhole.stdout | 2 +
7 files changed, 107 insertions(+)
create mode 100644 testsuite/tests/driver/linkwhole/Handles.hs
create mode 100644 testsuite/tests/driver/linkwhole/Main.hs
create mode 100644 testsuite/tests/driver/linkwhole/Makefile
create mode 100644 testsuite/tests/driver/linkwhole/MyCode.hs
create mode 100644 testsuite/tests/driver/linkwhole/Types.hs
create mode 100644 testsuite/tests/driver/linkwhole/all.T
create mode 100644 testsuite/tests/driver/linkwhole/linkwhole.stdout
(limited to 'testsuite/tests/driver')
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"
--
cgit v1.2.1