X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=464aa28350a94fb561ede9231c6c93f8fb790db9;hp=c6d3d0a47c1d48b195b89b485418521e6b78f226;hb=190b2d90f92f61eb802275729106b5d9fb9a7a7c;hpb=5576c3a5d24fd20c274b91156ed10c034e1cb809 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c6d3d0a..464aa28 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 @@ -48,6 +48,7 @@ import Maybes ( expectJust ) import ParserCoreUtils ( getCoreModuleName ) import SrcLoc import FastString +import LlvmCodeGen ( llvmFixupAsm ) -- import MonadUtils -- import Data.Either @@ -580,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'} @@ -605,6 +608,7 @@ getOutputFilename stop_phase output basename keep_hc = dopt Opt_KeepHcFiles dflags keep_raw_s = dopt Opt_KeepRawSFiles dflags keep_s = dopt Opt_KeepSFiles dflags + keep_bc = dopt Opt_KeepLlvmFiles dflags myPhaseInputExt HCc = hcsuf myPhaseInputExt StopLn = osuf @@ -615,11 +619,12 @@ getOutputFilename stop_phase output basename -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - StopLn -> True - Mangle | keep_raw_s -> True - As | keep_s -> True - HCc | keep_hc -> True - _other -> False + StopLn -> True + Mangle | keep_raw_s -> True + As | keep_s -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + _other -> False suffix = myPhaseInputExt next_phase @@ -695,27 +700,30 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l 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 @@ -726,10 +734,11 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc 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 @@ -743,13 +752,14 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc ) -- 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 @@ -897,13 +907,14 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma 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 @@ -1232,6 +1243,85 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc return (StopLn, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- LlvmOpt phase + +runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = liftIO $ do + 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 "-o", + SysTools.FileOption "" output_fn] + ++ optFlag + ++ map SysTools.Option lo_opts) + + return (LlvmLlc, dflags, maybe_loc, output_fn) + where + -- 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"] + + +----------------------------------------------------------------------------- +-- LlvmLlc phase + +runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = liftIO $ do + 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 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) + + 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 runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = panic ("runPhase: don't know how to run phase " ++ show other) @@ -1246,8 +1336,8 @@ runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc -- 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 @@ -1264,41 +1354,8 @@ runPhase_MoveBinary dflags input_fn dep_packages -- 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); - 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)) - 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" @@ -1425,12 +1482,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 @@ -1477,7 +1538,7 @@ linkBinary dflags o_files dep_packages = do 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) @@ -1525,7 +1586,7 @@ linkBinary dflags o_files dep_packages = do )) -- 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")) @@ -1610,19 +1671,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] @@ -1634,6 +1685,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 @@ -1791,9 +1854,9 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do 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 @@ -1832,6 +1895,7 @@ hscNextPhase dflags _ hsc_lang = HscC -> HCc HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle | otherwise -> As + HscLlvm -> LlvmOpt HscNothing -> StopLn HscInterpreted -> StopLn _other -> StopLn