Commit a6874e54 authored by Simon Marlow's avatar Simon Marlow Committed by Ben Gamari

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
parent 57d969ec
......@@ -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 [])
......
......@@ -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\>@
......
......@@ -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``.
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
}
{-# 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
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
module MyCode
( myFunction
) where
myFunction :: Int -> IO ()
myFunction i = putStrLn $ "Adding to 20: " ++ show (i + 20)
module Types
( SOHandles(..)
, SOHandleExport
) where
import Foreign
data SOHandles = SOHandles
{ someData :: String
, someFn :: Int -> IO ()
}
type SOHandleExport = IO (StablePtr SOHandles)
test('linkwhole', [extra_files(['Types.hs','Main.hs','MyCode.hs','Handles.hs'])],
run_command, ['$MAKE -s --no-print-directory linkwhole'])
Adding to 20: 27
someData = "I'm a shared object"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment