From: Simon Marlow Date: Fri, 8 Apr 2011 14:54:50 +0000 (+0100) Subject: Force re-linking if the options have changed (#4451) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=814edf44433801e37318ce79082ac6991dbc87dd 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. --- diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 10c9f18..ca6fa74 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -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 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 8d31fd9..bc16ede 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 7c0fd46..c7a7b02 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 3eb5744..a4ea987 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -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} %************************************************************************ diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 6b17a28..0e46889 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -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}