Prefer #if defined to #ifdef
[ghc.git] / compiler / main / SysTools.hs
index 56eba69..ad2e33c 100644 (file)
@@ -25,14 +25,13 @@ module SysTools (
         runLlvmLlc,
         runClang,
         figureLlvmVersion,
-        readElfSection,
 
         getLinkerInfo,
         getCompilerInfo,
 
         linkDynLib,
 
-        askCc,
+        askLd,
 
         touch,                  -- String -> String -> IO ()
         copy,
@@ -44,7 +43,12 @@ module SysTools (
         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
         addFilesToClean,
 
-        Option(..)
+        Option(..),
+
+        -- frameworks
+        getPkgFrameworkOpts,
+        getFrameworkOpts
+
 
  ) where
 
@@ -62,6 +66,8 @@ import Util
 import DynFlags
 import Exception
 
+import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
+
 import Data.IORef
 import Control.Monad
 import System.Exit
@@ -73,14 +79,22 @@ import System.Directory
 import Data.Char
 import Data.List
 import qualified Data.Map as Map
-import Text.ParserCombinators.ReadP hiding (char)
-import qualified Text.ParserCombinators.ReadP as R
+import qualified Data.Set as Set
 
-#ifndef mingw32_HOST_OS
+#if !defined(mingw32_HOST_OS)
 import qualified System.Posix.Internals
 #else /* Must be Win32 */
 import Foreign
 import Foreign.C.String
+#if MIN_VERSION_Win32(2,5,0)
+import qualified System.Win32.Types as Win32
+#else
+import qualified System.Win32.Info as Win32
+#endif
+import System.Win32.Types (DWORD, LPTSTR, HANDLE)
+import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
+import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
+import System.Win32.DLL (loadLibrary, getProcAddress)
 #endif
 
 import System.Process
@@ -88,7 +102,7 @@ import Control.Concurrent
 import FastString
 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
 
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS)
 # if defined(i386_HOST_ARCH)
 #  define WINDOWS_CCONV stdcall
 # elif defined(x86_64_HOST_ARCH)
@@ -114,9 +128,9 @@ On Unix:
 On Windows:
   - ghc never has a shell wrapper.
   - we can find the location of the ghc binary, which is
-        $topdir/bin/<something>.exe
+        $topdir/<foo>/<something>.exe
     where <something> may be "ghc", "ghc-stage2", or similar
-  - we strip off the "bin/<something>.exe" to leave $topdir.
+  - we strip off the "<foo>/<something>.exe" to leave $topdir.
 
 from topdir we can find package.conf, ghc-asm, etc.
 
@@ -185,6 +199,8 @@ initSysTools mbMinusB
            platformConstantsFile = top_dir </> "platformConstants"
            installed :: FilePath -> FilePath
            installed file = top_dir </> file
+           libexec :: FilePath -> FilePath
+           libexec file = top_dir </> "bin" </> file
 
        settingsStr <- readFile settingsFile
        platformConstantsStr <- readFile platformConstantsFile
@@ -237,6 +253,7 @@ initSysTools mbMinusB
        -- to make that possible, so for now you can't.
        gcc_prog <- getSetting "C compiler command"
        gcc_args_str <- getSetting "C compiler flags"
+       gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
        cpp_prog <- getSetting "Haskell CPP command"
        cpp_args_str <- getSetting "Haskell CPP flags"
        let unreg_gcc_args = if targetUnregisterised
@@ -263,10 +280,10 @@ initSysTools mbMinusB
 
              -- For all systems, unlit, split, mangle are GHC utilities
              -- architecture-specific stuff is done when building Config.hs
-           unlit_path = installed cGHC_UNLIT_PGM
+           unlit_path = libexec cGHC_UNLIT_PGM
 
              -- split is a Perl script
-           split_script  = installed cGHC_SPLIT_PGM
+           split_script  = libexec cGHC_SPLIT_PGM
 
        windres_path <- getSetting "windres command"
        libtool_path <- getSetting "libtool command"
@@ -303,6 +320,8 @@ initSysTools mbMinusB
        lc_prog <- getSetting "LLVM llc command"
        lo_prog <- getSetting "LLVM opt command"
 
