X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=1c29c7f68869f5a6bd54567c704fa000e0f6e689;hb=9a81ddfb43b96cfeae2236c9616ca3552250b235;hp=81886ec77400af676142abe52b71e062cd041c1a;hpb=751203ddcf825e8e5e1b0d4601b1e0e8cbd05a82;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 81886ec..1c29c7f 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 @@ -461,15 +461,9 @@ doLink dflags stop_phase o_files | otherwise = case ghcLink dflags of NoLink -> return () - LinkBinary -> linkBinary dflags o_files link_pkgs + LinkBinary -> linkBinary dflags o_files [] LinkDynLib -> linkDynLib dflags o_files [] other -> panicBadLink other - where - -- Always link in the haskell98 package for static linking. Other - -- packages have to be specified via the -package flag. - link_pkgs - | dopt Opt_AutoLinkPackages dflags = [haskell98PackageId] - | otherwise = [] -- --------------------------------------------------------------------------- @@ -700,30 +694,27 @@ 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 - let dflags0' = flattenExtensionFlags dflags0 - src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn + 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 - let dflags2' = flattenExtensionFlags dflags2 - unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns + unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings checkProcessArgsResult unhandled_flags @@ -734,11 +725,10 @@ 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 @@ -752,14 +742,13 @@ 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 - let dflags1' = flattenExtensionFlags dflags1 - handleFlagWarnings dflags1' warns + handleFlagWarnings dflags1 warns checkProcessArgsResult unhandled_flags - return (Hsc sf, dflags1', maybe_loc, output_fn) + return (Hsc sf, dflags1, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Hsc phase @@ -907,10 +896,9 @@ 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 - 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) + 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 @@ -1289,11 +1277,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) @@ -1332,8 +1324,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 @@ -1350,43 +1342,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); - (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" @@ -1513,12 +1470,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 @@ -1565,7 +1526,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) @@ -1613,7 +1574,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")) @@ -1698,19 +1659,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] @@ -1722,6 +1673,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 @@ -1897,17 +1860,10 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do , SysTools.FileOption "" output_fn ]) -cHaskell1Version :: String -cHaskell1Version = "5" -- i.e., Haskell 98 - hsSourceCppOpts :: [String] -- Default CPP defines in Haskell source hsSourceCppOpts = - [ "-D__HASKELL1__="++cHaskell1Version - , "-D__GLASGOW_HASKELL__="++cProjectVersionInt - , "-D__HASKELL98__" - , "-D__CONCURRENT_HASKELL__" - ] + [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] -- -----------------------------------------------------------------------------