import UniqFM ( eltsUFM )
import ErrUtils
import DynFlags
-import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) )
+import StaticFlags ( v_Ld_inputs, opt_PIC, opt_Static, WayName(..) )
import Config
import Panic
import Util
import ParserCoreUtils ( getCoreModuleName )
import SrcLoc
import FastString
+import LlvmCodeGen ( llvmFixupAsm )
-- import MonadUtils
-- import Data.Either
" but I wanted to stop at phase " ++ show stop_phase)
| otherwise
- = do (next_phase, dflags', maybe_loc, output_fn)
+ = do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
+ (ptext (sLit "Running phase") <+> ppr phase)
+ (next_phase, dflags', maybe_loc, output_fn)
<- runPhase phase stop_phase hsc_env orig_basename
orig_suff input_fn orig_get_output_fn maybe_loc
let hsc_env' = hsc_env {hsc_dflags = dflags'}
runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do let dflags0 = hsc_dflags hsc_env
- src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
+ let dflags0' = flattenExtensionFlags dflags0
+ src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
checkProcessArgsResult unhandled_flags
+ let dflags1' = flattenExtensionFlags dflags1
- if not (dopt Opt_Cpp dflags1) then do
+ if not (xopt Opt_Cpp dflags1') then do
-- we have to be careful to emit warnings only once.
- unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
+ unless (dopt Opt_Pp dflags1') $ handleFlagWarnings dflags1' warns
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
return (HsPp sf, dflags1, maybe_loc, input_fn)
else do
- output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc
- liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
+ output_fn <- liftIO $ get_output_fn dflags1' (HsPp sf) maybe_loc
+ liftIO $ doCpp dflags1' True{-raw-} False{-no CC opts-} input_fn output_fn
-- re-read the pragmas now that we've preprocessed the file
-- See #2464,#3457
- src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
+ src_opts <- liftIO $ getOptionsFromFile dflags0' output_fn
(dflags2, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
- unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
+ let dflags2' = flattenExtensionFlags dflags2
+ unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
-- the HsPp pass below will emit warnings
checkProcessArgsResult unhandled_flags
runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
= do let dflags = hsc_dflags hsc_env
+ dflags' = flattenExtensionFlags dflags
if not (dopt Opt_Pp dflags) then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
- return (Hsc sf, dflags, maybe_loc, input_fn)
+ return (Hsc sf, dflags', maybe_loc, input_fn)
else do
let hspp_opts = getOpts dflags opt_F
let orig_fn = basename <.> suff
)
-- re-read pragmas now that we've parsed the file (see #3674)
- src_opts <- liftIO $ getOptionsFromFile dflags output_fn
+ src_opts <- liftIO $ getOptionsFromFile dflags' output_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags src_opts
- handleFlagWarnings dflags1 warns
+ let dflags1' = flattenExtensionFlags dflags1
+ handleFlagWarnings dflags1' warns
checkProcessArgsResult unhandled_flags
- return (Hsc sf, dflags1, maybe_loc, output_fn)
+ return (Hsc sf, dflags1', maybe_loc, output_fn)
-----------------------------------------------------------------------------
-- Hsc phase
runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do
let dflags = hsc_dflags hsc_env
- output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc
- liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
- return (Cmm, dflags, maybe_loc, output_fn)
+ dflags' = flattenExtensionFlags dflags
+ output_fn <- liftIO $ get_output_fn dflags' Cmm maybe_loc
+ liftIO $ doCpp dflags' False{-not raw-} True{-include CC opts-} input_fn output_fn
+ return (Cmm, dflags', maybe_loc, output_fn)
runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
= do
- let dflags = hsc_dflags hsc_env
+ let dflags = ensureFlattenedExtensionFlags $ hsc_dflags hsc_env
let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
let dflags = hsc_dflags hsc_env
let lo_opts = getOpts dflags opt_lo
let opt_lvl = max 0 (min 2 $ optLevel dflags)
+ -- don't specify anything if user has specified commands. We do this for
+ -- opt but not llc since opt is very specifically for optimisation passes
+ -- only, so if the user is passing us extra options we assume they know
+ -- what they are doing and don't get in the way.
+ let optFlag = if null lo_opts
+ then [SysTools.Option (llvmOpts !! opt_lvl)]
+ else []
output_fn <- get_output_fn dflags LlvmLlc maybe_loc
SysTools.runLlvmOpt dflags
- (map SysTools.Option lo_opts
- ++ [ SysTools.FileOption "" input_fn,
- SysTools.Option (llvmOpts !! opt_lvl),
+ ([ SysTools.FileOption "" input_fn,
SysTools.Option "-o",
- SysTools.FileOption "" output_fn])
+ SysTools.FileOption "" output_fn]
+ ++ optFlag
+ ++ map SysTools.Option lo_opts)
return (LlvmLlc, dflags, maybe_loc, output_fn)
where
- -- we always run Opt since we rely on it to fix up some pretty
- -- big deficiencies in the code we generate
+ -- we always (unless -optlo specified) run Opt since we rely on it to
+ -- fix up some pretty big deficiencies in the code we generate
llvmOpts = ["-mem2reg", "-O1", "-O2"]
let dflags = hsc_dflags hsc_env
let lc_opts = getOpts dflags opt_lc
let opt_lvl = max 0 (min 2 $ optLevel dflags)
+#if darwin_TARGET_OS
+ let nphase = LlvmMangle
+#else
+ let nphase = As
+#endif
+ let rmodel | opt_PIC = "pic"
+ | not opt_Static = "dynamic-no-pic"
+ | otherwise = "static"
- output_fn <- get_output_fn dflags As maybe_loc
+ output_fn <- get_output_fn dflags nphase maybe_loc
SysTools.runLlvmLlc dflags
- (map SysTools.Option lc_opts
- ++ [ -- SysTools.Option "-tailcallopt",
- SysTools.Option (llvmOpts !! opt_lvl),
+ ([ SysTools.Option (llvmOpts !! opt_lvl),
+ SysTools.Option $ "-relocation-model=" ++ rmodel,
SysTools.FileOption "" input_fn,
- SysTools.Option "-o", SysTools.FileOption "" output_fn])
+ SysTools.Option "-o", SysTools.FileOption "" output_fn]
+ ++ map SysTools.Option lc_opts)
- return (As, dflags, maybe_loc, output_fn)
+ return (nphase, dflags, maybe_loc, output_fn)
where
+#if darwin_TARGET_OS
+ llvmOpts = ["-O1", "-O2", "-O2"]
+#else
llvmOpts = ["-O1", "-O2", "-O3"]
+#endif
+
+
+-----------------------------------------------------------------------------
+-- LlvmMangle phase
+
+runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+ = liftIO $ do
+ let dflags = hsc_dflags hsc_env
+ output_fn <- get_output_fn dflags As maybe_loc
+ llvmFixupAsm input_fn output_fn
+ return (As, dflags, maybe_loc, output_fn)
-- warning suppression
-- we don't need the generality of a phase (MoveBinary is always
-- done after linking and makes only sense in a parallel setup) -- HWL
-runPhase_MoveBinary :: DynFlags -> FilePath -> [PackageId] -> IO Bool
-runPhase_MoveBinary dflags input_fn dep_packages
+runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
+runPhase_MoveBinary dflags input_fn
| WayPar `elem` (wayNames dflags) && not opt_Static =
panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
| WayPar `elem` (wayNames dflags) = do
-- generate a wrapper script for running a parallel prg under PVM
writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
return True
- | not opt_Static =
- case (dynLibLoader dflags) of
- Wrapped wrapmode ->
- do
- let (o_base, o_ext) = splitExtension input_fn
- let wrapped_executable | o_ext == "exe" = (o_base ++ ".dyn") <.> o_ext
- | otherwise = input_fn ++ ".dyn"
- behaviour <- wrapper_behaviour dflags wrapmode dep_packages
-
- -- THINKME isn't this possible to do a bit nicer?
- let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour
- renameFile input_fn wrapped_executable
- let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId);
- (md_c_flags, _) = machdepCCOpts dflags
- SysTools.runCc dflags
- ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c")
- , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"")
- , SysTools.Option "-o"
- , SysTools.FileOption "" input_fn] ++
- map (SysTools.FileOption "-I") (includeDirs rtsDetails) ++
- map Option md_c_flags)
- return True
- _ -> return True
| otherwise = return True
-wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char]
-wrapper_behaviour dflags mode dep_packages =
- let seperateBySemiColon strs = tail $ concatMap (';':) strs
- in case mode of
- Nothing -> do
- pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
- return ('H' : (seperateBySemiColon pkg_lib_paths))
- Just s -> do
- allpkg <- getPreloadPackagesAnd dflags dep_packages
- putStrLn (unwords (map (packageIdString . packageConfigId) allpkg))
- return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg))
-
mkExtraCObj :: DynFlags -> [String] -> IO FilePath
mkExtraCObj dflags xs
= do cFile <- newTempName dflags "c"
let no_hs_main = dopt Opt_NoHsMain dflags
let main_lib | no_hs_main = []
| otherwise = [ "-lHSrtsmain" ]
- rtsEnabledObj <- if dopt Opt_RtsOptsEnabled dflags
- then do fn <- mkExtraCObj dflags
- ["#include \"Rts.h\"",
- "const rtsBool rtsOptsEnabled = rtsTrue;"]
- return [fn]
- else return []
+ let mkRtsEnabledObj val = do fn <- mkExtraCObj dflags
+ ["#include \"Rts.h\"",
+ "#include \"RtsOpts.h\"",
+ "const rtsOptsEnabledEnum rtsOptsEnabled = "
+ ++ val ++ ";"]
+ return [fn]
+ rtsEnabledObj <- case rtsOptsEnabled dflags of
+ RtsOptsNone -> mkRtsEnabledObj "rtsOptsNone"
+ RtsOptsSafeOnly -> return []
+ RtsOptsAll -> mkRtsEnabledObj "rtsOptsAll"
rtsOptsObj <- case rtsOpts dflags of
Just opts ->
do fn <- mkExtraCObj dflags
let
thread_opts | WayThreaded `elem` ways = [
-#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(haiku_TARGET_OS)
+#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(haiku_TARGET_OS)
"-lpthread"
#endif
#if defined(osf3_TARGET_OS)
))
-- parallel only: move binary to another dir -- HWL
- success <- runPhase_MoveBinary dflags output_fn dep_packages
+ success <- runPhase_MoveBinary dflags output_fn
if success then return ()
else ghcError (InstallationError ("cannot move binary"))
let verb = getVerbFlag dflags
let o_file = outputFile dflags
- -- We don't want to link our dynamic libs against the RTS package,
- -- because the RTS lib comes in several flavours and we want to be
- -- able to pick the flavour when a binary is linked.
pkgs <- getPreloadPackagesAnd dflags dep_packages
- -- On Windows we need to link the RTS import lib as Windows does
- -- not allow undefined symbols.
-#if !defined(mingw32_HOST_OS)
- let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
-#else
- let pkgs_no_rts = pkgs
-#endif
- let pkg_lib_paths = collectLibraryPaths pkgs_no_rts
+ let pkg_lib_paths = collectLibraryPaths pkgs
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
#ifdef elf_OBJ_FORMAT
get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
+ -- We don't want to link our dynamic libs against the RTS package,
+ -- because the RTS lib comes in several flavours and we want to be
+ -- able to pick the flavour when a binary is linked.
+ -- On Windows we need to link the RTS import lib as Windows does
+ -- not allow undefined symbols.
+ -- The RTS library path is still added to the library search path
+ -- above in case the RTS is being explicitly linked in (see #3807).
+#if !defined(mingw32_HOST_OS)
+ let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
+#else
+ let pkgs_no_rts = pkgs
+#endif
let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
-- probably _stub.o files
cpp_prog ([SysTools.Option verb]
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
+ ++ map SysTools.Option target_defs
++ map SysTools.Option hscpp_opts
++ map SysTools.Option cc_opts
- ++ map SysTools.Option target_defs
++ [ SysTools.Option "-x"
, SysTools.Option "c"
, SysTools.Option input_fn
projects / ghc-hetmet.git / blobdiff