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