Commit eb4352ab authored by Simon Marlow's avatar Simon Marlow

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.
parent 2ebe8add
......@@ -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
......
......@@ -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]
......
......@@ -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]
......
......@@ -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/
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment