X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=22ce8c43245abdd478b3a45117a2bc2f92034404;hb=b17eae42ad936fd88ddcc356ba876e8a0910d46b;hp=4dc287a725f56fd4d0beaef221ce261e60155d14;hpb=4630ac742d08f4ec9a4a6911834f2e5844558754;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 4dc287a..22ce8c4 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- GHC Driver @@ -16,7 +23,7 @@ module DriverPipeline ( -- Interfaces for the compilation manager (interpreted/batch-mode) preprocess, - compile, CompResult(..), + compile, link, ) where @@ -35,7 +42,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 @@ -86,36 +93,25 @@ preprocess dflags (filename, mb_phase) = -- NB. No old interface can also mean that the source has changed. compile :: HscEnv - -> ModSummary - -> Maybe Linkable -- Just linkable <=> source unchanged - -> Maybe ModIface -- Old interface, if available - -> Int -> Int - -> IO CompResult - -data CompResult - = CompOK ModDetails -- New details - ModIface -- New iface - (Maybe Linkable) -- a Maybe, for the same reasons as hm_linkable - - | CompErrs - - -compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do - - let dflags0 = ms_hspp_opts mod_summary - this_mod = ms_mod mod_summary - src_flavour = ms_hsc_src mod_summary + -> ModSummary -- summary for module being compiled + -> Int -> Int -- module N of M + -> Maybe ModIface -- old interface, if we have one + -> Maybe Linkable -- old linkable, if we have one + -> IO (Maybe HomeModInfo) -- the complete HomeModInfo, if successful + +compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable + = do + let dflags0 = ms_hspp_opts summary + this_mod = ms_mod summary + src_flavour = ms_hsc_src summary have_object | Just l <- maybe_old_linkable, isObjectLinkable l = True | otherwise = False - -- FIXME: We need to know whether or not we're recompiling the file. Move this to HscMain? - --showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary) - - let location = ms_location mod_summary + let location = ms_location summary let input_fn = expectJust "compile:hs" (ml_hs_file location) - let input_fnpp = ms_hspp_file mod_summary + let input_fnpp = ms_hspp_file summary debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) @@ -151,20 +147,23 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do = do stub_o <- compileStub dflags' this_mod location return [ DotO stub_o ] - handleBatch (HscNoRecomp, iface, details) + handleBatch HscNoRecomp = ASSERT (isJust maybe_old_linkable) - return (CompOK details iface maybe_old_linkable) - handleBatch (HscRecomp hasStub, iface, details) + return maybe_old_linkable + + handleBatch (HscRecomp hasStub) | isHsBoot src_flavour - = do SysTools.touch dflags' "Touching object file" + = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too + SysTools.touch dflags' "Touching object file" object_filename - return (CompOK details iface Nothing) + return maybe_old_linkable + | otherwise = do stub_unlinked <- getStubLinkable hasStub (hs_unlinked, unlinked_time) <- case hsc_lang of HscNothing - -> return ([], ms_hs_date mod_summary) + -> return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. _other -> do runPipeline StopLn dflags (output_fn,Nothing) @@ -176,15 +175,15 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do return ([DotO object_filename], o_time) let linkable = LM unlinked_time this_mod (hs_unlinked ++ stub_unlinked) - return (CompOK details iface (Just linkable)) + return (Just linkable) - handleInterpreted (InteractiveNoRecomp, iface, details) + handleInterpreted InteractiveNoRecomp = ASSERT (isJust maybe_old_linkable) - return (CompOK details iface maybe_old_linkable) - handleInterpreted (InteractiveRecomp hasStub comp_bc, iface, details) + return maybe_old_linkable + handleInterpreted (InteractiveRecomp hasStub comp_bc modBreaks) = do stub_unlinked <- getStubLinkable hasStub - let hs_unlinked = [BCOs comp_bc] - unlinked_time = ms_hs_date mod_summary + let hs_unlinked = [BCOs comp_bc modBreaks] + unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, -- rather than the current time? This works better in -- the case where the local clock is out of sync @@ -193,24 +192,31 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do -- be out of date. let linkable = LM unlinked_time this_mod (hs_unlinked ++ stub_unlinked) - return (CompOK details iface (Just linkable)) + return (Just linkable) - let runCompiler compiler handle - = do mbResult <- compiler hsc_env' mod_summary - source_unchanged old_iface + let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) + -- -> IO (Maybe HomeModInfo) + runCompiler compiler handle + = do mbResult <- compiler hsc_env' summary source_unchanged mb_old_iface (Just (mod_index, nmods)) case mbResult of - Nothing -> return CompErrs - Just result -> handle result + Nothing -> return Nothing + Just (result, iface, details) -> do + linkable <- handle result + return (Just HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = linkable }) -- run the compiler case hsc_lang of - HscInterpreted | not (isHsBoot src_flavour) -- We can't compile boot files to - -- bytecode so don't even try. - -> runCompiler hscCompileInteractive handleInterpreted - HscNothing - -> runCompiler hscCompileNothing handleBatch - _other - -> runCompiler hscCompileBatch handleBatch + HscInterpreted + | isHsBoot src_flavour -> + runCompiler hscCompileNothing handleBatch + | otherwise -> + runCompiler hscCompileInteractive handleInterpreted + HscNothing -> + runCompiler hscCompileNothing handleBatch + _other -> + runCompiler hscCompileBatch handleBatch ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -247,10 +253,10 @@ compileStub dflags mod location = do -- --------------------------------------------------------------------------- -- Link -link :: GhcLink -- interactive or batch - -> DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link +link :: GhcLink -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link -> IO SuccessFlag -- For the moment, in the batch linker, we don't bother to tell doLink @@ -263,7 +269,7 @@ link :: GhcLink -- interactive or batch #ifdef GHCI link LinkInMemory dflags batch_attempt_linking hpt = do -- Not Linking...(demand linker will do the job) - return Succeeded + return Succeeded #endif link NoLink dflags batch_attempt_linking hpt @@ -271,62 +277,64 @@ link NoLink dflags batch_attempt_linking hpt link LinkBinary dflags batch_attempt_linking hpt | batch_attempt_linking - = do - let - home_mod_infos = eltsUFM hpt + = do + let + home_mod_infos = eltsUFM hpt - -- the packages we depend on - pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos + -- the packages we depend on + pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos - -- the linkables to link - linkables = map (expectJust "link".hm_linkable) home_mod_infos + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) - -- check for the -no-link flag - if isNoLink (ghcLink dflags) - then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") - return Succeeded - else do - - let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables - - exe_file = exeFileName dflags - - -- if the modification time on the executable is later than the - -- modification times on all of the objects, then omit linking - -- (unless the -no-recomp flag was given). - e_exe_time <- IO.try $ getModificationTime exe_file - let linking_needed - | Left _ <- e_exe_time = True - | Right t <- e_exe_time = - any (t <) (map linkableTime linkables) - - if not (dopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg dflags 2 (text exe_file <+> ptext SLIT("is up to date, linking not required.")) - return Succeeded - else do - - debugTraceMsg dflags 1 (ptext SLIT("Linking") <+> text exe_file - <+> text "...") - - -- Don't showPass in Batch mode; doLink will do that for us. - let link = case ghcLink dflags of - LinkBinary -> linkBinary - LinkDynLib -> linkDynLib - link dflags obj_files pkg_deps + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + exe_file = exeFileName dflags + + -- if the modification time on the executable is later than the + -- modification times on all of the objects, then omit linking + -- (unless the -no-recomp flag was given). + e_exe_time <- IO.try $ getModificationTime exe_file + extra_ld_inputs <- readIORef v_Ld_inputs + extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs + let other_times = map linkableTime linkables + ++ [ t' | Right t' <- extra_times ] + linking_needed + | Left _ <- e_exe_time = True + | Right t <- e_exe_time = any (t <) other_times + + if not (dopt Opt_ForceRecomp dflags) && not linking_needed + then do debugTraceMsg dflags 2 (text exe_file <+> ptext SLIT("is up to date, linking not required.")) + return Succeeded + else do + + debugTraceMsg dflags 1 (ptext SLIT("Linking") <+> text exe_file + <+> text "...") + + -- Don't showPass in Batch mode; doLink will do that for us. + let link = case ghcLink dflags of + LinkBinary -> linkBinary + LinkDynLib -> linkDynLib + link dflags obj_files pkg_deps debugTraceMsg dflags 3 (text "link: done") - -- linkBinary only returns if it succeeds + -- linkBinary only returns if it succeeds return Succeeded | otherwise = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ text " Main.main not exported; not linking.") return Succeeded - -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. @@ -413,12 +421,16 @@ runPipeline -> 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) mb_basename output maybe_loc +runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc = do - let (input_basename, suffix) = splitFilename input_fn + let + (input_basename, suffix) = splitFilename input_fn basename | Just b <- mb_basename = b | otherwise = input_basename + -- Decide where dump files should go based on the pipeline output + dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + -- If we were given a -x flag, then use that phase to start from start_phase = fromMaybe (startPhase suffix) mb_phase @@ -640,15 +652,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 (basename `joinFileExt` suff) + ; 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 @@ -735,8 +747,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 @@ -811,6 +823,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 @@ -877,6 +890,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 []) @@ -886,10 +906,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) @@ -1173,7 +1189,9 @@ linkBinary 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 @@ -1225,6 +1243,8 @@ linkBinary 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 @@ -1237,6 +1257,7 @@ linkBinary 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 @@ -1275,6 +1296,61 @@ exeFileName dflags "a.out" #endif +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 " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to esacpe the + -- backslashes in the path. + + 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 + + linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () linkDynLib dflags o_files dep_packages = do let verb = getVerbFlag dflags @@ -1294,49 +1370,84 @@ linkDynLib dflags o_files dep_packages = do extra_ld_inputs <- readIORef v_Ld_inputs 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"; } - -- opts from -optdll- - let extra_ld_opts = getOpts dflags opt_dll + SysTools.runLink dflags + ([ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + , 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 pstate = pkgState dflags - rts_pkg = getPackageDetails pstate rtsPackageId - base_pkg = getPackageDetails pstate basePackageId + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - let extra_os = if static || no_hs_main - then [] - else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o", - head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ] - SysTools.runMkDLL dflags + 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 - ++ extra_os - ++ [ "--target=i386-mingw32" ] + ++ [ "-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 - ++ (if "--def" `elem` (concatMap words extra_ld_opts) - 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