{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-}
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 GHC.Settings
import Module
import Packages
import Config
import Outputable
import ErrUtils
import GHC.Platform
import DynFlags
import Fingerprint
import ToolSettings
import qualified Data.Map as Map
import System.FilePath
import System.IO
import System.Directory
import SysTools.ExtraObj
import SysTools.Info
import SysTools.Tasks
import SysTools.BaseDir
initLlvmConfig :: String
-> IO LlvmConfig
initLlvmConfig top_dir
= do
targets <- readAndParse "llvm-targets" mkLlvmTarget
passes <- readAndParse "llvm-passes" id
return (targets, passes)
where
readAndParse name builder =
do 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 :: String
-> IO Settings
initSysTools top_dir
= do
mtool_dir <- findToolDir top_dir
let installed :: FilePath -> FilePath
installed file = top_dir </> file
libexec :: FilePath -> FilePath
libexec file = top_dir </> "bin" </> file
settingsFile = installed "settings"
platformConstantsFile = installed "platformConstants"
settingsStr <- readFile settingsFile
platformConstantsStr <- readFile platformConstantsFile
settingsList <- case maybeReadFuzzy settingsStr of
Just s ->
return s
Nothing ->
pgmError ("Can't parse " ++ show settingsFile)
let mySettings = Map.fromList settingsList
platformConstants <- case maybeReadFuzzy platformConstantsStr of
Just s ->
return s
Nothing ->
pgmError ("Can't parse " ++
show platformConstantsFile)
let getSetting key = either pgmError pure $
getFilePathSetting0 top_dir settingsFile mySettings key
getToolSetting :: String -> IO String
getToolSetting key = expandToolDir mtool_dir <$> getSetting key
getBooleanSetting :: String -> IO Bool
getBooleanSetting key = either pgmError pure $
getBooleanSetting0 settingsFile mySettings key
targetPlatformString <- getSetting "target platform string"
tablesNextToCode <- getBooleanSetting "Tables next to code"
myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
cc_prog <- getToolSetting "C compiler command"
cc_args_str <- getSetting "C compiler flags"
cxx_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"
platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings
let unreg_cc_args = if platformUnregisterised platform
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
else []
cpp_args = map Option (words cpp_args_str)
cc_args = words cc_args_str ++ unreg_cc_args
cxx_args = words cxx_args_str
ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
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 <- getToolSetting "unlit command"
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"
mkdll_prog <- getToolSetting "dllwrap command"
let mkdll_args = []
cc_link_args_str <- getSetting "C compiler link flags"
let as_prog = cc_prog
as_args = map Option cc_args
ld_prog = cc_prog
ld_args = map Option (cc_args ++ words cc_link_args_str)
llvmTarget <- getSetting "LLVM target"
lc_prog <- getSetting "LLVM llc command"
lo_prog <- getSetting "LLVM opt command"
lcc_prog <- getSetting "LLVM clang command"
let iserv_prog = libexec "ghc-iserv"
integerLibrary <- getSetting "integer library"
integerLibraryType <- case integerLibrary of
"integer-gmp" -> pure IntegerGMP
"integer-simple" -> pure IntegerSimple
_ -> pgmError $ unwords
[ "Entry for"
, show "integer library"
, "must be one of"
, show "integer-gmp"
, "or"
, show "integer-simple"
]
ghcWithInterpreter <- getBooleanSetting "Use interpreter"
ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator"
ghcWithSMP <- getBooleanSetting "Support SMP"
ghcRTSWays <- getSetting "RTS ways"
leadingUnderscore <- getBooleanSetting "Leading underscore"
useLibFFI <- getBooleanSetting "Use LibFFI"
ghcThreaded <- getBooleanSetting "Use Threads"
ghcDebugged <- getBooleanSetting "Use Debugging"
ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"
return $ Settings
{ sGhcNameVersion = GhcNameVersion
{ ghcNameVersion_programName = "ghc"
, ghcNameVersion_projectVersion = cProjectVersion
}
, sFileSettings = FileSettings
{ fileSettings_tmpDir = normalise tmpdir
, fileSettings_ghcUsagePath = ghc_usage_msg_path
, fileSettings_ghciUsagePath = ghci_usage_msg_path
, fileSettings_toolDir = mtool_dir
, fileSettings_topDir = top_dir
, fileSettings_systemPackageConfig = pkgconfig_path
}
, sToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
, toolSettings_ldSupportsBuildId = ldSupportsBuildId
, toolSettings_ldSupportsFilelist = ldSupportsFilelist
, toolSettings_ldIsGnuLd = ldIsGnuLd
, toolSettings_ccSupportsNoPie = gccSupportsNoPie
, toolSettings_pgm_L = unlit_path
, toolSettings_pgm_P = (cpp_prog, cpp_args)
, toolSettings_pgm_F = ""
, toolSettings_pgm_c = cc_prog
, toolSettings_pgm_a = (as_prog, as_args)
, toolSettings_pgm_l = (ld_prog, ld_args)
, toolSettings_pgm_dll = (mkdll_prog,mkdll_args)
, toolSettings_pgm_T = touch_path
, toolSettings_pgm_windres = windres_path
, toolSettings_pgm_libtool = libtool_path
, toolSettings_pgm_ar = ar_path
, toolSettings_pgm_ranlib = ranlib_path
, toolSettings_pgm_lo = (lo_prog,[])
, toolSettings_pgm_lc = (lc_prog,[])
, toolSettings_pgm_lcc = (lcc_prog,[])
, toolSettings_pgm_i = iserv_prog
, toolSettings_opt_L = []
, toolSettings_opt_P = []
, toolSettings_opt_P_fingerprint = fingerprint0
, toolSettings_opt_F = []
, toolSettings_opt_c = cc_args
, toolSettings_opt_cxx = cxx_args
, toolSettings_opt_a = []
, toolSettings_opt_l = []
, toolSettings_opt_windres = []
, toolSettings_opt_lcc = []
, toolSettings_opt_lo = []
, toolSettings_opt_lc = []
, toolSettings_opt_i = []
, toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags
}
, sTargetPlatform = platform
, sPlatformMisc = PlatformMisc
{ platformMisc_targetPlatformString = targetPlatformString
, platformMisc_integerLibrary = integerLibrary
, platformMisc_integerLibraryType = integerLibraryType
, platformMisc_ghcWithInterpreter = ghcWithInterpreter
, platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen
, platformMisc_ghcWithSMP = ghcWithSMP
, platformMisc_ghcRTSWays = ghcRTSWays
, platformMisc_tablesNextToCode = tablesNextToCode
, platformMisc_leadingUnderscore = leadingUnderscore
, platformMisc_libFFI = useLibFFI
, platformMisc_ghcThreaded = ghcThreaded
, platformMisc_ghcDebugged = ghcDebugged
, platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw
, platformMisc_llvmTarget = llvmTarget
}
, sPlatformConstants = platformConstants
, sRawSettings = settingsList
}
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 platformMisc_ghcThreaded $ platformMisc dflags0
then addWay' WayThreaded dflags0
else dflags0
dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1
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"; }
unregisterised = platformUnregisterised (targetPlatform dflags)
let bsymbolicFlag =
["-Wl,-Bsymbolic" | not unregisterised]
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 ]