From eb4352ab0675309fe6cb1ad38cf070340a338e50 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 10 Aug 2007 08:47:53 +0000 Subject: [PATCH] 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. --- compiler/main/DriverPipeline.hs | 57 ++++++++++++++++++++++++++++++++++++++- compiler/main/DynFlags.hs | 16 ++++++++++- compiler/main/SysTools.lhs | 18 ++++++++++++- distrib/prep-bin-dist-mingw | 1 + 4 files changed, 89 insertions(+), 3 deletions(-) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index cf6bff1..4f19cfa 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. @@ -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 $ + "\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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1721b4c..10924bd 100644 --- 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 --- 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 --- 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/ -- 1.7.10.4