X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=c0ea4fc58688e9154c316772718c69dfa758c705;hb=f8c52d7fde2d7408b4f734251c373f8d3e2c558e;hp=e414f4cb3d61e40652207882c98dd60de27fe0f8;hpb=efae1c61f1a22ea5aec32a9f29ee9d594d8a4ea0;p=ghc-hetmet.git diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index e414f4c..c0ea4fc 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. @@ -156,7 +163,8 @@ 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 - = 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) | otherwise @@ -181,9 +189,9 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do handleInterpreted (InteractiveNoRecomp, iface, details) = ASSERT (isJust maybe_old_linkable) return (CompOK details iface maybe_old_linkable) - handleInterpreted (InteractiveRecomp hasStub comp_bc, iface, details) + handleInterpreted (InteractiveRecomp hasStub comp_bc modBreaks, iface, details) = do stub_unlinked <- getStubLinkable hasStub - let hs_unlinked = [BCOs comp_bc] + let hs_unlinked = [BCOs comp_bc modBreaks] unlinked_time = ms_hs_date mod_summary -- Why do we use the timestamp of the source file here, -- rather than the current time? This works better in @@ -204,13 +212,11 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do Just result -> handle result -- 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 @@ -811,6 +820,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 +887,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 +903,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) @@ -1227,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 @@ -1239,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 @@ -1277,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