X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=f4f65384250f20c624b1a2412940ecdbbb254311;hb=3ebd889775714f8ad3bae8d9cc7a4790ef04614f;hp=2019836fabd1e3e73b62088ecf4d59f98a51b42d;hpb=1971591f865ac0806802c476f23792ae2c89411a;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 2019836..f4f6538 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -38,7 +38,7 @@ import Module 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 @@ -581,7 +581,9 @@ pipeLoop hsc_env phase stop_phase " 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'} @@ -912,7 +914,7 @@ runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc 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 @@ -1250,20 +1252,27 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn 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 ([ SysTools.FileOption "" input_fn, - SysTools.Option (llvmOpts !! opt_lvl), SysTools.Option "-o", SysTools.FileOption "" output_fn] - ++ map SysTools.Option lo_opts) + ++ 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"] @@ -1280,11 +1289,15 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc #else let nphase = As #endif + let rmodel | opt_PIC = "pic" + | not opt_Static = "dynamic-no-pic" + | otherwise = "static" output_fn <- get_output_fn dflags nphase maybe_loc SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), + SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts) @@ -1504,12 +1517,16 @@ linkBinary dflags o_files dep_packages = do 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 @@ -1689,19 +1706,9 @@ linkDynLib dflags o_files dep_packages = do 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] @@ -1713,6 +1720,18 @@ linkDynLib dflags o_files dep_packages = do 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