diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 26 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 4 | ||||
| -rw-r--r-- | docs/users_guide/phases.rst | 15 | ||||
| -rw-r--r-- | testsuite/tests/driver/linkwhole/Handles.hs | 18 | ||||
| -rw-r--r-- | testsuite/tests/driver/linkwhole/Main.hs | 46 | ||||
| -rw-r--r-- | testsuite/tests/driver/linkwhole/Makefile | 20 | ||||
| -rw-r--r-- | testsuite/tests/driver/linkwhole/MyCode.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/driver/linkwhole/Types.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/driver/linkwhole/all.T | 2 | ||||
| -rw-r--r-- | testsuite/tests/driver/linkwhole/linkwhole.stdout | 2 |
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" |