+       let iserv_prog = libexec "ghc-iserv"
+
        let platform = Platform {
                           platformArch = targetArch,
                           platformOS   = targetOS,
@@ -327,6 +346,7 @@ initSysTools mbMinusB
                     sLdSupportsBuildId       = ldSupportsBuildId,
                     sLdSupportsFilelist      = ldSupportsFilelist,
                     sLdIsGnuLd               = ldIsGnuLd,
+                    sGccSupportsNoPie        = gccSupportsNoPie,
                     sProgramName             = "ghc",
                     sProjectVersion          = cProjectVersion,
                     sPgm_L   = unlit_path,
@@ -338,13 +358,11 @@ initSysTools mbMinusB
                     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_libtool = libtool_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
+                    sPgm_i   = iserv_prog,
                     sOpt_L       = [],
                     sOpt_P       = [],
                     sOpt_F       = [],
@@ -354,6 +372,7 @@ initSysTools mbMinusB
                     sOpt_windres = [],
                     sOpt_lo      = [],
                     sOpt_lc      = [],
+                    sOpt_i       = [],
                     sPlatformConstants = platformConstants
              }
 
@@ -388,9 +407,8 @@ runCpp :: DynFlags -> [Option] -> IO ()
 runCpp dflags args =   do
   let (p,args0) = pgm_P dflags
       args1 = map Option (getOpts dflags opt_P)
-      args2 = if gopt Opt_WarnIsError dflags
-                 then [Option "-Werror"]
-                 else []
+      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
+                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
   mb_env <- getGccEnv args2
   runSomethingFiltered dflags id  "C pre-processor" p
                        (args0 ++ args1 ++ args2 ++ args) mb_env
@@ -407,7 +425,7 @@ runCc dflags args =   do
       args1 = map Option (getOpts dflags opt_c)
       args2 = args0 ++ args1 ++ args
   mb_env <- getGccEnv args2
-  runSomethingFiltered dflags cc_filter "C Compiler" p args2 mb_env
+  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
  where
   -- discard some harmless warnings from gcc that we can't turn off
   cc_filter = unlines . doFilter . lines
@@ -462,20 +480,22 @@ 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 = map Option (getOpts dflags opt_c)
-      args2 = args0 ++ args1 ++ args
+-- | Run the linker with some arguments and return the output
+askLd :: DynFlags -> [Option] -> IO String
+askLd dflags args = do
+  let (p,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ args1 ++ args
   mb_env <- getGccEnv args2
   runSomethingWith dflags "gcc" p args2 $ \real_args ->
-    readCreateProcess (proc p real_args){ env = mb_env }
+    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
 
--- Version of System.Process.readProcessWithExitCode that takes an environment
-readCreateProcess
+-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
+-- inherited from the parent process, and output to stderr is not captured.
+readCreateProcessWithExitCode'
     :: CreateProcess
     -> IO (ExitCode, String)    -- ^ stdout
-readCreateProcess proc = do
+readCreateProcessWithExitCode' proc = do
     (_, Just outh, _, pid) <-
         createProcess proc{ std_out = CreatePipe }
 
@@ -493,51 +513,25 @@ readCreateProcess proc = do
 
     return (ex, output)
 
+replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
+replaceVar (var, value) env =
+    (var, value) : filter (\(var',_) -> var /= var') env
+
+-- | Version of @System.Process.readProcessWithExitCode@ that takes a
+-- key-value tuple to insert into the environment.
 readProcessEnvWithExitCode
     :: String -- ^ program path
     -> [String] -- ^ program args
-    -> [(String, String)] -- ^ environment to override
+    -> (String, String) -- ^ addition to the environment
     -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
 readProcessEnvWithExitCode prog args env_update = do
     current_env <- getEnvironment
-    let new_env = env_update ++ [ (k, v)
-                                | let overriden_keys = map fst env_update
-                                , (k, v) <- current_env
-                                , k `notElem` overriden_keys
-                                ]
-        p       = proc prog args
-
-    (_stdin, Just stdoh, Just stdeh, pid) <-
-        createProcess p{ std_out = CreatePipe
-                       , std_err = CreatePipe
-                       , env     = Just new_env
-                       }
-
-    outMVar <- newEmptyMVar
-    errMVar <- newEmptyMVar
-
-    _ <- forkIO $ do
-        stdo <- hGetContents stdoh
-        _ <- evaluate (length stdo)
-        putMVar outMVar stdo
-
-    _ <- forkIO $ do
-        stde <- hGetContents stdeh
-        _ <- evaluate (length stde)
-        putMVar errMVar stde
-
-    out <- takeMVar outMVar
-    hClose stdoh
-    err <- takeMVar errMVar
-    hClose stdeh
-
-    ex <- waitForProcess pid
-
-    return (ex, out, err)
+    readCreateProcessWithExitCode (proc prog args) {
+        env = Just (replaceVar env_update current_env) } ""
 
 -- Don't let gcc localize version info string, #8825
-en_locale_env :: [(String, String)]
-en_locale_env = [("LANGUAGE", "en")]
+c_locale_env :: (String, String)
+c_locale_env = ("LANGUAGE", "C")
 
 -- 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
@@ -604,13 +598,13 @@ runClang dflags args = do
     (\(err :: SomeException) -> do
         errorMsg dflags $
             text ("Error running clang! you need clang installed to use the" ++
-                "LLVM backend") $+$
+                  " LLVM backend") $+$
             text "(or GHC tried to execute clang incorrectly)"
         throwIO err
     )
 
 -- | Figure out which version of LLVM we are running this session
-figureLlvmVersion :: DynFlags -> IO (Maybe Int)
+figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
 figureLlvmVersion dflags = do
   let (pgm,opts) = pgm_lc dflags
       args = filter notNull (map showOpt opts)
@@ -623,17 +617,18 @@ figureLlvmVersion dflags = 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)
+                  LLVM (http://llvm.org/):
+                    LLVM version 3.5.2
                     ...
              -}
              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)
