X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=67fe31d4068d6cca00631ca0db9306fb288d7f18;hb=e2390e76b2f1f2beecd9a0d308c4890a56ae8bca;hp=e414f4cb3d61e40652207882c98dd60de27fe0f8;hpb=efae1c61f1a22ea5aec32a9f29ee9d594d8a4ea0;p=ghc-hetmet.git

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index e414f4c..67fe31d 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -327,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.
 
@@ -413,12 +412,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 +814,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 +881,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 +897,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 +1234,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 +1248,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 +1287,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 $ 
+      "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
+      "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
+      "  <assemblyIdentity version=\"1.0.0.0\"\n"++
+      "     processorArchitecture=\"X86\"\n"++
+      "     name=\"" ++ basenameOf exe_filename ++ "\"\n"++
+      "     type=\"win32\"/>\n\n"++
+      "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
+      "    <security>\n"++
+      "      <requestedPrivileges>\n"++
+      "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
+      "        </requestedPrivileges>\n"++
+      "       </security>\n"++
+      "  </trustInfo>\n"++
+      "</assembly>\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