Don't use stdcall on Win64: It isn't supported; ccall is used instead
[ghc.git] / compiler / main / SysTools.lhs
index 3937aa4..848e02d 100644 (file)
@@ -7,9 +7,7 @@
 -----------------------------------------------------------------------------
 
 \begin{code}
-{-# OPTIONS -fno-cse #-}
--- -fno-cse is needed for GLOBAL_VAR's to behave properly
-
+{-# OPTIONS -fno-warn-unused-do-bind #-}
 module SysTools (
         -- Initialisation
         initSysTools,
@@ -17,15 +15,21 @@ module SysTools (
         -- Interface to system tools
         runUnlit, runCpp, runCc, -- [Option] -> IO ()
         runPp,                   -- [Option] -> IO ()
-        runMangle, runSplit,     -- [Option] -> IO ()
+        runSplit,                -- [Option] -> IO ()
         runAs, runLink,          -- [Option] -> IO ()
         runMkDLL,
         runWindres,
+        runLlvmOpt,
+        runLlvmLlc,
+        runClang,
+        figureLlvmVersion,
+        readElfSection,
+
+        askCc,
 
         touch,                  -- String -> String -> IO ()
         copy,
         copyWithHeader,
-        getExtraViaCOpts,
 
         -- Temporary-file management
         setTmpDir,
@@ -44,11 +48,12 @@ import Config
 import Outputable
 import ErrUtils
 import Panic
+import Platform
 import Util
 import DynFlags
-import FiniteMap
+import StaticFlags
+import Exception
 
-import Control.Exception
 import Data.IORef
 import Control.Monad
 import System.Exit
@@ -58,40 +63,54 @@ import System.IO
 import System.IO.Error as IO
 import System.Directory
 import Data.Char
-import Data.Maybe
 import Data.List
+import qualified Data.Map as Map
+import Text.ParserCombinators.ReadP hiding (char)
+import qualified Text.ParserCombinators.ReadP as R
 
 #ifndef mingw32_HOST_OS
 import qualified System.Posix.Internals
 #else /* Must be Win32 */
 import Foreign
-import CString          ( CString, peekCString )
+import Foreign.C.String
 #endif
 
-import System.Process   ( runInteractiveProcess, getProcessExitCode )
+import System.Process
 import Control.Concurrent
 import FastString
 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
+
+#ifdef mingw32_HOST_OS
+# if defined(i386_HOST_ARCH)
+#  define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+#  define WINDOWS_CCONV ccall
+# else
+#  error Unknown mingw32 arch
+# endif
+#endif
 \end{code}
 
+How GHC finds its files
+~~~~~~~~~~~~~~~~~~~~~~~
 
-                The configuration story
-                ~~~~~~~~~~~~~~~~~~~~~~~
+[Note topdir]
 
 GHC needs various support files (library packages, RTS etc), plus
-various auxiliary programs (cp, gcc, etc).  It finds these in one
-of two places:
+various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
+the root of GHC's support files
 
-* When running as an *installed program*, GHC finds most of this support
-  stuff in the installed library tree.  The path to this tree is passed
-  to GHC via the -B flag, and given to initSysTools .
+On Unix:
+  - ghc always has a shell wrapper that passes a -B<dir> option
 
-* When running *in-place* in a build tree, GHC finds most of this support
-  stuff in the build tree.  The path to the build tree is, again passed
-  to GHC via -B.
+On Windows:
+  - ghc never has a shell wrapper.
+  - we can find the location of the ghc binary, which is
+        $topdir/bin/<something>.exe
+    where <something> may be "ghc", "ghc-stage2", or similar
+  - we strip off the "bin/<something>.exe" to leave $topdir.
 
-GHC tells which of the two is the case by seeing whether package.conf
-is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
+from topdir we can find package.conf, ghc-asm, etc.
 
 
 SysTools.initSysProgs figures out exactly where all the auxiliary programs
@@ -107,8 +126,8 @@ Config.hs contains two sorts of things
   etc           They do *not* include paths
 
 
-  cUNLIT_DIR_REL   The *path* to the directory containing unlit, split etc
-  cSPLIT_DIR_REL   *relative* to the root of the build tree,
+  cUNLIT_DIR   The *path* to the directory containing unlit, split etc
+  cSPLIT_DIR   *relative* to the root of the build tree,
                    for use when running *in-place* in a build tree (only)
 
 
@@ -144,108 +163,79 @@ stuff.
 
 \begin{code}
 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
-
-             -> DynFlags
-             -> IO DynFlags     -- Set all the mutable variables above, holding
+             -> IO Settings     -- Set all the mutable variables above, holding
                                 --      (a) the system programs
                                 --      (b) the package-config file
                                 --      (c) the GHC usage message
-
-
-initSysTools mbMinusB dflags0
-  = do  { (am_installed, top_dir) <- findTopDir mbMinusB
-                -- top_dir
-                --      for "installed" this is the root of GHC's support files
-                --      for "in-place" it is the root of the build tree
+initSysTools mbMinusB
+  = do  { top_dir <- findTopDir mbMinusB
+                -- see [Note topdir]
                 -- NB: top_dir is assumed to be in standard Unix
                 -- format, '/' separated
 
-        ; let installed, installed_bin :: FilePath -> FilePath
-              installed_bin pgm  = top_dir </> pgm
-              installed     file = top_dir </> file
-              real_top_dir
-               | isWindowsHost = top_dir </> ".." </> ".."
-               | otherwise     = top_dir </> ".."
-              inplace dir   pgm  = real_top_dir </> dir </> pgm
-
-        ; let pkgconfig_path
-                | am_installed = installed "package.conf"
-                | otherwise    = inplace "inplace-datadir" "package.conf"
-
-              ghc_usage_msg_path
-                | am_installed = installed "ghc-usage.txt"
-                | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
+        ; let settingsFile = top_dir </> "settings"
+              installed :: FilePath -> FilePath
+              installed file = top_dir </> file
 
-              ghci_usage_msg_path
-                | am_installed = installed "ghci-usage.txt"
-                | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
+        ; settingsStr <- readFile settingsFile
+        ; mySettings <- case maybeReadFuzzy settingsStr of
+                        Just s ->
+                            return s
+                        Nothing ->
+                            pgmError ("Can't parse " ++ show settingsFile)
+        ; let getSetting key = case lookup key mySettings of
+                               Just xs ->
+                                   return $ case stripPrefix "$topdir" xs of
+                                            Just [] ->
+                                                top_dir
+                                            Just xs'@(c:_)
+                                             | isPathSeparator c ->
+                                                top_dir ++ xs'
+                                            _ ->
+                                                xs
+                               Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+              readSetting key = case lookup key mySettings of
+                                Just xs ->
+                                    case maybeRead xs of
+                                    Just v -> return v
+                                    Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
+                                Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+        ; targetArch <- readSetting "target arch"
+        ; targetOS <- readSetting "target os"
+        ; targetWordSize <- readSetting "target word size"
+        ; targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
+        ; targetHasIdentDirective <- readSetting "target has .ident directive"
+        ; targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
+        ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
+        -- On Windows, mingw is distributed with GHC,
+        -- so we look in TopDir/../mingw/bin
+        -- It would perhaps be nice to be able to override this
+        -- with the settings file, but it would be a little fiddly
+        -- to make that possible, so for now you can't.
+        ; gcc_prog <- getSetting "C compiler command"
+        ; gcc_args_str <- getSetting "C compiler flags"
+        ; let gcc_args = map Option (words gcc_args_str)
+        ; perl_path <- getSetting "perl command"
+
+        ; let pkgconfig_path = installed "package.conf.d"
+              ghc_usage_msg_path  = installed "ghc-usage.txt"
+              ghci_usage_msg_path = installed "ghci-usage.txt"
 
                 -- For all systems, unlit, split, mangle are GHC utilities
                 -- architecture-specific stuff is done when building Config.hs
-              unlit_path
-                | am_installed = installed_bin cGHC_UNLIT_PGM
-                | otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
-
-                -- split and mangle are Perl scripts
-              split_script
-                | am_installed = installed_bin cGHC_SPLIT_PGM
-                | otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
+              unlit_path = installed cGHC_UNLIT_PGM
 
-              mangle_script
-                | am_installed = installed_bin cGHC_MANGLER_PGM
-                | otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
+                -- split is a Perl script
+              split_script  = installed cGHC_SPLIT_PGM
 
-              windres_path
-                | am_installed = installed_bin "bin/windres"
-                | otherwise    = "windres"
+        ; windres_path <- getSetting "windres command"
 
         ; tmpdir <- getTemporaryDirectory
-        ; let dflags1 = setTmpDir tmpdir dflags0
-
-        -- Check that the package config exists
-        ; config_exists <- doesFileExist pkgconfig_path
-        ; when (not config_exists) $
-             throwDyn (InstallationError
-                         ("Can't find package.conf as " ++ pkgconfig_path))
-
-        -- On Windows, gcc and friends are distributed with GHC,
-        --      so when "installed" we look in TopDir/bin
-        -- When "in-place", or when not on Windows, we look wherever
-        --      the build-time configure script found them
-        ; let
-              -- The trailing "/" is absolutely essential; gcc seems
-              -- to construct file names simply by concatenating to
-              -- this -B path with no extra slash We use "/" rather
-              -- than "\\" because otherwise "\\\" is mangled
-              -- later on; although gcc_args are in NATIVE format,
-              -- gcc can cope
-              --      (see comments with declarations of global variables)
-              gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
-              (gcc_prog,gcc_args)
-                | isWindowsHost && am_installed
-                    -- We tell gcc where its specs file + exes are (-B)
-                    -- and also some places to pick up include files.  We need
-                    -- to be careful to put all necessary exes in the -B place
-                    -- (as, ld, cc1, etc) since if they don't get found there,
-                    -- gcc then tries to run unadorned "as", "ld", etc, and
-                    -- will pick up whatever happens to be lying around in
-                    -- the path, possibly including those from a cygwin
-                    -- install on the target, which is exactly what we're
-                    -- trying to avoid.
-                    = (installed_bin "gcc", [gcc_b_arg])
-                | otherwise = (cGCC, [])
-              perl_path
-                | isWindowsHost && am_installed = installed_bin cGHC_PERL
-                | otherwise = cGHC_PERL
-              -- 'touch' is a GHC util for Windows
-              touch_path
-                | isWindowsHost
-                    = if am_installed
-                      then installed_bin cGHC_TOUCHY_PGM
-                      else inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
-                | otherwise = "touch"
-              -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
-              -- a call to Perl to get the invocation of split and mangle.
+
+        ; touch_path <- getSetting "touch command"
+
+        ; let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
+              -- a call to Perl to get the invocation of split.
               -- On Unix, scripts are invoked using the '#!' method.  Binary
               -- installations of GHC on Unix place the correct line on the
               -- front of the script at installation time, so we don't want
@@ -253,97 +243,86 @@ initSysTools mbMinusB dflags0
               (split_prog,  split_args)
                 | isWindowsHost = (perl_path,    [Option split_script])
                 | otherwise     = (split_script, [])
-              (mangle_prog, mangle_args)
-                | isWindowsHost = (perl_path,   [Option mangle_script])
-                | otherwise     = (mangle_script, [])
-              (mkdll_prog, mkdll_args)
-                | not isWindowsHost
-                    = panic "Can't build DLLs on a non-Win32 system"
-                | am_installed =
-                    (installed "gcc-lib/" </> cMKDLL,
-                     [ Option "--dlltool-name",
-                       Option (installed "gcc-lib/" </> "dlltool"),
-                       Option "--driver-name",
-                       Option gcc_prog, gcc_b_arg ])
-                | otherwise    = (cMKDLL, [])
+        ; mkdll_prog <- getSetting "dllwrap command"
+        ; let mkdll_args = []
 
         -- cpp is derived from gcc on all platforms
         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
         -- Config.hs one day.
-        ; let cpp_path  = (gcc_prog, gcc_args ++
-                           (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
+        ; let cpp_prog  = gcc_prog
+              cpp_args  = Option "-E"
+                        : map Option (words cRAWCPP_FLAGS)
+                       ++ gcc_args
 
         -- Other things being equal, as and ld are simply gcc
-        ; let   (as_prog,as_args)  = (gcc_prog,gcc_args)
-                (ld_prog,ld_args)  = (gcc_prog,gcc_args)
-
-        ; return dflags1{
-                        ghcUsagePath = ghc_usage_msg_path,
-                        ghciUsagePath = ghci_usage_msg_path,
-                        topDir  = top_dir,
-                        systemPackageConfig = pkgconfig_path,
-                        pgm_L   = unlit_path,
-                        pgm_P   = cpp_path,
-                        pgm_F   = "",
-                        pgm_c   = (gcc_prog,gcc_args),
-                        pgm_m   = (mangle_prog,mangle_args),
-                        pgm_s   = (split_prog,split_args),
-                        pgm_a   = (as_prog,as_args),
-                        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_windres = windres_path
+        ; let   as_prog  = gcc_prog
+                as_args  = gcc_args
+                ld_prog  = gcc_prog
+                ld_args  = gcc_args
+
+        -- We just assume on command line
+        ; lc_prog <- getSetting "LLVM llc command"
+        ; lo_prog <- getSetting "LLVM opt command"
+
+        ; return $ Settings {
+                        sTargetPlatform = Platform {
+                                              platformArch = targetArch,
+                                              platformOS   = targetOS,
+                                              platformWordSize = targetWordSize,
+                                              platformHasGnuNonexecStack = targetHasGnuNonexecStack,
+                                              platformHasIdentDirective = targetHasIdentDirective,
+                                              platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
+                                          },
+                        sTmpDir = normalise tmpdir,
+                        sGhcUsagePath = ghc_usage_msg_path,
+                        sGhciUsagePath = ghci_usage_msg_path,
+                        sTopDir  = top_dir,
+                        sRawSettings = mySettings,
+                        sExtraGccViaCFlags = words myExtraGccViaCFlags,
+                        sSystemPackageConfig = pkgconfig_path,
+                        sPgm_L   = unlit_path,
+                        sPgm_P   = (cpp_prog, cpp_args),
+                        sPgm_F   = "",
+                        sPgm_c   = (gcc_prog, gcc_args),
+                        sPgm_s   = (split_prog,split_args),
+                        sPgm_a   = (as_prog, as_args),
+                        sPgm_l   = (ld_prog, ld_args),
+                        sPgm_dll = (mkdll_prog,mkdll_args),
+                        sPgm_T   = touch_path,
+                        sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
+                        sPgm_windres = windres_path,
+                        sPgm_lo  = (lo_prog,[]),
+                        sPgm_lc  = (lc_prog,[]),
                         -- Hans: this isn't right in general, but you can
                         -- elaborate it in the same way as the others
+                        sOpt_L       = [],
+                        sOpt_P       = (if opt_PIC
+                                        then -- this list gets reversed
+                                             ["-D__PIC__", "-U __PIC__"]
+                                        else []),
+                        sOpt_F       = [],
+                        sOpt_c       = [],
+                        sOpt_a       = [],
+                        sOpt_l       = [],
+                        sOpt_windres = [],
+                        sOpt_lo      = [],
+                        sOpt_lc      = []
                 }
         }
 \end{code}
 
 \begin{code}
--- Find TopDir
---      for "installed" this is the root of GHC's support files
---      for "in-place" it is the root of the build tree
---
--- Plan of action:
--- 1. Set proto_top_dir
---      if there is no given TopDir path, get the directory
---      where GHC is running (only on Windows)
---
--- 2. If package.conf exists in proto_top_dir, we are running
---      installed; and TopDir = proto_top_dir
---
--- 3. Otherwise we are running in-place, so
---      proto_top_dir will be /...stuff.../ghc/compiler
---      Set TopDir to /...stuff..., which is the root of the build tree
---
--- This is very gruesome indeed
-
-findTopDir :: Maybe String   -- Maybe TopDir path (without the '-B' prefix).
-           -> IO (Bool,      -- True <=> am installed, False <=> in-place
-                  String)    -- TopDir (in Unix format '/' separated)
-
-findTopDir mbMinusB
-  = do { top_dir <- get_proto
-       ; exists1 <- doesFileExist (top_dir </> "package.conf")
-       ; exists2 <- doesFileExist (top_dir </> "inplace")
-       ; let amInplace = not exists1 -- On Windows, package.conf doesn't exist
-                                     -- when we are inplace
-                      || exists2 -- On Linux, the presence of inplace signals
-                                 -- that we are inplace
-
-       ; return (not amInplace, top_dir)
-       }
-  where
-    -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
-    get_proto = case mbMinusB of
-                  Just minusb -> return (normalise minusb)
-                  Nothing
-                      -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
-                            case maybe_exec_dir of       -- (only works on Windows;
-                                                         --  returns Nothing on Unix)
-                              Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
-                              Just dir -> return dir
+-- returns a Unix-format path (relying on getBaseDir to do so too)
+findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
+           -> IO String    -- TopDir (in Unix format '/' separated)
+findTopDir (Just minusb) = return (normalise minusb)
+findTopDir Nothing
+    = do -- Get directory of executable
+         maybe_exec_dir <- getBaseDir
+         case maybe_exec_dir of
+             -- "Just" on Windows, "Nothing" on unix
+             Nothing  -> ghcError (InstallationError "missing -B<dir> option")
+             Just dir -> return dir
 \end{code}
 
 
@@ -364,8 +343,11 @@ runCpp :: DynFlags -> [Option] -> IO ()
 runCpp dflags args =   do
   let (p,args0) = pgm_P dflags
       args1 = args0 ++ args
-  mb_env <- getGccEnv args1
-  runSomethingFiltered dflags id  "C pre-processor" p args1 mb_env
+      args2 = if dopt Opt_WarnIsError dflags
+              then Option "-Werror" : args1
+              else                    args1
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id  "C pre-processor" p args2 mb_env
 
 runPp :: DynFlags -> [Option] -> IO ()
 runPp dflags args =   do
@@ -432,6 +414,37 @@ runCc dflags args =   do
 isContainedIn :: String -> String -> Bool
 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
 
+askCc :: DynFlags -> [Option] -> IO String
+askCc dflags args = do
+  let (p,args0) = pgm_c dflags
+      args1 = args0 ++ args
+  mb_env <- getGccEnv args1
+  runSomethingWith dflags "gcc" p args1 $ \real_args ->
+    readCreateProcess (proc p real_args){ env = mb_env }
+
+-- Version of System.Process.readProcessWithExitCode that takes an environment
+readCreateProcess
+    :: CreateProcess
+    -> IO (ExitCode, String)    -- ^ stdout
+readCreateProcess proc = do
+    (_, Just outh, _, pid) <-
+        createProcess proc{ std_out = CreatePipe }
+
+    -- fork off a thread to start consuming the output
+    output  <- hGetContents outh
+    outMVar <- newEmptyMVar
+    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
+
+    -- wait on the output
+    takeMVar outMVar
+    hClose outh
+
+    -- wait on the process
+    ex <- waitForProcess pid
+
+    return (ex, output)
+
+
 -- If the -B<dir> option is set, add <dir> to PATH.  This works around
 -- a bug in gcc on Windows Vista where it can't find its auxiliary
 -- binaries (see bug #1110).
@@ -451,11 +464,6 @@ getGccEnv opts =
         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
   mangle_path other = other
 
-runMangle :: DynFlags -> [Option] -> IO ()
-runMangle dflags args = do
-  let (p,args0) = pgm_m dflags
-  runSomething dflags "Mangler" p (args0++args)
-
 runSplit :: DynFlags -> [Option] -> IO ()
 runSplit dflags args = do
   let (p,args0) = pgm_s dflags
@@ -468,6 +476,76 @@ runAs dflags args = do
   mb_env <- getGccEnv args1
   runSomethingFiltered dflags id "Assembler" p args1 mb_env
 
+-- | Run the LLVM Optimiser
+runLlvmOpt :: DynFlags -> [Option] -> IO ()
+runLlvmOpt dflags args = do
+  let (p,args0) = pgm_lo dflags
+  runSomething dflags "LLVM Optimiser" p (args0++args)
+
+-- | Run the LLVM Compiler
+runLlvmLlc :: DynFlags -> [Option] -> IO ()
+runLlvmLlc dflags args = do
+  let (p,args0) = pgm_lc dflags
+  runSomething dflags "LLVM Compiler" p (args0++args)
+
+-- | Run the clang compiler (used as an assembler for the LLVM
+-- backend on OS X as LLVM doesn't support the OS X system
+-- assembler)
+runClang :: DynFlags -> [Option] -> IO ()
+runClang dflags args = do
+  -- we simply assume its available on the PATH
+  let clang = "clang"
+  Exception.catch (do
+        runSomething dflags "Clang (Assembler)" clang args
+    )
+    (\(err :: SomeException) -> do
+        putMsg dflags $ text $ "Error running clang! you need clang installed"
+                            ++ " to use the LLVM backend"
+        throw err
+    )
+
+-- | Figure out which version of LLVM we are running this session
+figureLlvmVersion :: DynFlags -> IO (Maybe Int)
+figureLlvmVersion dflags = do
+  let (pgm,opts) = pgm_lc dflags
+      args = filter notNull (map showOpt opts)
+      -- we grab the args even though they should be useless just in
+      -- case the user is using a customised 'llc' that requires some
+      -- of the options they've specified. llc doesn't care what other
+      -- options are specified when '-version' is used.
+      args' = args ++ ["-version"]
+  ver <- catchIO (do
+             (pin, pout, perr, _) <- runInteractiveProcess pgm args'
+                                             Nothing Nothing
+             {- > llc -version
+                  Low Level Virtual Machine (http://llvm.org/):
+                    llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
+                    ...
+             -}
+             hSetBinaryMode pout False
+             _     <- hGetLine pout
+             vline <- hGetLine pout
+             v     <- case filter isDigit vline of
+                            []      -> fail "no digits!"
+                            [x]     -> fail $ "only 1 digit! (" ++ show x ++ ")"
+                            (x:y:_) -> return ((read [x,y]) :: Int)
+             hClose pin
+             hClose pout
+             hClose perr
+             return $ Just v
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out LLVM version):" <+>
+                     text (show err))
+                putMsg dflags $ vcat
+                    [ text "Warning:", nest 9 $
+                          text "Couldn't figure out LLVM version!" $$
+                          text "Make sure you have installed LLVM"]
+                return Nothing)
+  return ver
+  
+
 runLink :: DynFlags -> [Option] -> IO ()
 runLink dflags args = do
   let (p,args0) = pgm_l dflags
@@ -484,25 +562,24 @@ runMkDLL dflags args = do
 
 runWindres :: DynFlags -> [Option] -> IO ()
 runWindres dflags args = do
-  let (gcc,gcc_args) = pgm_c dflags
-      windres        = pgm_windres dflags
+  let (gcc, gcc_args) = pgm_c dflags
+      windres = pgm_windres dflags
+      quote x = "\"" ++ x ++ "\""
+      args' = -- If windres.exe and gcc.exe are in a directory containing
+              -- spaces then windres fails to run gcc. We therefore need
+              -- to tell it what command to use...
+              Option ("--preprocessor=" ++
+                      unwords (map quote (gcc :
+                                          map showOpt gcc_args ++
+                                          ["-E", "-xc", "-DRC_INVOKED"])))
+              -- ...but if we do that then if windres calls popen then
+              -- it can't understand the quoting, so we have to use
+              -- --use-temp-file so that it interprets it correctly.
+              -- See #1828.
+            : Option "--use-temp-file"
+            : args
   mb_env <- getGccEnv gcc_args
-  runSomethingFiltered dflags id "Windres" windres
-        -- we must tell windres where to find gcc: it might not be on PATH
-        (Option ("--preprocessor=" ++
-                 unwords (map quote (gcc : map showOpt gcc_args ++
-                                     ["-E", "-xc", "-DRC_INVOKED"])))
-        -- -- use-temp-file is required for windres to interpret the
-        -- quoting in the preprocessor arg above correctly.  Without
-        -- this, windres calls the preprocessor with popen, which gets
-        -- the quoting wrong (discovered by experimentation and
-        -- reading the windres sources).  See #1828.
-        : Option "--use-temp-file"
-        : args)
-        -- we must use the PATH workaround here too, since windres invokes gcc
-        mb_env
-  where
-        quote x = '\"' : x ++ "\""
+  runSomethingFiltered dflags id "Windres" windres args' mb_env
 
 touch :: DynFlags -> String -> String -> IO ()
 touch dflags purpose arg =
@@ -516,23 +593,46 @@ copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
 copyWithHeader dflags purpose maybe_header from to = do
   showPass dflags purpose
 
-  h <- openFile to WriteMode
-  ls <- readFile from -- inefficient, but it'll do for now.
-                      -- ToDo: speed up via slurping.
-  maybe (return ()) (hPutStr h) maybe_header
-  hPutStr h ls
-  hClose h
-
-getExtraViaCOpts :: DynFlags -> IO [String]
-getExtraViaCOpts dflags = do
-  (am_installed, top_dir) <- findTopDir (Just (topDir dflags))
-  let top_dir'
-       -- XXX Euch:
-       | isWindowsHost && not am_installed
-          = top_dir </> ".." </> ".." </> "inplace-datadir"
-       | otherwise = top_dir
-  f <- readFile (top_dir' </> "extra-gcc-opts")
-  return (words f)
+  hout <- openBinaryFile to   WriteMode
+  hin  <- openBinaryFile from ReadMode
+  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
+  maybe (return ()) (header hout) maybe_header
+  hPutStr hout ls
+  hClose hout
+  hClose hin
+ where
+#if __GLASGOW_HASKELL__ >= 702
+  -- write the header string in UTF-8.  The header is something like
+  --   {-# LINE "foo.hs" #-}
+  -- and we want to make sure a Unicode filename isn't mangled.
+  header h str = do
+   hSetEncoding h utf8
+   hPutStr h str
+   hSetBinaryMode h True
+#else
+  header h str = hPutStr h str
+#endif
+
+-- | read the contents of the named section in an ELF object as a
+-- String.
+readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
+readElfSection _dflags section exe = do
+  let
+     prog = "readelf"
+     args = [Option "-p", Option section, FileOption "" exe]
+  --
+  r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) ""
+  case r of
+    (ExitSuccess, out, _err) -> return (doFilter (lines out))
+    _ -> return Nothing
+ where
+  doFilter [] = Nothing
+  doFilter (s:r) = case readP_to_S parse s of
+                    [(p,"")] -> Just p
+                    _r       -> doFilter r
+   where parse = do
+           skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces;
+           munch (const True)
 \end{code}
 
 %************************************************************************
@@ -542,32 +642,30 @@ getExtraViaCOpts dflags = do
 %************************************************************************
 
 \begin{code}
-GLOBAL_VAR(v_FilesToClean, [],               [String] )
-GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
-\end{code}
-
-\begin{code}
 cleanTempDirs :: DynFlags -> IO ()
 cleanTempDirs dflags
    = unless (dopt Opt_KeepTmpFiles dflags)
-   $ do ds <- readIORef v_DirsToClean
-        removeTmpDirs dflags (eltsFM ds)
-        writeIORef v_DirsToClean emptyFM
+   $ do let ref = dirsToClean dflags
+        ds <- readIORef ref
+        removeTmpDirs dflags (Map.elems ds)
+        writeIORef ref Map.empty
 
 cleanTempFiles :: DynFlags -> IO ()
 cleanTempFiles dflags
    = unless (dopt Opt_KeepTmpFiles dflags)
-   $ do fs <- readIORef v_FilesToClean
+   $ do let ref = filesToClean dflags
+        fs <- readIORef ref
         removeTmpFiles dflags fs
-        writeIORef v_FilesToClean []
+        writeIORef ref []
 
 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 cleanTempFilesExcept dflags dont_delete
    = unless (dopt Opt_KeepTmpFiles dflags)
-   $ do files <- readIORef v_FilesToClean
+   $ do let ref = filesToClean dflags
+        files <- readIORef ref
         let (to_keep, to_delete) = partition (`elem` dont_delete) files
+        writeIORef ref to_keep
         removeTmpFiles dflags to_delete
-        writeIORef v_FilesToClean to_keep
 
 
 -- find a temporary name that doesn't already exist.
@@ -575,44 +673,47 @@ newTempName :: DynFlags -> Suffix -> IO FilePath
 newTempName dflags extn
   = do d <- getTempDir dflags
        x <- getProcessID
-       findTempName (d ++ "/ghc" ++ show x ++ "_") 0
+       findTempName (d </> "ghc" ++ show x ++ "_") 0
   where
     findTempName :: FilePath -> Integer -> IO FilePath
     findTempName prefix x
       = do let filename = (prefix ++ show x) <.> extn
            b  <- doesFileExist filename
            if b then findTempName prefix (x+1)
-                else do consIORef v_FilesToClean filename -- clean it up later
+                else do -- clean it up later
+                        consIORef (filesToClean dflags) filename
                         return filename
 
 -- return our temporary directory within tmp_dir, creating one if we
 -- don't have one yet
 getTempDir :: DynFlags -> IO FilePath
-getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
-  = do mapping <- readIORef v_DirsToClean
-       case lookupFM mapping tmp_dir of
+getTempDir dflags
+  = do let ref = dirsToClean dflags
+           tmp_dir = tmpDir dflags
+       mapping <- readIORef ref
+       case Map.lookup tmp_dir mapping of
            Nothing ->
                do x <- getProcessID
-                  let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
+                  let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
                   let
                       mkTempDir :: Integer -> IO FilePath
                       mkTempDir x
                        = let dirname = prefix ++ show x
                          in do createDirectory dirname
-                               let mapping' = addToFM mapping tmp_dir dirname
-                               writeIORef v_DirsToClean mapping'
+                               let mapping' = Map.insert tmp_dir dirname mapping
+                               writeIORef ref mapping'
                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
                                return dirname
-                            `IO.catch` \e ->
+                            `catchIO` \e ->
                                     if isAlreadyExistsError e
                                     then mkTempDir (x+1)
                                     else ioError e
                   mkTempDir 0
            Just d -> return d
 
-addFilesToClean :: [FilePath] -> IO ()
+addFilesToClean :: DynFlags -> [FilePath] -> IO ()
 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
-addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
+addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
 
 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
 removeTmpDirs dflags ds
@@ -642,7 +743,7 @@ removeTmpFiles dflags fs
     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 
 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
-removeWith dflags remover f = remover f `IO.catch`
+removeWith dflags remover f = remover f `catchIO`
   (\e ->
    let msg = if isDoesNotExistError e
              then ptext (sLit "Warning: deleting non-existent") <+> text f
@@ -671,33 +772,45 @@ runSomethingFiltered
   -> Maybe [(String,String)] -> IO ()
 
 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        r <- builderMainLoop dflags filter_fn pgm real_args mb_env
+        return (r,())
+
+runSomethingWith
+  :: DynFlags -> String -> String -> [Option]
+  -> ([String] -> IO (ExitCode, a))
+  -> IO a
+
+runSomethingWith dflags phase_name pgm args io = do
   let real_args = filter notNull (map showOpt args)
-  traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
-  (exit_code, doesn'tExist) <-
-     IO.catch (do
-         rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
-         case rc of
-           ExitSuccess{} -> return (rc, False)
-           ExitFailure n
-             -- rawSystem returns (ExitFailure 127) if the exec failed for any
-             -- reason (eg. the program doesn't exist).  This is the only clue
-             -- we have, but we need to report something to the user because in
-             -- the case of a missing program there will otherwise be no output
-             -- at all.
-            | n == 127  -> return (rc, True)
-            | otherwise -> return (rc, False))
-                -- Should 'rawSystem' generate an IO exception indicating that
-                -- 'pgm' couldn't be run rather than a funky return code, catch
-                -- this here (the win32 version does this, but it doesn't hurt
-                -- to test for this in general.)
-              (\ err ->
-                if IO.isDoesNotExistError err
-                 then return (ExitFailure 1, True)
-                 else IO.ioError err)
-  case (doesn'tExist, exit_code) of
-     (True, _)        -> throwDyn (InstallationError ("could not execute: " ++ pgm))
-     (_, ExitSuccess) -> return ()
-     _                -> throwDyn (PhaseFailed phase_name exit_code)
+#if __GLASGOW_HASKELL__ >= 701
+      cmdLine = showCommandForUser pgm real_args
+#else
+      cmdLine = unwords (pgm:real_args)
+#endif
+  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
+
+handleProc :: String -> String -> IO (ExitCode, r) -> IO r
+handleProc pgm phase_name proc = do
+    (rc, r) <- proc `catchIO` handler
+    case rc of
+      ExitSuccess{} -> return r
+      ExitFailure n
+        -- rawSystem returns (ExitFailure 127) if the exec failed for any
+        -- reason (eg. the program doesn't exist).  This is the only clue
+        -- we have, but we need to report something to the user because in
+        -- the case of a missing program there will otherwise be no output
+        -- at all.
+       | n == 127  -> does_not_exist
+       | otherwise -> ghcError (PhaseFailed phase_name rc)
+  where
+    handler err =
+       if IO.isDoesNotExistError err
+          then does_not_exist
+          else IO.ioError err
+
+    does_not_exist = ghcError (InstallationError ("could not execute: " ++ pgm))
+
 
 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
                 -> [String] -> Maybe [(String, String)]
@@ -709,8 +822,8 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
   -- and run a loop piping the output from the compiler to the log_action in DynFlags
   hSetBuffering hStdOut LineBuffering
   hSetBuffering hStdErr LineBuffering
-  forkIO (readerProc chan hStdOut filter_fn)
-  forkIO (readerProc chan hStdErr filter_fn)
+  _ <- forkIO (readerProc chan hStdOut filter_fn)
+  _ <- forkIO (readerProc chan hStdErr filter_fn)
   -- we don't want to finish until 2 streams have been completed
   -- (stdout and stderr)
   -- nor until 1 exit code has been retrieved.
@@ -813,29 +926,22 @@ data BuildMessage
   | BuildError !SrcLoc !SDoc
   | EOF
 
-showOpt :: Option -> String
-showOpt (FileOption pre f) = pre ++ f
-showOpt (Option s)  = s
-
-traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
--- a) trace the command (at two levels of verbosity)
--- b) don't do it at all if dry-run is set
+traceCmd :: DynFlags -> String -> String -> IO a -> IO a
+-- trace the command (at two levels of verbosity)
 traceCmd dflags phase_name cmd_line action
  = do   { let verb = verbosity dflags
         ; showPass dflags phase_name
         ; debugTraceMsg dflags 3 (text cmd_line)
-        ; hFlush stderr
-
-           -- Test for -n flag
-        ; unless (dopt Opt_DryRun dflags) $ do {
+        ; case flushErr dflags of
+              FlushErr io -> io
 
            -- And run it!
-        ; action `IO.catch` handle_exn verb
-        }}
+        ; action `catchIO` handle_exn verb
+        }
   where
     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
-                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
+                              ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
 \end{code}
 
 %************************************************************************
@@ -850,25 +956,33 @@ traceCmd dflags phase_name cmd_line action
 
 getBaseDir :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
--- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
--- return the path $(stuff).  Note that we drop the "bin/" directory too.
-getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
-                buf <- mallocArray len
-                ret <- getModuleFileName nullPtr buf len
-                if ret == 0 then free buf >> return Nothing
-                            else do s <- peekCString buf
-                                    free buf
-                                    return (Just (rootDir s))
+-- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
+-- return the path $(stuff)/lib.
+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
   where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+    
     rootDir s = case splitFileName $ normalise s of
-                (d, "ghc.exe") ->
+                (d, ghc_exe)
+                 | lower ghc_exe `elem` ["ghc.exe",
+                                         "ghc-stage1.exe",
+                                         "ghc-stage2.exe",
+                                         "ghc-stage3.exe"] ->
                     case splitFileName $ takeDirectory d of
-                    (d', "bin") -> takeDirectory d'
-                    _ -> panic ("Expected \"bin\" in " ++ show s)
-                _ -> panic ("Expected \"ghc.exe\" in " ++ show s)
-
-foreign import stdcall unsafe "GetModuleFileNameA"
-  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+                    -- ghc is in $topdir/bin/ghc.exe
+                    (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
+                    _ -> fail
+                _ -> fail
+        where fail = panic ("can't decompose ghc.exe path: " ++ show s)
+              lower = map toLower
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getBaseDir = return Nothing
 #endif