+             vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
+             v     <- case span (/= '.') vline of
+                        ("",_)  -> fail "no digits!"
+                        (x,y) -> return (read x
+                                        , read $ takeWhile isDigit $ drop 1 y)
+
              hClose pin
              hClose pout
              hClose perr
@@ -646,13 +641,14 @@ figureLlvmVersion dflags = do
                 errorMsg dflags $ vcat
                     [ text "Warning:", nest 9 $
                           text "Couldn't figure out LLVM version!" $$
-                          text "Make sure you have installed LLVM"]
+                          text ("Make sure you have installed LLVM " ++
+                                llvmVersionStr supportedLlvmVersion) ]
                 return Nothing)
   return ver
 
 {- Note [Windows stack usage]
 
-See: Trac #8870 (and #8834 for related info)
+See: Trac #8870 (and #8834 for related info) and #12186
 
 On Windows, occasionally we need to grow the stack. In order to do
 this, we would normally just bump the stack pointer - but there's a
@@ -673,23 +669,17 @@ stack space in GHC itself. In the x86 codegen, we needed approximately
 ~12kb of stack space in one go, which caused the process to segfault,
 as the intervening pages were not committed.
 
-In the future, we should do the same thing, to make the problem
-completely go away. In the mean time, we're using a workaround: we
-instruct the linker to specify the generated PE as having an initial
-reserved stack size of 8mb, as well as a initial *committed* stack
-size of 8mb. The default committed size was previously only 4k.
+GCC can emit such a check for us automatically but only when the flag
+-fstack-check is used.
 
-Theoretically it's possible to still hit this problem if you request a
-stack bump of more than 8mb in one go. But the amount of code
-necessary is quite large, and 8mb "should be more than enough for
-anyone" right now (he said, before millions of lines of code cried out
-in terror).
+See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html
+for more information.
 
 -}
 
 {- Note [Run-time linker info]
 
-See also: Trac #5240, Trac #6063
+See also: Trac #5240, Trac #6063, Trac #10110
 
 Before 'runLink', we need to be sure to get the relevant information
 about the linker we're using at runtime to see if we need any extra
@@ -718,12 +708,50 @@ circular dependency.
 
 -}
 
+{- Note [ELF needed shared libs]
+
+Some distributions change the link editor's default handling of
+ELF DT_NEEDED tags to include only those shared objects that are
+needed to resolve undefined symbols. For Template Haskell we need
+the last temporary shared library also if it is not needed for the
+currently linked temporary shared library. We specify --no-as-needed
+to override the default. This flag exists in GNU ld and GNU gold.
+
+The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
+(Mach-O) the flag is not needed.
+
+-}
+
+{- Note [Windows static libGCC]
+
+The GCC versions being upgraded to in #10726 are configured with
+dynamic linking of libgcc supported. This results in libgcc being
+linked dynamically when a shared library is created.
+
+This introduces thus an extra dependency on GCC dll that was not
+needed before by shared libraries created with GHC. This is a particular
+issue on Windows because you get a non-obvious error due to this missing
+dependency. This dependent dll is also not commonly on your path.
+
+For this reason using the static libgcc is preferred as it preserves
+the same behaviour that existed before. There are however some very good
+reasons to have the shared version as well as described on page 181 of
+https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
+
+"There are several situations in which an application should use the
+ shared ‘libgcc’ instead of the static version. The most common of these
+ is when the application wishes to throw and catch exceptions across different
+ shared libraries. In that case, each of the libraries as well as the application
+ itself should use the shared ‘libgcc’. "
+
+-}
 
 neededLinkArgs :: LinkerInfo -> [Option]
 neededLinkArgs (GnuLD o)     = o
 neededLinkArgs (GnuGold o)   = o
 neededLinkArgs (DarwinLD o)  = o
 neededLinkArgs (SolarisLD o) = o
+neededLinkArgs (AixLD o)     = o
 neededLinkArgs UnknownLD     = []
 
 -- Grab linker info and cache it in DynFlags.
@@ -752,12 +780,18 @@ getLinkerInfo' dflags = do
         | any ("GNU ld" `isPrefixOf`) stdo =
           -- GNU ld specifically needs to use less memory. This especially
           -- hurts on small object files. Trac #5240.
+          -- Set DT_NEEDED for all shared libraries. Trac #10110.
+          -- TODO: Investigate if these help or hurt when using split sections.
           return (GnuLD $ map Option ["-Wl,--hash-size=31",
-                                      "-Wl,--reduce-memory-overheads"])
+                                      "-Wl,--reduce-memory-overheads",
+                                      -- ELF specific flag
+                                      -- see Note [ELF needed shared libs]
+                                      "-Wl,--no-as-needed"])
 
         | any ("GNU gold" `isPrefixOf`) stdo =
-          -- GNU gold does not require any special arguments.
-          return (GnuGold [])
+          -- GNU gold only needs --no-as-needed. Trac #10110.
+          -- ELF specific flag, see Note [ELF needed shared libs]
+          return (GnuGold [Option "-Wl,--no-as-needed"])
 
          -- Unknown linker.
         | otherwise = fail "invalid --version output, or linker is unsupported"
@@ -773,6 +807,9 @@ getLinkerInfo' dflags = do
                  -- precisely so we assume here, the Solaris linker is
                  -- used.
                  return $ SolarisLD []
+               OSAIX ->
+                 -- IBM AIX uses its own non-binutils linker as well
+                 return $ AixLD []
                OSDarwin ->
                  -- Darwin has neither GNU Gold or GNU LD, but a strange linker
                  -- that doesn't support --version. We can just assume that's
