module SysTools (
initSysTools,
initLlvmConfig,
module SysTools.Tasks,
module SysTools.Info,
linkDynLib,
copy,
copyWithHeader,
Option(..),
expandTopDir,
libmLinkOpts,
getPkgFrameworkOpts,
getFrameworkOpts
) where
#include "HsVersions.h"
import GhcPrelude
import Module
import Packages
import Config
import Outputable
import ErrUtils
import Platform
import Util
import DynFlags
import Fingerprint
import System.FilePath
import System.IO
import System.Directory
import SysTools.ExtraObj
import SysTools.Info
import SysTools.Tasks
import SysTools.BaseDir
initLlvmConfig :: Maybe String
-> IO LlvmConfig
initLlvmConfig mbMinusB
= do
targets <- readAndParse "llvm-targets" mkLlvmTarget
passes <- readAndParse "llvm-passes" id
return (targets, passes)
where
readAndParse name builder =
do top_dir <- findTopDir mbMinusB
let llvmConfigFile = top_dir </> name
llvmConfigStr <- readFile llvmConfigFile
case maybeReadFuzzy llvmConfigStr of
Just s -> return (fmap builder <$> s)
Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile)
mkLlvmTarget :: (String, String, String) -> LlvmTarget
mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)
initSysTools :: Maybe String
-> IO Settings
initSysTools mbMinusB
= do top_dir <- findTopDir mbMinusB
mtool_dir <- findToolDir top_dir
let settingsFile = top_dir </> "settings"
platformConstantsFile = top_dir </> "platformConstants"
installed :: FilePath -> FilePath
installed file = top_dir </> file
libexec :: FilePath -> FilePath
libexec file = top_dir </> "bin" </> file
settingsStr <- readFile settingsFile
platformConstantsStr <- readFile platformConstantsFile
mySettings <- case maybeReadFuzzy settingsStr of
Just s ->
return s
Nothing ->
pgmError ("Can't parse " ++ show settingsFile)
platformConstants <- case maybeReadFuzzy platformConstantsStr of
Just s ->
return s
Nothing ->
pgmError ("Can't parse " ++
show platformConstantsFile)
let getSetting key = case lookup key mySettings of
Just xs -> return $ expandTopDir top_dir xs
Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
getToolSetting key = expandToolDir mtool_dir <$> getSetting key
getBooleanSetting key = case lookup key mySettings of
Just "YES" -> return True
Just "NO" -> return False
Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
readSetting key = case lookup key mySettings of
Just xs ->
case maybeRead xs of
Just v -> return v
Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
crossCompiling <- getBooleanSetting "cross compiling"
targetArch <- readSetting "target arch"
targetOS <- readSetting "target os"
targetWordSize <- readSetting "target word size"
targetUnregisterised <- getBooleanSetting "Unregisterised"
targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
targetHasIdentDirective <- readSetting "target has .ident directive"
targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
gcc_prog <- getToolSetting "C compiler command"
gcc_args_str <- getSetting "C compiler flags"
gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
cpp_prog <- getToolSetting "Haskell CPP command"
cpp_args_str <- getSetting "Haskell CPP flags"
let unreg_gcc_args = if targetUnregisterised
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
else []
tntc_gcc_args
| mkTablesNextToCode targetUnregisterised
= ["-DTABLES_NEXT_TO_CODE"]
| otherwise = []
cpp_args= map Option (words cpp_args_str)
gcc_args = map Option (words gcc_args_str
++ unreg_gcc_args
++ tntc_gcc_args)
ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
perl_path <- getToolSetting "perl command"
let pkgconfig_path = installed "package.conf.d"
ghc_usage_msg_path = installed "ghc-usage.txt"
ghci_usage_msg_path = installed "ghci-usage.txt"
unlit_path = libexec cGHC_UNLIT_PGM
split_script = libexec cGHC_SPLIT_PGM
windres_path <- getToolSetting "windres command"
libtool_path <- getToolSetting "libtool command"
ar_path <- getToolSetting "ar command"
ranlib_path <- getToolSetting "ranlib command"
tmpdir <- getTemporaryDirectory
touch_path <- getToolSetting "touch command"
let
(split_prog, split_args)
| isWindowsHost = (perl_path, [Option split_script])
| otherwise = (split_script, [])
mkdll_prog <- getToolSetting "dllwrap command"
let mkdll_args = []
gcc_link_args_str <- getSetting "C compiler link flags"
let as_prog = gcc_prog
as_args = gcc_args
ld_prog = gcc_prog
ld_args = gcc_args ++ map Option (words gcc_link_args_str)
lc_prog <- getSetting "LLVM llc command"
lo_prog <- getSetting "LLVM opt command"
lcc_prog <- getSetting "LLVM clang command"
let iserv_prog = libexec "ghc-iserv"
let platform = Platform {
platformArch = targetArch,
platformOS = targetOS,
platformWordSize = targetWordSize,
platformUnregisterised = targetUnregisterised,
platformHasGnuNonexecStack = targetHasGnuNonexecStack,
platformHasIdentDirective = targetHasIdentDirective,
platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
platformIsCrossCompiling = crossCompiling
}
return $ Settings {
sTargetPlatform = platform,
sTmpDir = normalise tmpdir,
sGhcUsagePath = ghc_usage_msg_path,
sGhciUsagePath = ghci_usage_msg_path,
sToolDir = mtool_dir,
sTopDir = top_dir,
sRawSettings = mySettings,
sExtraGccViaCFlags = words myExtraGccViaCFlags,
sSystemPackageConfig = pkgconfig_path,
sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
sLdSupportsBuildId = ldSupportsBuildId,
sLdSupportsFilelist = ldSupportsFilelist,
sLdIsGnuLd = ldIsGnuLd,
sGccSupportsNoPie = gccSupportsNoPie,
sProgramName = "ghc",
sProjectVersion = cProjectVersion,
sPgm_L = unlit_path,
sPgm_P = (cpp_prog, cpp_args),
sPgm_F = "",
sPgm_c = (gcc_prog, gcc_args),
sPgm_s = (split_prog,split_args),
sPgm_a = (as_prog, as_args),
sPgm_l = (ld_prog, ld_args),
sPgm_dll = (mkdll_prog,mkdll_args),
sPgm_T = touch_path,
sPgm_windres = windres_path,
sPgm_libtool = libtool_path,
sPgm_ar = ar_path,
sPgm_ranlib = ranlib_path,
sPgm_lo = (lo_prog,[]),
sPgm_lc = (lc_prog,[]),
sPgm_lcc = (lcc_prog,[]),
sPgm_i = iserv_prog,
sOpt_L = [],
sOpt_P = [],
sOpt_P_fingerprint = fingerprint0,
sOpt_F = [],
sOpt_c = [],
sOpt_a = [],
sOpt_l = [],
sOpt_windres = [],
sOpt_lcc = [],
sOpt_lo = [],
sOpt_lc = [],
sOpt_i = [],
sPlatformConstants = platformConstants
}
copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
-> IO ()
copyWithHeader dflags purpose maybe_header from to = do
showPass dflags purpose
hout <- openBinaryFile to WriteMode
hin <- openBinaryFile from ReadMode
ls <- hGetContents hin
maybe (return ()) (header hout) maybe_header
hPutStr hout ls
hClose hout
hClose hin
where
header h str = do
hSetEncoding h utf8
hPutStr h str
hSetBinaryMode h True
linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLib dflags0 o_files dep_packages
= do
let
dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
else dflags0
dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
else dflags1
dflags = updateWays dflags2
verbFlags = getVerbFlags dflags
o_file = outputFile dflags
pkgs <- getPreloadPackagesAnd dflags dep_packages
let pkg_lib_paths = collectLibraryPaths dflags pkgs
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
get_pkg_lib_path_opts l
| ( osElfTarget (platformOS (targetPlatform dflags)) ||
osMachOTarget (platformOS (targetPlatform dflags)) ) &&
dynLibLoader dflags == SystemDependent &&
WayDyn `elem` ways dflags
= ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
| otherwise = ["-L" ++ l]
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
let platform = targetPlatform dflags
os = platformOS platform
pkgs_no_rts = case os of
OSMinGW32 ->
pkgs
_ ->
filter ((/= rtsUnitId) . packageConfigId) pkgs
let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
in package_hs_libs ++ extra_libs ++ other_flags
let extra_ld_inputs = ldInputs dflags
pkg_framework_opts <- getPkgFrameworkOpts dflags platform
(map unitId pkgs)
let framework_opts = getFrameworkOpts dflags platform
case os of
OSMinGW32 -> do
let output_fn = case o_file of
Just s -> s
Nothing -> "HSdll.dll"
runLink dflags (
map Option verbFlags
++ [ Option "-o"
, FileOption "" output_fn
, Option "-shared"
] ++
[ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
| gopt Opt_SharedImplib dflags
]
++ map (FileOption "") o_files
++ [Option "-Wl,--enable-auto-import"]
++ extra_ld_inputs
++ map Option (
lib_path_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
_ | os == OSDarwin -> do
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
instName <- case dylibInstallName dflags of
Just n -> return n
Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
runLink dflags (
map Option verbFlags
++ [ Option "-dynamiclib"
, Option "-o"
, FileOption "" output_fn
]
++ map Option o_files
++ [ Option "-undefined",
Option "dynamic_lookup",
Option "-single_module" ]
++ (if platformArch platform == ArchX86_64
then [ ]
else [ Option "-Wl,-read_only_relocs,suppress" ])
++ [ Option "-install_name", Option instName ]
++ map Option lib_path_opts
++ extra_ld_inputs
++ map Option framework_opts
++ map Option pkg_lib_path_opts
++ map Option pkg_link_opts
++ map Option pkg_framework_opts
++ [ Option "-Wl,-dead_strip_dylibs" ]
)
_ -> do
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
let bsymbolicFlag =
["-Wl,-Bsymbolic"]
runLink dflags (
map Option verbFlags
++ libmLinkOpts
++ [ Option "-o"
, FileOption "" output_fn
]
++ map Option o_files
++ [ Option "-shared" ]
++ map Option bsymbolicFlag
++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
++ extra_ld_inputs
++ map Option lib_path_opts
++ map Option pkg_lib_path_opts
++ map Option pkg_link_opts
)
libmLinkOpts :: [Option]
libmLinkOpts =
#if defined(HAVE_LIBM)
[Option "-lm"]
#else
[]
#endif
getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]
getPkgFrameworkOpts dflags platform dep_packages
| platformUsesFrameworks platform = do
pkg_framework_path_opts <- do
pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
return $ map ("-F" ++) pkg_framework_paths
pkg_framework_opts <- do
pkg_frameworks <- getPackageFrameworks dflags dep_packages
return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
return (pkg_framework_path_opts ++ pkg_framework_opts)
| otherwise = return []
getFrameworkOpts :: DynFlags -> Platform -> [String]
getFrameworkOpts dflags platform
| platformUsesFrameworks platform = framework_path_opts ++ framework_opts
| otherwise = []
where
framework_paths = frameworkPaths dflags
framework_path_opts = map ("-F" ++) framework_paths
frameworks = cmdlineFrameworks dflags
framework_opts = concat [ ["-framework", fw]
| fw <- reverse frameworks ]