X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=4f19cfab38d5ff2f98e5c55d506413bb035fbe69;hb=eb4352ab0675309fe6cb1ad38cf070340a338e50;hp=b1a8189f2c59086a2e48134915539b5bd2cc7d63;hpb=3c22606bf3114747deeae0a8a1d5832ee834d9d1;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index b1a8189..4f19cfa 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -12,16 +12,13 @@ module DriverPipeline ( oneShot, compileFile, -- Interfaces for the batch-mode driver - staticLink, + linkBinary, -- Interfaces for the compilation manager (interpreted/batch-mode) preprocess, compile, CompResult(..), link, - -- DLL building - doMkDLL, - ) where #include "HsVersions.h" @@ -30,7 +27,6 @@ import Packages import HeaderInfo import DriverPhases import SysTools -import qualified SysTools import HscMain import Finder import HscTypes @@ -39,7 +35,7 @@ import Module import UniqFM ( eltsUFM ) import ErrUtils import DynFlags -import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) +import StaticFlags ( v_Ld_inputs, opt_Static, opt_HardwireLibPaths, WayName(..) ) import Config import Panic import Util @@ -60,7 +56,6 @@ import Control.Monad import Data.List ( isSuffixOf ) import Data.Maybe import System.Exit -import System.Cmd import System.Environment -- --------------------------------------------------------------------------- @@ -161,7 +156,9 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do return (CompOK details iface maybe_old_linkable) handleBatch (HscRecomp hasStub, iface, details) | isHsBoot src_flavour - = return (CompOK details iface Nothing) + = do SysTools.touch dflags' "Touching object file" + object_filename + return (CompOK details iface Nothing) | otherwise = do stub_unlinked <- getStubLinkable hasStub (hs_unlinked, unlinked_time) <- @@ -316,13 +313,13 @@ link LinkBinary dflags batch_attempt_linking hpt -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of - MkDLL -> doMkDLL - LinkBinary -> staticLink + LinkBinary -> linkBinary + LinkDynLib -> linkDynLib link dflags obj_files pkg_deps debugTraceMsg dflags 3 (text "link: done") - -- staticLink only returns if it succeeds + -- linkBinary only returns if it succeeds return Succeeded | otherwise @@ -330,7 +327,6 @@ link LinkBinary dflags batch_attempt_linking hpt text " Main.main not exported; not linking.") return Succeeded - -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. @@ -377,8 +373,8 @@ doLink dflags stop_phase o_files | otherwise = case ghcLink dflags of NoLink -> return () - LinkBinary -> staticLink dflags o_files link_pkgs - MkDLL -> doMkDLL dflags o_files link_pkgs + LinkBinary -> linkBinary dflags o_files link_pkgs + LinkDynLib -> linkDynLib dflags o_files [] where -- Always link in the haskell98 package for static linking. Other -- packages have to be specified via the -package flag. @@ -643,15 +639,15 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma dflags = dflags0 { includePaths = current_dir : paths } -- gather the imports and module name - (hspp_buf,mod_name) <- + (hspp_buf,mod_name,imps,src_imps) <- case src_flavour of ExtCoreFile -> do { -- no explicit imports in ExtCore input. ; m <- getCoreModuleName input_fn - ; return (Nothing, mkModuleName m) } + ; return (Nothing, mkModuleName m, [], []) } other -> do { buf <- hGetStringBuffer input_fn - ; (_,_,L _ mod_name) <- getImports dflags buf input_fn - ; return (Just buf, mod_name) } + ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn + ; return (Just buf, mod_name, imps, src_imps) } -- Build a ModLocation to pass to hscMain. -- The source filename is rather irrelevant by now, but it's used @@ -738,8 +734,8 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ms_location = location4, ms_hs_date = src_timestamp, ms_obj_date = Nothing, - ms_imps = unused_field, - ms_srcimps = unused_field } + ms_imps = imps, + ms_srcimps = src_imps } -- run the compiler! mbResult <- hscCompileOneShot hsc_env @@ -814,6 +810,7 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc (cmdline_include_paths ++ pkg_include_dirs) let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags + gcc_extra_viac_flags <- getExtraViaCOpts dflags let pic_c_flags = picCCOpts dflags let verb = getVerbFlag dflags @@ -880,6 +877,13 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc ++ (if hcc && mangle then md_regd_c_flags else []) + ++ (if hcc + then if mangle + then gcc_extra_viac_flags + else filter (=="-fwrapv") + gcc_extra_viac_flags + -- still want -fwrapv even for unreg'd + else []) ++ (if hcc then more_hcc_opts else []) @@ -889,10 +893,6 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc ++ split_opt ++ include_paths ++ pkg_extra_cc_opts -#ifdef HAVE_GCC_HAS_WRAPV - -- We need consistent integer overflow (trac #952) - ++ ["-fwrapv"] -#endif )) return (next_phase, dflags, maybe_loc, output_fn) @@ -1052,7 +1052,7 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc -- wrapper script calling the binary. Currently, we need this only in -- a parallel way (i.e. in GUM), because PVM expects the binary in a -- central directory. --- This is called from staticLink below, after linking. I haven't made it +-- This is called from linkBinary below, after linking. I haven't made it -- a separate phase to minimise interfering with other modules, and -- we don't need the generality of a phase (MoveBinary is always -- done after linking and makes only sense in a parallel setup) -- HWL @@ -1106,18 +1106,18 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ "", "args: while ($a = shift(@ARGV)) {", " if ( $a eq '+RTS' ) {", - " $in_RTS_args = 1;", + " $in_RTS_args = 1;", " } elsif ( $a eq '-RTS' ) {", - " $in_RTS_args = 0;", + " $in_RTS_args = 0;", " }", " if ( $a eq '-d' && $in_RTS_args ) {", - " $debug = '-';", + " $debug = '-';", " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {", - " $nprocessors = $1;", + " $nprocessors = $1;", " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {", - " $nprocessors = $1;", + " $nprocessors = $1;", " } else {", - " push(@nonPVM_args, $a);", + " push(@nonPVM_args, $a);", " }", "}", "", @@ -1166,8 +1166,8 @@ getHCFilePackages filename = -- read any interface files), so the user must explicitly specify all -- the packages. -staticLink :: DynFlags -> [FilePath] -> [PackageId] -> IO () -staticLink dflags o_files dep_packages = do +linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary dflags o_files dep_packages = do let verb = getVerbFlag dflags output_fn = exeFileName dflags @@ -1176,7 +1176,9 @@ staticLink dflags o_files dep_packages = do -- dependencies, and eliminating duplicates. pkg_lib_paths <- getPackageLibraryPath dflags dep_packages - let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths + let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) + get_pkg_lib_path_opts l | opt_HardwireLibPaths && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths @@ -1228,6 +1230,8 @@ staticLink dflags o_files dep_packages = do ] | otherwise = [] + rc_objs <- maybeCreateManifest dflags output_fn + let (md_c_flags, _) = machdepCCOpts dflags SysTools.runLink dflags ( [ SysTools.Option verb @@ -1240,6 +1244,7 @@ staticLink dflags o_files dep_packages = do ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts + ++ rc_objs #ifdef darwin_TARGET_OS ++ framework_path_opts ++ framework_opts @@ -1278,16 +1283,65 @@ exeFileName dflags "a.out" #endif ------------------------------------------------------------------------------ --- Making a DLL (only for Win32) +maybeCreateManifest + :: DynFlags + -> FilePath -- filename of executable + -> IO [FilePath] -- extra objects to embed, maybe +maybeCreateManifest dflags exe_filename = do +#ifndef mingw32_TARGET_OS + return [] +#else + if not (dopt Opt_GenManifest dflags) then return [] else do + + let manifest_filename = exe_filename `joinFileExt` "manifest" + + writeFile manifest_filename $ + "\n"++ + " \n"++ + " \n\n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + "\n" + + -- Windows will fine the manifest file if it is named foo.exe.manifest. + -- However, for extra robustness, and so that we can move the binary around, + -- we can embed the manifest in the binary itself using windres: + if not (dopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags "rc" + rc_obj_filename <- newTempName dflags (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n" + -- magic numbers :-) + + let wr_opts = getOpts dflags opt_windres + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + ++ wr_opts + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + return [rc_obj_filename] +#endif -doMkDLL :: DynFlags -> [String] -> [PackageId] -> IO () -doMkDLL dflags o_files dep_packages = do + +linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () +linkDynLib dflags o_files dep_packages = do let verb = getVerbFlag dflags let static = opt_Static let no_hs_main = dopt Opt_NoHsMain dflags let o_file = outputFile dflags - let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths @@ -1300,20 +1354,89 @@ doMkDLL dflags o_files dep_packages = do -- probably _stub.o files extra_ld_inputs <- readIORef v_Ld_inputs - -- opts from -optdll- - let extra_ld_opts = getOpts dflags opt_dll + let (md_c_flags, _) = machdepCCOpts dflags + let extra_ld_opts = getOpts dflags opt_l +#if defined(mingw32_HOST_OS) + ----------------------------------------------------------------------------- + -- Making a DLL + ----------------------------------------------------------------------------- + let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } - let pstate = pkgState dflags - rts_pkg = getPackageDetails pstate rtsPackageId - base_pkg = getPackageDetails pstate basePackageId + SysTools.runLink dflags + ([ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + , SysTools.Option "-Wl,--export-all-symbols" + , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + ] + ++ map (SysTools.FileOption "") o_files + ++ map SysTools.Option ( + md_c_flags + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) +#elif defined(darwin_TARGET_OS) + ----------------------------------------------------------------------------- + -- Making a darwin dylib + ----------------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct dependencies + -- for each of the dylibs. Note that we could (and should) do without this + -- for all libraries except the RTS; all we need to do is to pass the + -- correct HSfoo_dyn.dylib files to the link command. + -- This feature requires Mac OS X 10.3 or later; there is a similar feature, + -- -flat_namespace -undefined suppress, which works on earlier versions, + -- but it has other disadvantages. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no dynamic binding + -- nonsense when referring to symbols from within the library. The NCG + -- assumes that this option is specified (on i386, at least). + -- -Wl,-macosx_version_min -Wl,10.3 + -- Tell the linker its safe to assume that the library will run on 10.3 or + -- 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. + ----------------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + pwd <- getCurrentDirectory + SysTools.runLink dflags + ([ SysTools.Option verb + , SysTools.Option "-dynamiclib" + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ o_files + ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd `joinFileName` output_fn) ] + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) +#else + ----------------------------------------------------------------------------- + -- Making a DSO + ----------------------------------------------------------------------------- - let extra_os = if static || no_hs_main - then [] - else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o", - head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ] + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - let (md_c_flags, _) = machdepCCOpts dflags - SysTools.runMkDLL dflags + SysTools.runLink dflags ([ SysTools.Option verb , SysTools.Option "-o" , SysTools.FileOption "" output_fn @@ -1321,18 +1444,14 @@ doMkDLL dflags o_files dep_packages = do ++ map SysTools.Option ( md_c_flags ++ o_files - ++ extra_os - ++ [ "--target=i386-mingw32" ] + ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts ++ pkg_link_opts - ++ (if "--def" `elem` (concatMap words extra_ld_opts) - then [ "" ] - else [ "--export-all" ]) )) - +#endif -- ----------------------------------------------------------------------------- -- Running CPP @@ -1413,8 +1532,6 @@ hscNextPhase dflags other hsc_lang = hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop HsBootFile current_hsc_lang - = HscNothing -- No output (other than Foo.hi-boot) for hs-boot files hscMaybeAdjustTarget dflags stop other current_hsc_lang = hsc_lang where