Commit 814edf44 authored by Simon Marlow's avatar Simon Marlow

Force re-linking if the options have changed (#4451)

A common sequence of commands (at least for me) is this:

$ ghc hello
1 of 1] Compiling Main             ( hello.hs, hello.o )
Linking hello ...
$ ./hello +RTS -s
hello: Most RTS options are disabled. Link with -rtsopts to enable them.
$ ghc hello -rtsopts
$

grr, nothing happened.  I could use -fforce-recomp, but if this was a
large program I probably don't want to recompile it all again, so:

$ rm hello
removed `hello'
$ ghc hello -rtsopts
Linking hello ...
$ ./hello +RTS -s
./hello +RTS -s
Hello World!
          51,264 bytes allocated in the heap
           2,904 bytes copied during GC
          43,808 bytes maximum residency (1 sample(s))
          17,632 bytes maximum slop
etc.

With this patch, GHC notices when the options have changed and forces
a relink, so you don't need to rm the binary or use -fforce-recomp.
This is done by adding the pertinent stuff to the binary in a special
section called ".debug-ghc-link-info":

$ readelf -p .debug-ghc-link-info ./hello
String dump of section 'ghc-linker-opts':
  [     0]  (["-lHSbase-4.3.1.0","-lHSinteger-gmp-0.2.0.2","-lgmp","-lHSghc-prim-0.2.0.0","-lHSrts","-lm","-lrt","-ldl","-u","ghczmprim_GHCziTypes_Izh_static_info","-u","ghczmprim_GHCziTypes_Czh_static_info","-u","ghczmprim_GHCziTypes_Fzh_static_info","-u","ghczmprim_GHCziTypes_Dzh_static_info","-u","base_GHCziPtr_Ptr_static_info","-u","base_GHCziWord_Wzh_static_info","-u","base_GHCziInt_I8zh_static_info","-u","base_GHCziInt_I16zh_static_info","-u","base_GHCziInt_I32zh_static_info","-u","base_GHCziInt_I64zh_static_info","-u","base_GHCziWord_W8zh_static_info","-u","base_GHCziWord_W16zh_static_info","-u","base_GHCziWord_W32zh_static_info","-u","base_GHCziWord_W64zh_static_info","-u","base_GHCziStable_StablePtr_static_info","-u","ghczmprim_GHCziTypes_Izh_con_info","-u","ghczmprim_GHCziTypes_Czh_con_info","-u","ghczmprim_GHCziTypes_Fzh_con_info","-u","ghczmprim_GHCziTypes_Dzh_con_info","-u","base_GHCziPtr_Ptr_con_info","-u","base_GHCziPtr_FunPtr_con_info","-u","base_GHCziStable_StablePtr_con_info","-u","ghczmprim_GHCziTypes_False_closure","-u","ghczmprim_GHCziTypes_True_closure","-u","base_GHCziPack_unpackCString_closure","-u","base_GHCziIOziException_stackOverflow_closure","-u","base_GHCziIOziException_heapOverflow_closure","-u","base_ControlziExceptionziBase_nonTermination_closure","-u","base_GHCziIOziException_blockedIndefinitelyOnMVar_closure","-u","base_GHCziIOziException_blockedIndefinitelyOnSTM_closure","-u","base_ControlziExceptionziBase_nestedAtomically_closure","-u","base_GHCziWeak_runFinalizzerBatch_closure","-u","base_GHCziTopHandler_runIO_closure","-u","base_GHCziTopHandler_runNonIO_closure","-u","base_GHCziConcziIO_ensureIOManagerIsRunning_closure","-u","base_GHCziConcziSync_runSparks_closure","-u","base_GHCziConcziSignal_runHandlers_closure","-lHSffi"],Nothing,RtsOptsAll,False,[],[])

And GHC itself uses the readelf command to extract it when deciding
whether to relink.  The reason for the name ".debug-ghc-link-info" is
that sections beginning with ".debug" are removed automatically by
strip.

This currently only works on Linux; Windows and OS X still have the
old behaviour.
parent e0d60d50
......@@ -50,6 +50,7 @@ import Outputable
import Constants
import BasicTypes
import CLabel
import Util
-- The rest
import Data.List
......@@ -1022,18 +1023,6 @@ machRep_S_CType _ = panic "machRep_S_CType"
pprStringInCStyle :: [Word8] -> SDoc
pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
charToC :: Word8 -> String
charToC w =
case chr (fromIntegral w) of
'\"' -> "\\\""
'\'' -> "\\\'"
'\\' -> "\\\\"
c | c >= ' ' && c <= '~' -> [c]
| otherwise -> ['\\',
chr (ord '0' + ord c `div` 64),
chr (ord '0' + ord c `div` 8 `mod` 8),
chr (ord '0' + ord c `mod` 8)]
-- ---------------------------------------------------------------------------
-- Initialising static objects with floating-point numbers. We can't
-- just emit the floating point number, because C will cast it to an int
......
......@@ -63,6 +63,7 @@ import Control.Monad
import Data.List ( isSuffixOf )
import Data.Maybe
import System.Environment
import Data.Char
-- ---------------------------------------------------------------------------
-- Pre-process
......@@ -383,7 +384,30 @@ linkingNeeded dflags linkables pkg_deps = do
let (lib_errs,lib_times) = splitEithers e_lib_times
if not (null lib_errs) || any (t <) lib_times
then return True
else return False
else checkLinkInfo dflags pkg_deps exe_file
-- Returns 'False' if it was, and we can avoid linking, because the
-- previous binary was linked with "the same options".
checkLinkInfo :: DynFlags -> [PackageId] -> FilePath -> IO Bool
checkLinkInfo dflags pkg_deps exe_file
| isWindowsTarget || isDarwinTarget
-- ToDo: Windows and OS X do not use the ELF binary format, so
-- readelf does not work there. We need to find another way to do
-- this.
= return False -- conservatively we should return True, but not
-- linking in this case was the behaviour for a long
-- time so we leave it as-is.
| otherwise
= do
link_info <- getLinkInfo dflags pkg_deps
debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
m_exe_link_info <- readElfSection dflags ghcLinkInfoSectionName exe_file
debugTraceMsg dflags 3 $ text ("Exe link info: " ++ show m_exe_link_info)
return (Just link_info /= m_exe_link_info)
ghcLinkInfoSectionName :: String
ghcLinkInfoSectionName = ".debug-ghc-link-info"
-- if we use the ".debug" prefix, then strip will strip it by default
findHSLib :: [String] -> String -> IO (Maybe FilePath)
findHSLib dirs lib = do
......@@ -1370,11 +1394,11 @@ runPhase_MoveBinary dflags input_fn
return True
| otherwise = return True
mkExtraCObj :: DynFlags -> [String] -> IO FilePath
mkExtraCObj :: DynFlags -> String -> IO FilePath
mkExtraCObj dflags xs
= do cFile <- newTempName dflags "c"
oFile <- newTempName dflags "o"
writeFile cFile $ unlines xs
writeFile cFile xs
let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
md_c_flags = machdepCCOpts dflags
SysTools.runCc dflags
......@@ -1386,19 +1410,66 @@ mkExtraCObj dflags xs
map Option md_c_flags)
return oFile
mkRtsOptionsLevelObj :: DynFlags -> IO [FilePath]
mkRtsOptionsLevelObj dflags
= do let mkRtsEnabledObj val
= do fn <- mkExtraCObj dflags
["#include \"Rts.h\"",
"#include \"RtsOpts.h\"",
"const rtsOptsEnabledEnum rtsOptsEnabled = "
++ val ++ ";"]
return [fn]
case rtsOptsEnabled dflags of
RtsOptsNone -> mkRtsEnabledObj "rtsOptsNone"
RtsOptsSafeOnly -> return [] -- The default
RtsOptsAll -> mkRtsEnabledObj "rtsOptsAll"
mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath
mkExtraObjToLinkIntoBinary dflags dep_packages = do
link_info <- getLinkInfo dflags dep_packages
mkExtraCObj dflags (showSDoc (vcat [rts_opts_enabled,
extra_rts_opts,
link_opts link_info]))
where
mk_rts_opts_enabled val
= vcat [text "#include \"Rts.h\"",
text "#include \"RtsOpts.h\"",
text "const rtsOptsEnabledEnum rtsOptsEnabled = " <>
text val <> semi ]
rts_opts_enabled = case rtsOptsEnabled dflags of
RtsOptsNone -> mk_rts_opts_enabled "rtsOptsNone"
RtsOptsSafeOnly -> empty -- The default
RtsOptsAll -> mk_rts_opts_enabled "rtsOptsAll"
extra_rts_opts = case rtsOpts dflags of
Nothing -> empty
Just opts -> text "char *ghc_rts_opts = " <> text (show opts) <> semi
link_opts info
| isDarwinTarget = empty
| isWindowsTarget = empty
| otherwise = hcat [
text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName,
text ",\\\"\\\",@note\\n",
text "\\t.ascii \\\"", info', text "\\\"\\n\");" ]
where
-- we need to escape twice: once because we're inside a C string,
-- and again because we're inside an asm string.
info' = text $ (escape.escape) info
escape :: String -> String
escape = concatMap (charToC.fromIntegral.ord)
-- The "link info" is a string representing the parameters of the
-- link. We save this information in the binary, and the next time we
-- link, if nothing else has changed, we use the link info stored in
-- the existing binary to decide whether to re-link or not.
getLinkInfo :: DynFlags -> [PackageId] -> IO String
getLinkInfo dflags dep_packages = do
package_link_opts <- getPackageLinkOpts dflags dep_packages
#ifdef darwin_TARGET_OS
pkg_frameworks <- getPackageFrameworks dflags dep_packages
#endif
extra_ld_inputs <- readIORef v_Ld_inputs
let
link_info = (package_link_opts,
#ifdef darwin_TARGET_OS
pkg_frameworks,
#endif
rtsOpts dflags,
rtsOptsEnabled dflags,
dopt Opt_NoHsMain dflags,
extra_ld_inputs,
getOpts dflags opt_l)
--
return (show link_info)
-- generates a Perl skript starting a parallel prg under PVM
mk_pvm_wrapper_script :: String -> String -> String -> String
......@@ -1510,15 +1581,8 @@ linkBinary dflags o_files dep_packages = do
let no_hs_main = dopt Opt_NoHsMain dflags
let main_lib | no_hs_main = []
| otherwise = [ "-lHSrtsmain" ]
rtsEnabledObj <- mkRtsOptionsLevelObj dflags
rtsOptsObj <- case rtsOpts dflags of
Just opts ->
do fn <- mkExtraCObj dflags
-- We assume that the Haskell "show" does
-- the right thing here
["char *ghc_rts_opts = " ++ show opts ++ ";"]
return [fn]
Nothing -> return []
extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
pkg_link_opts <- getPackageLinkOpts dflags dep_packages
......@@ -1593,8 +1657,7 @@ linkBinary dflags o_files dep_packages = do
#endif
++ pkg_lib_path_opts
++ main_lib
++ rtsEnabledObj
++ rtsOptsObj
++ [extraLinkObj]
++ pkg_link_opts
#ifdef darwin_TARGET_OS
++ pkg_framework_path_opts
......@@ -1724,7 +1787,7 @@ linkDynLib dflags o_files dep_packages = do
let md_c_flags = machdepCCOpts dflags
let extra_ld_opts = getOpts dflags opt_l
rtsEnabledObj <- mkRtsOptionsLevelObj dflags
extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
#if defined(mingw32_HOST_OS)
-----------------------------------------------------------------------------
......@@ -1753,7 +1816,7 @@ linkDynLib dflags o_files dep_packages = do
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ rtsEnabledObj
++ [extraLinkObj]
++ pkg_link_opts
))
#elif defined(darwin_TARGET_OS)
......@@ -1810,7 +1873,7 @@ linkDynLib dflags o_files dep_packages = do
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ rtsEnabledObj
++ [extraLinkObj]
++ pkg_link_opts
))
#else
......@@ -1845,7 +1908,7 @@ linkDynLib dflags o_files dep_packages = do
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ rtsEnabledObj
++ [extraLinkObj]
++ pkg_link_opts
))
#endif
......
......@@ -623,6 +623,7 @@ data DynLibLoader
deriving Eq
data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
deriving (Show)
-- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
initDynFlags :: DynFlags -> IO DynFlags
......
......@@ -7,6 +7,7 @@
-----------------------------------------------------------------------------
\begin{code}
{-# OPTIONS -fno-warn-unused-do-bind #-}
module SysTools (
-- Initialisation
initSysTools,
......@@ -20,6 +21,7 @@ module SysTools (
runWindres,
runLlvmOpt,
runLlvmLlc,
readElfSection,
touch, -- String -> String -> IO ()
copy,
......@@ -58,6 +60,8 @@ import System.Directory
import Data.Char
import Data.List
import qualified Data.Map as Map
import Text.ParserCombinators.ReadP hiding (char)
import qualified Text.ParserCombinators.ReadP as R
#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
......@@ -448,6 +452,27 @@ getExtraViaCOpts :: DynFlags -> IO [String]
getExtraViaCOpts dflags = do
f <- readFile (topDir dflags </> "extra-gcc-opts")
return (words f)
-- | read the contents of the named section in an ELF object as a
-- String.
readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
readElfSection _dflags section exe = do
let
prog = "readelf"
args = [Option "-p", Option section, FileOption "" exe]
--
r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) ""
case r of
(ExitSuccess, out, _err) -> return (doFilter (lines out))
_ -> return Nothing
where
doFilter [] = Nothing
doFilter (s:r) = case readP_to_S parse s of
[(p,"")] -> Just p
_r -> doFilter r
where parse = do
skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces;
munch (const True)
\end{code}
%************************************************************************
......
......@@ -81,7 +81,10 @@ module Util (
Direction(..), reslash,
-- * Utils for defining Data instances
abstractConstr, abstractDataType, mkNoRepType
abstractConstr, abstractDataType, mkNoRepType,
-- * Utils for printing C code
charToC
) where
#include "HsVersions.h"
......@@ -106,7 +109,7 @@ import System.Directory ( doesDirectoryExist, createDirectory,
import System.FilePath
import System.Time ( ClockTime )
import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit )
import Data.Ratio ( (%) )
import Data.Ord ( comparing )
import Data.Bits
......@@ -1066,3 +1069,22 @@ abstractDataType :: String -> DataType
abstractDataType n = mkDataType n [abstractConstr n]
\end{code}
%************************************************************************
%* *
\subsection[Utils-C]{Utils for printing C code}
%* *
%************************************************************************
\begin{code}
charToC :: Word8 -> String
charToC w =
case chr (fromIntegral w) of
'\"' -> "\\\""
'\'' -> "\\\'"
'\\' -> "\\\\"
c | c >= ' ' && c <= '~' -> [c]
| otherwise -> ['\\',
chr (ord '0' + ord c `div` 64),
chr (ord '0' + ord c `div` 8 `mod` 8),
chr (ord '0' + ord c `mod` 8)]
\end{code}
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