FIX #1271: create manifests, and embed them in executables on Windows

We have 4 new flags:

  -fno-gen-manifest
     suppresses creation of foo.exe.manifest

  -fno-embed-manifest
     suppresses embedding of the manifest in the executable

  -pgmwindres
     specify a program to use instead of windres

  -optwindres
     extra options to pass to windres

"windres" is now copied from mingw and included in a binary
distribution.

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index cf6bff1..4f19cfa 100644 (file)
--- 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.
 
@@ -1231,6 +1230,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 +1244,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 +1283,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

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1721b4c..10924bd 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -253,6 +253,8 @@ data DynFlag
    | Opt_Haddock
    | Opt_Hpc_No_Auto
    | Opt_BreakOnException
+   | Opt_GenManifest
+   | Opt_EmbedManifest
 
    -- keeping stuff
    | Opt_KeepHiDiffs
@@ -324,6 +326,7 @@ data DynFlags = DynFlags {
   opt_a                        :: [String],
   opt_l                        :: [String],
   opt_dep              :: [String],
+  opt_windres          :: [String],
 
   -- commands for particular phases
   pgm_L                        :: String,
@@ -337,6 +340,7 @@ data DynFlags = DynFlags {
   pgm_dll              :: (String,[Option]),
   pgm_T                 :: String,
   pgm_sysman            :: String,
+  pgm_windres           :: String,
 
   --  Package flags
   extraPkgConfs                :: [FilePath],
@@ -479,6 +483,7 @@ defaultDynFlags =
        opt_m                   = [],
        opt_l                   = [],
        opt_dep                 = [],
+        opt_windres             = [],
        
        extraPkgConfs           = [],
        packageFlags            = [],
@@ -496,6 +501,9 @@ defaultDynFlags =
 
            Opt_DoAsmMangling,
     
+            Opt_GenManifest,
+            Opt_EmbedManifest,
+
            -- on by default:
            Opt_PrintBindResult ]
            ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
@@ -561,6 +569,7 @@ setPgms   f d = d{ pgm_s   = (f,[])}
 setPgma   f d = d{ pgm_a   = (f,[])}
 setPgml   f d = d{ pgm_l   = (f,[])}
 setPgmdll f d = d{ pgm_dll = (f,[])}
+setPgmwindres f d = d{ pgm_windres = f}
 
 addOptL   f d = d{ opt_L   = f : opt_L d}
 addOptP   f d = d{ opt_P   = f : opt_P d}
@@ -570,6 +579,7 @@ addOptm   f d = d{ opt_m   = f : opt_m d}
 addOpta   f d = d{ opt_a   = f : opt_a d}
 addOptl   f d = d{ opt_l   = f : opt_l d}
 addOptdep f d = d{ opt_dep = f : opt_dep d}
+addOptwindres f d = d{ opt_windres = f : opt_windres d}
 
 addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d}
 
@@ -910,6 +920,7 @@ dynamic_flags = [
   ,  ( "pgma"           , HasArg (upd . setPgma) )  
   ,  ( "pgml"           , HasArg (upd . setPgml) )  
   ,  ( "pgmdll"                , HasArg (upd . setPgmdll) )
+  ,  ( "pgmwindres"     , HasArg (upd . setPgmwindres) )
 
   ,  ( "optL"          , HasArg (upd . addOptL) )  
   ,  ( "optP"          , HasArg (upd . addOptP) )  
@@ -919,6 +930,7 @@ dynamic_flags = [
   ,  ( "opta"          , HasArg (upd . addOpta) )  
   ,  ( "optl"          , HasArg (upd . addOptl) )  
   ,  ( "optdep"                , HasArg (upd . addOptdep) )
+  ,  ( "optwindres"     , HasArg (upd . addOptwindres) )
 
   ,  ( "split-objs"    , NoArg (if can_split
                                    then setDynFlag Opt_SplitObjs
@@ -1180,7 +1192,9 @@ fFlags = [
   -- Deprecated in favour of -XUndecidableInstances:
   ( "allow-undecidable-instances",      Opt_UndecidableInstances ),
   -- Deprecated in favour of -XIncoherentInstances:
-  ( "allow-incoherent-instances",       Opt_IncoherentInstances )
+  ( "allow-incoherent-instances",       Opt_IncoherentInstances ),
+  ( "gen-manifest",                     Opt_GenManifest ),
+  ( "embed-manifest",                   Opt_EmbedManifest )
   ]
 
 supportedLanguages :: [String]

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index e098dd9..7a2c081 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -17,6 +17,7 @@ module SysTools (
        runMangle, runSplit,     -- [Option] -> IO ()
        runAs, runLink,          -- [Option] -> IO ()
        runMkDLL,
+        runWindres,
 
        touch,                  -- String -> String -> IO ()
        copy,
@@ -196,6 +197,10 @@ initSysTools mbMinusB dflags
                | am_installed = installed_bin cGHC_MANGLER_PGM
                | otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
 
+              windres_path
+               | am_installed = installed_bin "windres"
+               | otherwise    = "windres"
+
        ; let dflags0 = defaultDynFlags
 #ifndef mingw32_HOST_OS
        -- check whether TMPDIR is set in the environment
@@ -326,7 +331,8 @@ initSysTools mbMinusB dflags
                        pgm_l   = (ld_prog,ld_args),
                        pgm_dll = (mkdll_prog,mkdll_args),
                         pgm_T   = touch_path,
-                        pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
+                        pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
+                        pgm_windres = windres_path
                        -- Hans: this isn't right in general, but you can 
                        -- elaborate it in the same way as the others
                 }
@@ -518,6 +524,16 @@ runMkDLL dflags args = do
   mb_env <- getGccEnv (args0++args)
   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
 
+runWindres :: DynFlags -> [Option] -> IO ()
+runWindres dflags args = do
+  let (gcc,gcc_args) = pgm_c dflags
+      windres        = pgm_windres dflags
+  runSomething dflags "Windres" windres 
+        (Option ("--preprocessor=" ++ gcc ++ unwords (map showOpt gcc_args) ++
+                 " -E -xc -DRC_INVOKED")
+         : args)
+        -- we must tell windres where to find gcc: it might not be on PATH
+
 touch :: DynFlags -> String -> String -> IO ()
 touch dflags purpose arg =
   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]

diff --git a/distrib/prep-bin-dist-mingw b/distrib/prep-bin-dist-mingw
index 45c9743..55411e5 100644 (file)
--- a/distrib/prep-bin-dist-mingw
+++ b/distrib/prep-bin-dist-mingw
@@ -144,6 +144,7 @@ cp $mingw_lib/* gcc-lib/
 cp $mingw_bin/as.exe gcc-lib/
 cp $mingw_bin/ld.exe gcc-lib/
 cp $mingw_bin/ar.exe bin/
+cp $mingw_bin/windres.exe bin/
 # Note: later versions of dlltool.exe depend on a bfd helper DLL.
 cp $mingw_bin/dllwrap.exe gcc-lib/
 cp $mingw_bin/dlltool.exe gcc-lib/