X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=845f909994e04d266767db025f6c4bfca7f9659a;hb=4fb923d8cc248d02ff9f688e46453428c68633aa;hp=cf6bff18eef2321a61a693a8ff6bf19fdca2dc68;hpb=2ebe8addfaae2bc65e6b87ad369928b02053014f;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index cf6bff1..845f909 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -6,6 +6,13 @@ -- ----------------------------------------------------------------------------- +{-# 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 + module DriverPipeline ( -- Run a series of compilation steps in a pipeline, for a -- collection of source files. @@ -16,7 +23,7 @@ module DriverPipeline ( -- Interfaces for the compilation manager (interpreted/batch-mode) preprocess, - compile, CompResult(..), + compile, link, ) where @@ -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) @@ -327,7 +333,6 @@ link LinkBinary dflags batch_attempt_linking hpt text " Main.main not exported; not linking.") return Succeeded - -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. @@ -413,12 +418,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 @@ -647,7 +656,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ; return (Nothing, mkModuleName m, [], []) } other -> do { buf <- hGetStringBuffer input_fn - ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn + ; (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. @@ -1231,6 +1240,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 @@ -1243,6 +1254,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 @@ -1281,6 +1293,59 @@ 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 \"" ++ 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 + + linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () linkDynLib dflags o_files dep_packages = do let verb = getVerbFlag dflags @@ -1312,7 +1377,6 @@ linkDynLib dflags o_files dep_packages = do , 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