module GHC.Linker.ExtraObj
( mkExtraObj
, mkExtraObjToLinkIntoBinary
, mkNoteObjsToLinkIntoBinary
, checkLinkInfo
, getLinkInfo
, 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.Linker.Unit
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 cFile <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule String
extn
oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o"
writeFile cFile xs
runCc Nothing logger tmpfs dflags
([Option "-c",
FileOption "" cFile,
Option "-o",
FileOption "" oFile]
++ if extn /= "s"
then cOpts
else [])
return 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
$ HasDebugCallStack =>
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)
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
link_info <- DynFlags -> UnitEnv -> [UnitId] -> IO String
getLinkInfo DynFlags
dflags UnitEnv
unit_env [UnitId]
dep_packages
if (platformSupportsSavingLinkOpts (platformOS platform ))
then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info))
else return []
where
unit_state :: UnitState
unit_state = HasDebugCallStack => 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
package_link_opts <- GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO UnitLinkOpts
getUnitLinkOpts (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Ways
ways DynFlags
dflags) UnitEnv
unit_env [UnitId]
dep_packages
pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))
then return []
else do
ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
return (collectFrameworks ps)
let link_info =
( UnitLinkOpts
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
)
return (show 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
link_info <- DynFlags -> UnitEnv -> [UnitId] -> IO String
getLinkInfo DynFlags
dflags UnitEnv
unit_env [UnitId]
pkg_deps
debugTraceMsg logger 3 $ text ("Link info: " ++ link_info)
m_exe_link_info <- readElfNoteAsString logger exe_file
ghcLinkInfoSectionName ghcLinkInfoNoteName
let 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)
debugTraceMsg logger 3 $ case 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)
return (not 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