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.
import Constants
import BasicTypes
import CLabel
import Constants
import BasicTypes
import CLabel
-- The rest
import Data.List
-- The rest
import Data.List
pprStringInCStyle :: [Word8] -> SDoc
pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
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
-- ---------------------------------------------------------------------------
-- Initialising static objects with floating-point numbers. We can't
-- just emit the floating point number, because C will cast it to an int
import Data.List ( isSuffixOf )
import Data.Maybe
import System.Environment
import Data.List ( isSuffixOf )
import Data.Maybe
import System.Environment
-- ---------------------------------------------------------------------------
-- Pre-process
-- ---------------------------------------------------------------------------
-- Pre-process
let (lib_errs,lib_times) = splitEithers e_lib_times
if not (null lib_errs) || any (t <) lib_times
then return True
let (lib_errs,lib_times) = splitEithers e_lib_times
if not (null lib_errs) || any (t <) lib_times
then return True
+ 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
findHSLib :: [String] -> String -> IO (Maybe FilePath)
findHSLib dirs lib = do
return True
| otherwise = return True
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"
mkExtraCObj dflags xs
= do cFile <- newTempName dflags "c"
oFile <- newTempName dflags "o"
- writeFile cFile $ unlines xs
let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
md_c_flags = machdepCCOpts dflags
SysTools.runCc dflags
let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
md_c_flags = machdepCCOpts dflags
SysTools.runCc dflags
map Option md_c_flags)
return oFile
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
-- generates a Perl skript starting a parallel prg under PVM
mk_pvm_wrapper_script :: String -> String -> String -> String
let no_hs_main = dopt Opt_NoHsMain dflags
let main_lib | no_hs_main = []
| otherwise = [ "-lHSrtsmain" ]
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
pkg_link_opts <- getPackageLinkOpts dflags dep_packages
#endif
++ pkg_lib_path_opts
++ main_lib
#endif
++ pkg_lib_path_opts
++ main_lib
- ++ rtsEnabledObj
- ++ rtsOptsObj
++ pkg_link_opts
#ifdef darwin_TARGET_OS
++ pkg_framework_path_opts
++ pkg_link_opts
#ifdef darwin_TARGET_OS
++ pkg_framework_path_opts
let md_c_flags = machdepCCOpts dflags
let extra_ld_opts = getOpts dflags opt_l
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)
-----------------------------------------------------------------------------
#if defined(mingw32_HOST_OS)
-----------------------------------------------------------------------------
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
#elif defined(darwin_TARGET_OS)
++ pkg_link_opts
))
#elif defined(darwin_TARGET_OS)
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
#else
++ pkg_link_opts
))
#else
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
#endif
++ pkg_link_opts
))
#endif
deriving Eq
data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
deriving Eq
data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
-- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
initDynFlags :: DynFlags -> IO DynFlags
-- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
initDynFlags :: DynFlags -> IO DynFlags
-----------------------------------------------------------------------------
\begin{code}
-----------------------------------------------------------------------------
\begin{code}
+{-# OPTIONS -fno-warn-unused-do-bind #-}
module SysTools (
-- Initialisation
initSysTools,
module SysTools (
-- Initialisation
initSysTools,
runWindres,
runLlvmOpt,
runLlvmLlc,
runWindres,
runLlvmOpt,
runLlvmLlc,
touch, -- String -> String -> IO ()
copy,
touch, -- String -> String -> IO ()
copy,
import Data.Char
import Data.List
import qualified Data.Map as Map
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
#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
getExtraViaCOpts dflags = do
f <- readFile (topDir dflags </> "extra-gcc-opts")
return (words f)
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}
%************************************************************************
\end{code}
%************************************************************************
Direction(..), reslash,
-- * Utils for defining Data instances
Direction(..), reslash,
-- * Utils for defining Data instances
- abstractConstr, abstractDataType, mkNoRepType
+ abstractConstr, abstractDataType, mkNoRepType,
+
+ -- * Utils for printing C code
+ charToC
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
import System.FilePath
import System.Time ( ClockTime )
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
import Data.Ratio ( (%) )
import Data.Ord ( comparing )
import Data.Bits
abstractDataType n = mkDataType n [abstractConstr n]
\end{code}
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}