module GHC.Linker.ExtraObj
( mkExtraObj
, mkExtraObjToLinkIntoBinary
, mkNoteObjsToLinkIntoBinary
, checkLinkInfo
, getLinkInfo
, getCompilerInfo
, ghcLinkInfoSectionName
, ghcLinkInfoNoteName
, platformSupportsSavingLinkOpts
, haveRtsOptsFlags
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Unit
import GHC.Unit.Env
import GHC.Utils.Asm
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Driver.Session
import GHC.Driver.Ppr
import qualified GHC.Data.ShortText as ST
import GHC.SysTools.Elf
import GHC.SysTools.Tasks
import GHC.SysTools.Info
import GHC.Linker.Unit
import Control.Monad.IO.Class
import Control.Monad
import Data.Maybe
mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath
Logger
logger TmpFs
tmpfs DynFlags
dflags UnitState
unit_state String
extn String
xs
= do String
cFile <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule String
extn
String
oFile <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_GhcSession String
"o"
String -> String -> IO ()
writeFile String
cFile String
xs
CompilerInfo
ccInfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO CompilerInfo
getCompilerInfo Logger
logger DynFlags
dflags
Maybe ForeignSrcLang
-> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runCc forall a. Maybe a
Nothing Logger
logger TmpFs
tmpfs DynFlags
dflags
([String -> Option
Option String
"-c",
String -> String -> Option
FileOption String
"" String
cFile,
String -> Option
Option String
"-o",
String -> String -> Option
FileOption String
"" String
oFile]
forall a. [a] -> [a] -> [a]
++ if String
extn forall a. Eq a => a -> a -> Bool
/= String
"s"
then [Option]
cOpts
else CompilerInfo -> [Option]
asmOpts CompilerInfo
ccInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return String
oFile
where
cOpts :: [Option]
cOpts = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (DynFlags -> [String]
picCCOpts DynFlags
dflags)
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"-I" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> String
ST.unpack)
(forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludeDirs forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> Unit -> UnitInfo
unsafeLookupUnit UnitState
unit_state Unit
rtsUnit)
asmOpts :: CompilerInfo -> [Option]
asmOpts CompilerInfo
ccInfo =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CompilerInfo
ccInfo forall a. Eq a => a -> a -> Bool
==) [CompilerInfo
Clang, CompilerInfo
AppleClang, CompilerInfo
AppleClang51]
then [String -> Option
Option String
"-Qunused-arguments"]
else []
mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath)
Logger
logger TmpFs
tmpfs DynFlags
dflags UnitState
unit_state = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags Bool -> Bool -> Bool
&& DynFlags -> Bool
haveRtsOptsFlags DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
Logger -> SDoc -> IO ()
logInfo Logger
logger forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
(forall doc. IsLine doc => String -> doc
text String
"Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." forall doc. IsDoc doc => doc -> doc -> doc
$$
forall doc. IsLine doc => String -> doc
text String
" Call hs_init_ghc() from your main() function to set these options.")
case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
GhcLink
_ | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
GhcLink
LinkDynLib
| OS
OSMinGW32 <- Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
-> SDoc -> IO (Maybe String)
mk_extra_obj SDoc
dllMain
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
GhcLink
_ -> SDoc -> IO (Maybe String)
mk_extra_obj SDoc
exeMain
where
mk_extra_obj :: SDoc -> IO (Maybe String)
mk_extra_obj = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger
-> TmpFs -> DynFlags -> UnitState -> String -> String -> IO String
mkExtraObj Logger
logger TmpFs
tmpfs DynFlags
dflags UnitState
unit_state String
"c" forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
showSDoc DynFlags
dflags
exeMain :: SDoc
exeMain = forall doc. IsDoc doc => [doc] -> doc
vcat [
forall doc. IsLine doc => String -> doc
text String
"#include <Rts.h>",
forall doc. IsLine doc => String -> doc
text String
"extern StgClosure ZCMain_main_closure;",
forall doc. IsLine doc => String -> doc
text String
"int main(int argc, char *argv[])",
forall doc. IsLine doc => Char -> doc
char Char
'{',
forall doc. IsLine doc => String -> doc
text String
" RtsConfig __conf = defaultRtsConfig;",
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts_enabled = "
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text (forall a. Show a => a -> String
show (DynFlags -> RtsOptsEnabled
rtsOptsEnabled DynFlags
dflags)) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi,
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts_suggestions = "
forall doc. IsLine doc => doc -> doc -> doc
<> (if DynFlags -> Bool
rtsOptsSuggestions DynFlags
dflags
then forall doc. IsLine doc => String -> doc
text String
"true"
else forall doc. IsLine doc => String -> doc
text String
"false") forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi,
forall doc. IsLine doc => String -> doc
text String
"__conf.keep_cafs = "
forall doc. IsLine doc => doc -> doc -> doc
<> (if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepCAFs DynFlags
dflags
then forall doc. IsLine doc => String -> doc
text String
"true"
else forall doc. IsLine doc => String -> doc
text String
"false") forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi,
case DynFlags -> Maybe String
rtsOpts DynFlags
dflags of
Maybe String
Nothing -> forall doc. IsOutput doc => doc
Outputable.empty
Just String
opts -> forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts= " forall doc. IsLine doc => doc -> doc -> doc
<>
forall doc. IsLine doc => String -> doc
text (forall a. Show a => a -> String
show String
opts) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi,
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_hs_main = true;",
forall doc. IsLine doc => String -> doc
text String
" return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
forall doc. IsLine doc => Char -> doc
char Char
'}',
forall doc. IsLine doc => Char -> doc
char Char
'\n'
]
dllMain :: SDoc
dllMain = forall doc. IsDoc doc => [doc] -> doc
vcat [
forall doc. IsLine doc => String -> doc
text String
"#include <Rts.h>",
forall doc. IsLine doc => String -> doc
text String
"#include <windows.h>",
forall doc. IsLine doc => String -> doc
text String
"#include <stdbool.h>",
forall doc. IsLine doc => Char -> doc
char Char
'\n',
forall doc. IsLine doc => String -> doc
text String
"bool",
forall doc. IsLine doc => String -> doc
text String
"WINAPI",
forall doc. IsLine doc => String -> doc
text String
"DllMain ( HINSTANCE hInstance STG_UNUSED",
forall doc. IsLine doc => String -> doc
text String
" , DWORD reason STG_UNUSED",
forall doc. IsLine doc => String -> doc
text String
" , LPVOID reserved STG_UNUSED",
forall doc. IsLine doc => String -> doc
text String
" )",
forall doc. IsLine doc => String -> doc
text String
"{",
forall doc. IsLine doc => String -> doc
text String
" return true;",
forall doc. IsLine doc => String -> doc
text String
"}",
forall doc. IsLine doc => Char -> doc
char Char
'\n'
]
mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [String]
mkNoteObjsToLinkIntoBinary Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [UnitId]
dep_packages = do
String
link_info <- DynFlags -> UnitEnv -> [UnitId] -> IO String
getLinkInfo DynFlags
dflags UnitEnv
unit_env [UnitId]
dep_packages
if (OS -> Bool
platformSupportsSavingLinkOpts (Platform -> OS
platformOS Platform
platform ))
then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ Logger
-> TmpFs -> DynFlags -> UnitState -> String -> String -> IO String
mkExtraObj Logger
logger TmpFs
tmpfs DynFlags
dflags UnitState
unit_state String
"s" (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (String -> SDoc
link_opts String
link_info))
else forall (m :: * -> *) a. Monad m => a -> m a
return []
where
unit_state :: UnitState
unit_state = HasDebugCallStack => UnitEnv -> UnitState
ue_units UnitEnv
unit_env
platform :: Platform
platform = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
link_opts :: String -> SDoc
link_opts String
info = forall doc. IsLine doc => [doc] -> doc
hcat
[
Platform -> String -> String -> Word32 -> String -> SDoc
makeElfNote Platform
platform String
ghcLinkInfoSectionName String
ghcLinkInfoNoteName Word32
0 String
info
, if Platform -> Bool
platformHasGnuNonexecStack Platform
platform
then forall doc. IsLine doc => String -> doc
text String
".section .note.GNU-stack,\"\","
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Platform -> String -> doc
sectionType Platform
platform String
"progbits" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Char -> doc
char Char
'\n'
else forall doc. IsOutput doc => doc
Outputable.empty
]
getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
getLinkInfo DynFlags
dflags UnitEnv
unit_env [UnitId]
dep_packages = do
([String], [String], [String])
package_link_opts <- GhcNameVersion
-> Ways -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])
getUnitLinkOpts (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Ways
ways DynFlags
dflags) UnitEnv
unit_env [UnitId]
dep_packages
[String]
pkg_frameworks <- if Bool -> Bool
not (Platform -> Bool
platformUsesFrameworks (UnitEnv -> Platform
ue_platform UnitEnv
unit_env))
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[UnitInfo]
ps <- forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
dep_packages)
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnitInfo] -> [String]
collectFrameworks [UnitInfo]
ps)
let link_info :: (([String], [String], [String]), [String], Maybe String,
RtsOptsEnabled, Bool, [String], [String])
link_info =
( ([String], [String], [String])
package_link_opts
, [String]
pkg_frameworks
, DynFlags -> Maybe String
rtsOpts DynFlags
dflags
, DynFlags -> RtsOptsEnabled
rtsOptsEnabled DynFlags
dflags
, GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
, forall a b. (a -> b) -> [a] -> [b]
map Option -> String
showOpt (DynFlags -> [Option]
ldInputs DynFlags
dflags)
, forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_l
)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Show a => a -> String
show (([String], [String], [String]), [String], Maybe String,
RtsOptsEnabled, Bool, [String], [String])
link_info)
platformSupportsSavingLinkOpts :: OS -> Bool
platformSupportsSavingLinkOpts :: OS -> Bool
platformSupportsSavingLinkOpts OS
os
| OS
os forall a. Eq a => a -> a -> Bool
== OS
OSSolaris2 = Bool
False
| Bool
otherwise = OS -> Bool
osElfTarget OS
os
ghcLinkInfoSectionName :: String
ghcLinkInfoSectionName :: String
ghcLinkInfoSectionName = String
".debug-ghc-link-info"
ghcLinkInfoNoteName :: String
ghcLinkInfoNoteName :: String
ghcLinkInfoNoteName = String
"GHC link info"
checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> String -> IO Bool
checkLinkInfo Logger
logger DynFlags
dflags UnitEnv
unit_env [UnitId]
pkg_deps String
exe_file
| Bool -> Bool
not (OS -> Bool
platformSupportsSavingLinkOpts (Platform -> OS
platformOS (UnitEnv -> Platform
ue_platform UnitEnv
unit_env)))
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise
= do
String
link_info <- DynFlags -> UnitEnv -> [UnitId] -> IO String
getLinkInfo DynFlags
dflags UnitEnv
unit_env [UnitId]
pkg_deps
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => String -> doc
text (String
"Link info: " forall a. [a] -> [a] -> [a]
++ String
link_info)
Maybe String
m_exe_link_info <- Logger -> String -> String -> String -> IO (Maybe String)
readElfNoteAsString Logger
logger String
exe_file
String
ghcLinkInfoSectionName String
ghcLinkInfoNoteName
let sameLinkInfo :: Bool
sameLinkInfo = (forall a. a -> Maybe a
Just String
link_info forall a. Eq a => a -> a -> Bool
== Maybe String
m_exe_link_info)
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 forall a b. (a -> b) -> a -> b
$ case Maybe String
m_exe_link_info of
Maybe String
Nothing -> forall doc. IsLine doc => String -> doc
text String
"Exe link info: Not found"
Just String
s
| Bool
sameLinkInfo -> forall doc. IsLine doc => String -> doc
text (String
"Exe link info is the same")
| Bool
otherwise -> forall doc. IsLine doc => String -> doc
text (String
"Exe link info is different: " forall a. [a] -> [a] -> [a]
++ String
s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
sameLinkInfo)
haveRtsOptsFlags :: DynFlags -> Bool
haveRtsOptsFlags :: DynFlags -> Bool
haveRtsOptsFlags DynFlags
dflags =
forall a. Maybe a -> Bool
isJust (DynFlags -> Maybe String
rtsOpts DynFlags
dflags) Bool -> Bool -> Bool
|| case DynFlags -> RtsOptsEnabled
rtsOptsEnabled DynFlags
dflags of
RtsOptsEnabled
RtsOptsSafeOnly -> Bool
False
RtsOptsEnabled
_ -> Bool
True