@@ -789,15 +826,18 @@ getLinkerInfo' dflags = do
                    [ -- Reduce ld memory usage
                      "-Wl,--hash-size=31"
                    , "-Wl,--reduce-memory-overheads"
-                     -- Increase default stack, see
+                     -- Emit gcc stack checks
                      -- Note [Windows stack usage]
-                   , "-Xlinker", "--stack=0x800000,0x800000" ]
+                   , "-fstack-check"
+                     -- Force static linking of libGCC
+                     -- Note [Windows static libGCC]
+                   , "-static-libgcc" ]
                _ -> do
                  -- In practice, we use the compiler as the linker here. Pass
                  -- -Wl,--version to get linker version info.
                  (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
                                         (["-Wl,--version"] ++ args3)
-                                        en_locale_env
+                                        c_locale_env
                  -- Split the output by lines to make certain kinds
                  -- of processing easier. In particular, 'clang' and 'gcc'
                  -- have slightly different outputs for '-Wl,--version', but
@@ -833,10 +873,10 @@ getCompilerInfo' dflags = do
       -- Try to grab the info from the process output.
       parseCompilerInfo _stdo stde _exitc
         -- Regular GCC
-        | any ("gcc version" `isPrefixOf`) stde =
+        | any ("gcc version" `isInfixOf`) stde =
           return GCC
         -- Regular clang
-        | any ("clang version" `isPrefixOf`) stde =
+        | any ("clang version" `isInfixOf`) stde =
           return Clang
         -- XCode 5.1 clang
         | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
@@ -853,7 +893,7 @@ getCompilerInfo' dflags = do
   -- Process the executable call
   info <- catchIO (do
                 (exitc, stdo, stde) <-
-                    readProcessEnvWithExitCode pgm ["-v"] en_locale_env
+                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env
                 -- Split the output by lines to make certain kinds
                 -- of processing easier.
                 parseCompilerInfo (lines stdo) (lines stde) exitc
@@ -874,9 +914,9 @@ runLink dflags args = do
   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
   let (p,args0) = pgm_l dflags
       args1     = map Option (getOpts dflags opt_l)
-      args2     = args0 ++ args1 ++ args ++ linkargs
+      args2     = args0 ++ linkargs ++ args1 ++ args
   mb_env <- getGccEnv args2
-  runSomethingFiltered dflags ld_filter "Linker" p args2 mb_env
+  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
   where
     ld_filter = case (platformOS (targetPlatform dflags)) of
                   OSSolaris2 -> sunos_ld_filter
@@ -995,31 +1035,7 @@ copyWithHeader dflags purpose maybe_header from to = do
    hPutStr h str
    hSetBinaryMode h True
 
--- | 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 <- readProcessEnvWithExitCode prog (filter notNull (map showOpt args))
-                                  en_locale_env
-  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)
+
 
 {-
 ************************************************************************
@@ -1051,9 +1067,11 @@ cleanTempFilesExcept dflags dont_delete
    $ mask_
    $ do let ref = filesToClean dflags
         to_delete <- atomicModifyIORef' ref $ \files ->
-            let (to_keep,to_delete) = partition (`elem` dont_delete) files
-            in  (to_keep,to_delete)
+            let res@(_to_keep, _to_delete) =
+                    partition (`Set.member` dont_delete_set) files
+            in  res
         removeTmpFiles dflags to_delete
+  where dont_delete_set = Set.fromList dont_delete
 
 
 -- Return a unique numeric temp file suffix
@@ -1064,8 +1082,7 @@ newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n
 newTempName :: DynFlags -> Suffix -> IO FilePath
 newTempName dflags extn
   = do d <- getTempDir dflags
-       x <- getProcessID
-       findTempName (d </> "ghc" ++ show x ++ "_")
+       findTempName (d </> "ghc_") -- See Note [Deterministic base name]
   where
     findTempName :: FilePath -> IO FilePath
     findTempName prefix
@@ -1080,12 +1097,11 @@ newTempName dflags extn
 newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
 newTempLibName dflags extn
   = do d <- getTempDir dflags
-       x <- getProcessID
-       findTempName d ("ghc" ++ show x ++ "_")
+       findTempName d ("ghc_")
   where
     findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
     findTempName dir prefix
-      = do n <- newTempSuffix dflags
+      = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
            let libname = prefix ++ show n
                filename = dir </> "lib" ++ libname <.> extn
            b <- doesFileExist filename
@@ -1138,6 +1154,17 @@ getTempDir dflags = do
       `catchIO` \e -> if isAlreadyExistsError e
                       then mkTempDir prefix else ioError e
 
+-- Note [Deterministic base name]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The filename of temporary files, especially the basename of C files, can end
+-- up in the output in some form, e.g. as part of linker debug information. In the
+-- interest of bit-wise exactly reproducible compilation (#4012), the basename of
+-- the temporary file no longer contains random information (it used to contain
+-- the process id).
+--
+-- This is ok, as the temporary directory used contains the pid (see getTempDir).
+
 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 addFilesToClean dflags new_files
@@ -1174,8 +1201,8 @@ removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
 removeWith dflags remover f = remover f `catchIO`
   (\e ->
    let msg = if isDoesNotExistError e
-             then ptext (sLit "Warning: deleting non-existent") <+> text f
-             else ptext (sLit "Warning: exception raised when deleting")
+             then text "Warning: deleting non-existent" <+> text f
+             else text "Warning: exception raised when deleting"
                                             <+> text f <> colon
                $$ text (show e)
    in debugTraceMsg dflags 2 msg
@@ -1195,6 +1222,62 @@ runSomething :: DynFlags
 runSomething dflags phase_name pgm args =
   runSomethingFiltered dflags id phase_name pgm args Nothing
 
+-- | Run a command, placing the arguments in an external response file.
+--
+-- This command is used in order to avoid overlong command line arguments on
+-- Windows. The command line arguments are first written to an external,
+-- temporary response file, and then passed to the linker via @filepath.
+-- response files for passing them in. See:
+--
+--     https://gcc.gnu.org/wiki/Response_Files
+--     https://ghc.haskell.org/trac/ghc/ticket/10777
+runSomethingResponseFile
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe [(String,String)] -> IO ()
+
+runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        fp <- getResponseFile real_args
+        let args = ['@':fp]
+        r <- builderMainLoop dflags filter_fn pgm args mb_env
+        return (r,())
+  where
+    getResponseFile args = do
+      fp <- newTempName dflags "rsp"
+      withFile fp WriteMode $ \h -> do
+#if defined(mingw32_HOST_OS)
+          hSetEncoding h latin1
+#else
+          hSetEncoding h utf8
+#endif
+          hPutStr h $ unlines $ map escape args
+      return fp
+
+    -- Note: Response files have backslash-escaping, double quoting, and are
+    -- whitespace separated (some implementations use newline, others any
+    -- whitespace character). Therefore, escape any backslashes, newlines, and
+    -- double quotes in the argument, and surround the content with double
+    -- quotes.
+    --
+    -- Another possibility that could be considered would be to convert
+    -- backslashes in the argument to forward slashes. This would generally do
+    -- the right thing, since backslashes in general only appear in arguments
+    -- as part of file paths on Windows, and the forward slash is accepted for
+    -- those. However, escaping is more reliable, in case somehow a backslash
+    -- appears in a non-file.
+    escape x = concat
+        [ "\""
+        , concatMap
+            (\c ->
+                case c of
+                    '\\' -> "\\\\"
+                    '\n' -> "\\n"
+                    '\"' -> "\\\""
+                    _    -> [c])
+            x
+        , "\""
+        ]
+
 runSomethingFiltered
   :: DynFlags -> (String->String) -> String -> String -> [Option]
   -> Maybe [(String,String)] -> IO ()
@@ -1219,19 +1302,15 @@ 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 -> throwGhcExceptionIO (PhaseFailed phase_name rc)
+      ExitFailure n -> throwGhcExceptionIO (
+            ProgramError ("`" ++ takeFileName pgm ++ "'" ++
+                          " failed in phase `" ++ phase_name ++ "'." ++
+                          " (Exit code: " ++ show n ++ ")"))
   where
     handler err =
        if IO.isDoesNotExistError err
           then does_not_exist
-          else IO.ioError err
+          else throwGhcExceptionIO (ProgramError $ show err)
 
     does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
 
@@ -1275,10 +1354,12 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
               msg <- readChan chan
               case msg of
                 BuildMsg msg -> do
-                  log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
+                  putLogMsg dflags NoReason SevInfo noSrcSpan
+                     (defaultUserStyle dflags) msg
                   loop chan hProcess t p exitcode
                 BuildError loc msg -> do
-                  log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
+                  putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
+                     (defaultUserStyle dflags) msg
                   loop chan hProcess t p exitcode
                 EOF ->
                   loop chan hProcess (t-1) p exitcode
@@ -1364,8 +1445,8 @@ traceCmd dflags phase_name cmd_line action
         }
   where
     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
-                              ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
-                              ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
+                              ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn))
+                              ; throwGhcExceptionIO (ProgramError (show exn))}
 
 {-
 ************************************************************************
@@ -1380,7 +1461,7 @@ traceCmd dflags phase_name cmd_line action
 
 getBaseDir :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
--- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
+-- Assuming we are running ghc, accessed by path  $(stuff)/<foo>/ghc.exe,
 -- return the path $(stuff)/lib.
 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
   where
@@ -1388,9 +1469,24 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
         ret <- c_GetModuleFileName nullPtr buf size
         case ret of
           0 -> return Nothing
-          _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+          _ | ret < size -> do
+                path <- peekCWString buf
+                real <- getFinalPath path -- try to resolve symlinks paths
+                let libdir = (rootDir . sanitize . maybe path id) real
+                exists <- doesDirectoryExist libdir
+                if exists
+                   then return $ Just libdir
+                   else fail path
             | otherwise  -> try_size (size * 2)
 
+    -- getFinalPath returns paths in full raw form.
+    -- Unfortunately GHC isn't set up to handle these
+    -- So if the call succeeded, we need to drop the
+    -- \\?\ prefix.
+    sanitize s = if "\\\\?\\" `isPrefixOf` s
+                    then drop 4 s
+                    else s
+
     rootDir s = case splitFileName $ normalise s of
                 (d, ghc_exe)
                  | lower ghc_exe `elem` ["ghc.exe",
@@ -1399,19 +1495,51 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
                                          "ghc-stage3.exe"] ->
                     case splitFileName $ takeDirectory d of
                     -- 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
+                    (d', _) -> takeDirectory d' </> "lib"
+                _ -> fail s
+
+    fail s = 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
+
+-- Attempt to resolve symlinks in order to find the actual location GHC
+-- is located at. See Trac #11759.
+getFinalPath :: FilePath -> IO (Maybe FilePath)
+getFinalPath name = do
+    dllHwnd <- failIfNull "LoadLibray"     $ loadLibrary "kernel32.dll"
+    -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista.
+    -- This means that we can't bind directly to it since it may be missing.
+    -- Instead try to find it's address at runtime and if we don't succeed consider the
+    -- function failed.
+    addr_m  <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")
+                  `catch` (\(_ :: SomeException) -> return Nothing)
+    case addr_m of
+      Nothing   -> return Nothing
+      Just addr -> do handle  <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"
+                                        $ createFile name
+                                                     gENERIC_READ
+                                                     fILE_SHARE_READ
+                                                     Nothing
+                                                     oPEN_EXISTING
+                                                     (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
+                                                     Nothing
+                      let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
+                      path    <- Win32.try "GetFinalPathName"
+                                    (\buf len -> fnPtr handle buf len 0) 512
+                                    `finally` closeHandle handle
+                      return $ Just path
+
+type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
+
+foreign import WINDOWS_CCONV unsafe "dynamic"
+  makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
 #else
 getBaseDir = return Nothing
 #endif
 
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS)
 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 #else
 getProcessID :: IO Int
@@ -1436,7 +1564,16 @@ linesPlatform xs =
 
 #endif
 
-linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO ()
+{-
+Note [No PIE eating while linking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by
+default in their gcc builds. This is incompatible with -r as it implies that we
+are producing an executable. Consequently, we must manually pass -no-pie to gcc
+when joining object files or linking dynamic libraries. See #12759.
+-}
+
+linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
 linkDynLib dflags0 o_files dep_packages
  = do
     let -- This is a rather ugly hack to fix dynamically linked
@@ -1456,14 +1593,15 @@ linkDynLib dflags0 o_files dep_packages
 
     pkgs <- getPreloadPackagesAnd dflags dep_packages
 
-    let pkg_lib_paths = collectLibraryPaths pkgs
+    let pkg_lib_paths = collectLibraryPaths dflags pkgs
     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
         get_pkg_lib_path_opts l
          | ( osElfTarget (platformOS (targetPlatform dflags)) ||
              osMachOTarget (platformOS (targetPlatform dflags)) ) &&
            dynLibLoader dflags == SystemDependent &&
-           not (gopt Opt_Static dflags)
-            = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
+           WayDyn `elem` ways dflags
+            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
+              -- See Note [-Xlinker -rpath vs -Wl,-rpath]
          | otherwise = ["-L" ++ l]
 
     let lib_paths = libraryPaths dflags
@@ -1482,7 +1620,7 @@ linkDynLib dflags0 o_files dep_packages
                       OSMinGW32 ->
                           pkgs
                       _ ->
-                          filter ((/= rtsPackageKey) . packageConfigId) pkgs
+                          filter ((/= rtsUnitId) . packageConfigId) pkgs
     let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
                         in  package_hs_libs ++ extra_libs ++ other_flags
 
@@ -1490,6 +1628,11 @@ linkDynLib dflags0 o_files dep_packages
         -- and last temporary shared object file
     let extra_ld_inputs = ldInputs dflags
 
+    -- frameworks
+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform
+                                              (map unitId pkgs)
+    let framework_opts = getFrameworkOpts dflags platform
+
     case os of
         OSMinGW32 -> do
             -------------------------------------------------------------
@@ -1520,7 +1663,7 @@ linkDynLib dflags0 o_files dep_packages
                  ++ pkg_lib_path_opts
                  ++ pkg_link_opts
                 ))
-        OSDarwin -> do
+        _ | os `elem` [OSDarwin, OSiOS] -> do
             -------------------------------------------------------------------
             -- Making a darwin dylib
             -------------------------------------------------------------------
@@ -1575,30 +1718,30 @@ linkDynLib dflags0 o_files dep_packages
                  ++ [ Option "-install_name", Option instName ]
                  ++ map Option lib_path_opts
                  ++ extra_ld_inputs
+                 ++ map Option framework_opts
                  ++ map Option pkg_lib_path_opts
                  ++ map Option pkg_link_opts
+                 ++ map Option pkg_framework_opts
               )
