X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=c0aed96e7051f3530152af9c7f505e05196da10d;hp=5a7e78d86044e9714e18407d7cb90b47cba58314;hb=c9959e41ee1d72aa0ca28d51580f1ad3c06f0e8b;hpb=d1df0c600a5191df08e28b3f1eaa371deba45d5e diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 5a7e78d..c0aed96 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -35,7 +35,7 @@ import Finder import HscTypes import Outputable import Module -import LazyUniqFM ( eltsUFM ) +import UniqFM ( eltsUFM ) import ErrUtils import DynFlags import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) @@ -48,12 +48,12 @@ import Maybes ( expectJust ) import ParserCoreUtils ( getCoreModuleName ) import SrcLoc import FastString -import MonadUtils +-- import MonadUtils -import Data.Either +-- import Data.Either import Exception import Data.IORef ( readIORef ) -import GHC.Exts ( Int(..) ) +-- import GHC.Exts ( Int(..) ) import System.Directory import System.FilePath import System.IO @@ -187,7 +187,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -> return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. _other - -> do runPipeline StopLn hsc_env' (output_fn,Nothing) + -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) @@ -264,7 +264,7 @@ compileStub hsc_env mod location = do let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) (moduleName mod) location - runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing (SpecificFile stub_o) Nothing{-no ModLocation-} return stub_o @@ -696,19 +696,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 - (dflags, unhandled_flags, warns) + (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts - handleFlagWarnings dflags warns checkProcessArgsResult unhandled_flags - if not (dopt Opt_Cpp dflags) then + if not (dopt Opt_Cpp dflags1) then do + -- we have to be careful to emit warnings only once. + 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, dflags, maybe_loc, input_fn) + return (HsPp sf, dflags1, maybe_loc, input_fn) else do - output_fn <- liftIO $ get_output_fn dflags (HsPp sf) maybe_loc - liftIO $ doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn - return (HsPp sf, dflags, maybe_loc, 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 + (dflags2, unhandled_flags, warns) + <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts + unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns + -- the HsPp pass below will emit warnings + checkProcessArgsResult unhandled_flags + + return (HsPp sf, dflags2, maybe_loc, output_fn) ------------------------------------------------------------------------------- -- HsPp phase @@ -730,7 +741,15 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc ] ++ map SysTools.Option hspp_opts ) - return (Hsc sf, dflags, maybe_loc, output_fn) + + -- re-read pragmas now that we've parsed the file (see #3674) + src_opts <- liftIO $ getOptionsFromFile dflags output_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicNoPackageFlags dflags src_opts + handleFlagWarnings dflags1 warns + checkProcessArgsResult unhandled_flags + + return (Hsc sf, dflags1, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Hsc phase @@ -974,21 +993,21 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc then [] else [ "-ffloat-store" ]) ++ #endif + -- gcc's -fstrict-aliasing allows two accesses to memory -- to be considered non-aliasing if they have different types. -- This interacts badly with the C code we generate, which is -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - - liftIO $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. -- Also useful for plain .c files, just in case GHC saw a -- -x c option. [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp - then SysTools.Option "c++" else SysTools.Option "c"] ++ + then SysTools.Option "c++" + else SysTools.Option "c"] ++ [ SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn @@ -996,6 +1015,18 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ++ map SysTools.Option ( md_c_flags ++ pic_c_flags + +#if defined(mingw32_TARGET_OS) + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (if thisPackage dflags == basePackageId + then [ "-DCOMPILING_BASE_PACKAGE" ] + else []) +#endif + #ifdef sparc_TARGET_ARCH -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction. Note that the user can still override this @@ -1005,13 +1036,6 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- This is a temporary hack. ++ ["-mcpu=v9"] #endif -#if defined(darwin_TARGET_OS) && defined(i386_TARGET_ARCH) - -- By default, gcc on OS X will generate SSE - -- instructions, which need things 16-byte aligned, - -- but we don't 16-byte align things. Thus drop - -- back to generic i686 compatibility. Trac #2983. - ++ ["-march=i686"] -#endif ++ (if hcc && mangle then md_regd_c_flags else []) @@ -1141,8 +1165,8 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc output_fn <- get_output_fn dflags StopLn maybe_loc let base_o = dropExtension output_fn - split_odir = base_o ++ "_split" osuf = objectSuf dflags + split_odir = base_o ++ "_" ++ osuf ++ "_split" createDirectoryHierarchy split_odir @@ -1234,7 +1258,7 @@ runPhase_MoveBinary dflags input_fn dep_packages pvm_executable_base = "=" ++ input_fn pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base -- nuke old binary; maybe use configur'ed names for cp and rm? - tryIO (removeFile pvm_executable) + _ <- tryIO (removeFile pvm_executable) -- move the newly created binary into PVM land copy dflags "copying PVM executable" input_fn pvm_executable -- generate a wrapper script for running a parallel prg under PVM @@ -1275,6 +1299,20 @@ wrapper_behaviour dflags mode 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" + oFile <- newTempName dflags "o" + writeFile cFile $ unlines xs + let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId + SysTools.runCc dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] ++ + map (FileOption "-I") (includeDirs rtsDetails)) + return oFile + -- generates a Perl skript starting a parallel prg under PVM mk_pvm_wrapper_script :: String -> String -> String -> String mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ @@ -1369,7 +1407,7 @@ linkBinary dflags o_files dep_packages = do pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) -#ifdef linux_TARGET_OS +#ifdef elf_OBJ_FORMAT get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] | otherwise = ["-L" ++ l] #else @@ -1385,6 +1423,20 @@ 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 [] + rtsOptsObj <- case rtsOpts dflags of + Just opts -> + do fn <- mkExtraCObj dflags + -- We assume that the Haskell "show" does + -- the right thing here + ["char *ghc_rts_opts = " ++ show opts ++ ";"] + return [fn] + Nothing -> return [] pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1423,7 +1475,7 @@ linkBinary dflags o_files dep_packages = do let thread_opts | WayThreaded `elem` ways = [ -#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) +#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(haiku_TARGET_OS) "-lpthread" #endif #if defined(osf3_TARGET_OS) @@ -1442,6 +1494,12 @@ linkBinary dflags o_files dep_packages = do ] ++ map SysTools.Option ( md_c_flags + +#ifdef mingw32_TARGET_OS + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ ["-Wl,--enable-auto-import"] +#endif ++ o_files ++ extra_ld_inputs ++ lib_path_opts @@ -1453,6 +1511,8 @@ linkBinary dflags o_files dep_packages = do #endif ++ pkg_lib_path_opts ++ main_lib + ++ rtsEnabledObj + ++ rtsOptsObj ++ pkg_link_opts #ifdef darwin_TARGET_OS ++ pkg_framework_path_opts @@ -1562,7 +1622,7 @@ linkDynLib dflags o_files dep_packages = do #endif let pkg_lib_paths = collectLibraryPaths pkgs_no_rts let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths -#ifdef linux_TARGET_OS +#ifdef elf_OBJ_FORMAT get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] | otherwise = ["-L" ++ l] #else @@ -1590,11 +1650,18 @@ linkDynLib dflags o_files dep_packages = do , SysTools.Option "-o" , SysTools.FileOption "" output_fn , SysTools.Option "-shared" - , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + ] ++ + [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | dopt Opt_SharedImplib dflags ] ++ map (SysTools.FileOption "") o_files ++ map SysTools.Option ( md_c_flags + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ++ ["-Wl,--enable-auto-import"] + ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts @@ -1625,16 +1692,22 @@ linkDynLib dflags o_files dep_packages = do -- later, so that it will not complain about the use of the option -- -undefined dynamic_lookup above. -- -install_name - -- Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading - -- this lib and instead look for it at its absolute path. - -- When installing the .dylibs (see target.mk), we'll change that path to - -- point to the place they are installed. Therefore, we won't have to set - -- up DYLD_LIBRARY_PATH specifically for ghc. + -- Mac OS/X stores the path where a dynamic library is (to be) installed + -- in the library itself. It's called the "install name" of the library. + -- Then any library or executable that links against it before it's + -- installed will search for it in its ultimate install location. By + -- default we set the install name to the absolute path at build time, but + -- it can be overridden by the -dylib-install-name option passed to ghc. + -- Cabal does this. ----------------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - pwd <- getCurrentDirectory + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> do + pwd <- getCurrentDirectory + return $ pwd `combine` output_fn SysTools.runLink dflags ([ SysTools.Option verb , SysTools.Option "-dynamiclib" @@ -1644,7 +1717,8 @@ linkDynLib dflags o_files dep_packages = do ++ map SysTools.Option ( md_c_flags ++ o_files - ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd output_fn) ] + ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.5", + "-Wl,-read_only_relocs,suppress", "-install_name", instName ] ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts @@ -1657,6 +1731,14 @@ linkDynLib dflags o_files dep_packages = do ----------------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + let buildingRts = thisPackage dflags == rtsPackageId + let bsymbolicFlag = if buildingRts + then -- -Bsymbolic breaks the way we implement + -- hooks in the RTS + [] + else -- we need symbolic linking to resolve + -- non-PIC intra-package-relocations + ["-Wl,-Bsymbolic"] SysTools.runLink dflags ([ SysTools.Option verb @@ -1666,7 +1748,8 @@ linkDynLib dflags o_files dep_packages = do ++ map SysTools.Option ( md_c_flags ++ o_files - ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations + ++ [ "-shared" ] + ++ bsymbolicFlag ++ [ "-Wl,-soname," ++ takeFileName output_fn ] -- set the library soname ++ extra_ld_inputs ++ lib_path_opts