X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=e9fb307dbb558552b9eac99314a8f148b549d429;hb=de21f53e25eb67248ba416187d34ba7ec9ec143a;hp=1ee2924f33cf4092519c11ea96621298fced5a15;hpb=cf411c9ae5d61d6e5baa5e5e6b0ad9803b041236;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 1ee2924..e9fb307 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 -- --------------------------------------------------------------------------- @@ -75,7 +70,8 @@ import System.Environment preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath) preprocess dflags (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - runPipeline anyHsc dflags (filename, mb_phase) Temporary Nothing{-no ModLocation-} + runPipeline anyHsc dflags (filename, mb_phase) + Nothing Temporary Nothing{-no ModLocation-} -- --------------------------------------------------------------------------- -- Compile @@ -160,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) <- @@ -169,7 +167,9 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do -> return ([], ms_hs_date mod_summary) -- We're in --make mode: finish the compilation pipeline. _other - -> do runPipeline StopLn dflags (output_fn,Nothing) Persistent + -> do runPipeline StopLn dflags (output_fn,Nothing) + (Just basename) + Persistent (Just location) -- The object filename comes from the ModLocation o_time <- getModificationTime object_filename @@ -238,7 +238,7 @@ compileStub dflags mod location = do -- compile the _stub.c file w/ gcc let (stub_c,_) = mkStubPaths dflags (moduleName mod) location - runPipeline StopLn dflags (stub_c,Nothing) + runPipeline StopLn dflags (stub_c,Nothing) Nothing (SpecificFile stub_o) Nothing{-no ModLocation-} return stub_o @@ -247,7 +247,7 @@ compileStub dflags mod location = do -- --------------------------------------------------------------------------- -- Link -link :: GhcMode -- interactive or batch +link :: GhcLink -- interactive or batch -> DynFlags -- dynamic flags -> Bool -- attempt linking in batch mode? -> HomePackageTable -- what to link @@ -261,15 +261,15 @@ link :: GhcMode -- interactive or batch -- will succeed. #ifdef GHCI -link Interactive dflags batch_attempt_linking hpt +link LinkInMemory dflags batch_attempt_linking hpt = do -- Not Linking...(demand linker will do the job) return Succeeded #endif -link JustTypecheck dflags batch_attempt_linking hpt +link NoLink dflags batch_attempt_linking hpt = return Succeeded -link BatchCompile dflags batch_attempt_linking hpt +link LinkBinary dflags batch_attempt_linking hpt | batch_attempt_linking = do let @@ -313,13 +313,13 @@ link BatchCompile 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 - StaticLink -> 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 @@ -361,7 +361,8 @@ compileFile dflags stop_phase (src, mb_phase) = do other -> stop_phase (_, out_file) <- runPipeline stop_phase' dflags - (src, mb_phase) output Nothing{-no ModLocation-} + (src, mb_phase) Nothing output + Nothing{-no ModLocation-} return out_file @@ -373,8 +374,8 @@ doLink dflags stop_phase o_files | otherwise = case ghcLink dflags of NoLink -> return () - StaticLink -> 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. @@ -407,13 +408,16 @@ runPipeline :: Phase -- When to stop -> DynFlags -- Dynamic flags -> (FilePath,Maybe Phase) -- Input filename (and maybe -x suffix) + -> Maybe FilePath -- original basename (if different from ^^^) -> PipelineOutput -- Output filename -> Maybe ModLocation -- A ModLocation, if this is a Haskell module -> IO (DynFlags, FilePath) -- (final flags, output filename) -runPipeline stop_phase dflags (input_fn, mb_phase) output maybe_loc +runPipeline stop_phase dflags (input_fn, mb_phase) mb_basename output maybe_loc = do - let (basename, suffix) = splitFilename input_fn + let (input_basename, suffix) = splitFilename input_fn + basename | Just b <- mb_basename = b + | otherwise = input_basename -- If we were given a -x flag, then use that phase to start from start_phase = fromMaybe (startPhase suffix) mb_phase @@ -636,15 +640,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 @@ -731,8 +735,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 @@ -1045,7 +1049,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 @@ -1059,9 +1063,9 @@ runPhase_MoveBinary dflags input_fn 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? - system ("rm -f " ++ pvm_executable) + Panic.try (removeFile pvm_executable) -- move the newly created binary into PVM land - system ("cp -p " ++ input_fn ++ " " ++ pvm_executable) + copy dflags "copying PVM executable" input_fn pvm_executable -- 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 @@ -1099,18 +1103,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);", " }", "}", "", @@ -1159,8 +1163,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 @@ -1169,7 +1173,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 @@ -1271,16 +1277,12 @@ exeFileName dflags "a.out" #endif ------------------------------------------------------------------------------ --- Making a DLL (only for Win32) - -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 @@ -1293,7 +1295,15 @@ doMkDLL dflags o_files dep_packages = do -- probably _stub.o files extra_ld_inputs <- readIORef v_Ld_inputs - -- opts from -optdll- + let (md_c_flags, _) = machdepCCOpts dflags +#if defined(mingw32_HOST_OS) + ----------------------------------------------------------------------------- + -- Making a DLL + ----------------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } + + -- opts from -optdll- let extra_ld_opts = getOpts dflags opt_dll let pstate = pkgState dflags @@ -1304,8 +1314,6 @@ doMkDLL dflags o_files dep_packages = do then [] else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o", head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ] - - let (md_c_flags, _) = machdepCCOpts dflags SysTools.runMkDLL dflags ([ SysTools.Option verb , SysTools.Option "-o" @@ -1325,7 +1333,30 @@ doMkDLL dflags o_files dep_packages = do then [ "" ] else [ "--export-all" ]) )) - +#else + ----------------------------------------------------------------------------- + -- Making a DSO + ----------------------------------------------------------------------------- + -- opts from -optl- + let extra_ld_opts = getOpts dflags opt_l + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + SysTools.runLink dflags + ([ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ o_files + ++ [ "-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 + )) +#endif -- ----------------------------------------------------------------------------- -- Running CPP @@ -1406,8 +1437,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