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 <- IO CompilerInfo -> IO CompilerInfo
forall a. IO a -> IO a
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
([String -> Option
Option String
"-c",
String -> String -> Option
FileOption String
"" String
cFile,
String -> Option
Option String
"-o",
String -> String -> Option
FileOption String
"" String
oFile]
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ if String
extn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"s"
then [Option]
cOpts
else CompilerInfo -> [Option]
asmOpts CompilerInfo
ccInfo)
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
oFile
where
cOpts :: [Option]
cOpts = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (DynFlags -> [String]
picCCOpts DynFlags
dflags)
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (ShortText -> Option) -> [ShortText] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"-I" (String -> Option) -> (ShortText -> String) -> ShortText -> Option
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> String
ST.unpack)
(GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
-> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludeDirs (GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
-> [ShortText])
-> GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
-> [ShortText]
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) =>
UnitState
-> GenUnit UnitId
-> GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))
UnitState
-> GenUnit UnitId
-> GenericUnitInfo
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 [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
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 -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
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
-> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
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
-> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
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 = (String -> Maybe String) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> IO (Maybe String))
-> (SDoc -> IO String) -> SDoc -> IO (Maybe String)
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" (String -> IO String) -> (SDoc -> String) -> SDoc -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
showSDoc DynFlags
dflags
exeMain :: SDoc
exeMain = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#include <Rts.h>",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"extern StgClosure ZCMain_main_closure;",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"int main(int argc, char *argv[])",
Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'{',
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" RtsConfig __conf = defaultRtsConfig;",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts_enabled = "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (RtsOptsEnabled -> String
forall a. Show a => a -> String
show (DynFlags -> RtsOptsEnabled
rtsOptsEnabled DynFlags
dflags)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts_suggestions = "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (if DynFlags -> Bool
rtsOptsSuggestions DynFlags
dflags
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"true"
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"false") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__conf.keep_cafs = "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepCAFs DynFlags
dflags
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"true"
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"false") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
case DynFlags -> Maybe String
rtsOpts DynFlags
dflags of
Maybe String
Nothing -> SDoc
forall doc. IsOutput doc => doc
Outputable.empty
Just String
opts -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_opts= " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> String
forall a. Show a => a -> String
show String
opts) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" __conf.rts_hs_main = true;",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'}',
Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\n'
]
dllMain :: SDoc
dllMain = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#include <Rts.h>",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#include <windows.h>",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#include <stdbool.h>",
Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\n',
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bool",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WINAPI",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DllMain ( HINSTANCE hInstance STG_UNUSED",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" , DWORD reason STG_UNUSED",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" , LPVOID reserved STG_UNUSED",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" )",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" return true;",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"}",
Char -> SDoc
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 (String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (IO String -> IO [String]) -> IO String -> IO [String]
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 [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
unit_state :: UnitState
unit_state = (() :: Constraint) => UnitEnv -> UnitState
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 = [SDoc] -> SDoc
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 String -> SDoc
forall doc. IsLine doc => String -> doc
text String
".section .note.GNU-stack,\"\","
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> String -> SDoc
forall doc. IsLine doc => Platform -> String -> doc
sectionType Platform
platform String
"progbits" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\n'
else SDoc
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 [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))]
ps <- MaybeErr
UnitErr
[GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))]
-> IO
[GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv
-> [UnitId]
-> MaybeErr
UnitErr
[GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
dep_packages)
[String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))]
-> [String]
collectFrameworks [GenericUnitInfo
PackageId
PackageName
UnitId
ModuleName
(GenModule (GenUnit UnitId))]
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
, (Option -> String) -> [Option] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Option -> String
showOpt (DynFlags -> [Option]
ldInputs DynFlags
dflags)
, DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_l
)
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((([String], [String], [String]), [String], Maybe String,
RtsOptsEnabled, Bool, [String], [String])
-> String
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 OS -> OS -> Bool
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)))
= Bool -> IO Bool
forall a. a -> IO a
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 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Link info: " String -> String -> String
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 = (String -> Maybe String
forall a. a -> Maybe a
Just String
link_info Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
m_exe_link_info)
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe String
m_exe_link_info of
Maybe String
Nothing -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Exe link info: Not found"
Just String
s
| Bool
sameLinkInfo -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Exe link info is the same")
| Bool
otherwise -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Exe link info is different: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
sameLinkInfo)
haveRtsOptsFlags :: DynFlags -> Bool
haveRtsOptsFlags :: DynFlags -> Bool
haveRtsOptsFlags DynFlags
dflags =
Maybe String -> Bool
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