-        OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
         _ -> do
             -------------------------------------------------------------------
             -- Making a DSO
             -------------------------------------------------------------------
 
             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
-            let buildingRts = thisPackage dflags == rtsPackageKey
-            let bsymbolicFlag = if buildingRts
-                                then -- -Bsymbolic breaks the way we implement
-                                     -- hooks in the RTS
-                                     []
-                                else -- we need symbolic linking to resolve
-                                     -- non-PIC intra-package-relocations
-                                     ["-Wl,-Bsymbolic"]
+            let bsymbolicFlag = -- we need symbolic linking to resolve
+                                -- non-PIC intra-package-relocations
+                                ["-Wl,-Bsymbolic"]
 
             runLink dflags (
                     map Option verbFlags
                  ++ [ Option "-o"
                     , FileOption "" output_fn
                     ]
+                    -- See Note [No PIE eating when linking]
+                 ++ (if sGccSupportsNoPie (settings dflags)
+                     then [Option "-no-pie"]
+                     else [])
                  ++ map Option o_files
                  ++ [ Option "-shared" ]
                  ++ map Option bsymbolicFlag
@@ -1610,3 +1753,31 @@ linkDynLib dflags0 o_files dep_packages
                  ++ map Option pkg_lib_path_opts
                  ++ map Option pkg_link_opts
               )
+
+getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]
+getPkgFrameworkOpts dflags platform dep_packages
+  | platformUsesFrameworks platform = do
+    pkg_framework_path_opts <- do
+        pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
+        return $ map ("-F" ++) pkg_framework_paths
+
+    pkg_framework_opts <- do
+        pkg_frameworks <- getPackageFrameworks dflags dep_packages
+        return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
+
+    return (pkg_framework_path_opts ++ pkg_framework_opts)
+
+  | otherwise = return []
+
+getFrameworkOpts :: DynFlags -> Platform -> [String]
+getFrameworkOpts dflags platform
+  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
+  | otherwise = []
+  where
+    framework_paths     = frameworkPaths dflags
+    framework_path_opts = map ("-F" ++) framework_paths
+
+    frameworks     = cmdlineFrameworks dflags
+    -- reverse because they're added in reverse order from the cmd line:
+    framework_opts = concat [ ["-framework", fw]
+                            | fw <- reverse frameworks ]