SysTools.hs 71 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
{-
2
-----------------------------------------------------------------------------
3
--
4
-- (c) The University of Glasgow 2001-2003
5
--
6
-- Access to system tools: gcc, cp, rm etc
7 8
--
-----------------------------------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
9
-}
10

11 12
{-# LANGUAGE CPP, ScopedTypeVariables #-}

13
module SysTools (
Ian Lynagh's avatar
Ian Lynagh committed
14 15 16 17 18 19
        -- Initialisation
        initSysTools,

        -- Interface to system tools
        runUnlit, runCpp, runCc, -- [Option] -> IO ()
        runPp,                   -- [Option] -> IO ()
20
        runSplit,                -- [Option] -> IO ()
21
        runAs, runLink, runLibtool, -- [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
22
        runMkDLL,
23
        runWindres,
24 25
        runLlvmOpt,
        runLlvmLlc,
26
        runClang,
27
        figureLlvmVersion,
28

29
        getLinkerInfo,
Austin Seipp's avatar
Austin Seipp committed
30
        getCompilerInfo,
31

32 33
        linkDynLib,

34 35
        askCc,

Ian Lynagh's avatar
Ian Lynagh committed
36 37
        touch,                  -- String -> String -> IO ()
        copy,
38
        copyWithHeader,
39

Ian Lynagh's avatar
Ian Lynagh committed
40 41
        -- Temporary-file management
        setTmpDir,
Peter Trommler's avatar
Peter Trommler committed
42
        newTempName, newTempLibName,
Ian Lynagh's avatar
Ian Lynagh committed
43 44 45
        cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
        addFilesToClean,

46 47 48 49 50 51
        Option(..),

        -- frameworks
        getPkgFrameworkOpts,
        getFrameworkOpts

52 53 54

 ) where

55 56
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
57
import DriverPhases
58 59
import Module
import Packages
60
import Config
61
import Outputable
Simon Marlow's avatar
Simon Marlow committed
62 63
import ErrUtils
import Panic
64
import Platform
Simon Marlow's avatar
Simon Marlow committed
65 66
import Util
import DynFlags
67
import Exception
68

69 70
import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)

Simon Marlow's avatar
Simon Marlow committed
71 72 73 74
import Data.IORef
import Control.Monad
import System.Exit
import System.Environment
Ian Lynagh's avatar
Ian Lynagh committed
75
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
76
import System.IO
77
import System.IO.Error as IO
Simon Marlow's avatar
Simon Marlow committed
78
import System.Directory
79
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
80
import Data.List
81
import qualified Data.Map as Map
82

83
#ifndef mingw32_HOST_OS
84
import qualified System.Posix.Internals
85
#else /* Must be Win32 */
sof's avatar
sof committed
86
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
87
import Foreign.C.String
88 89 90 91 92 93 94 95
import qualified System.Win32.Info as Info
import Control.Exception (finally)
import Foreign.Ptr (FunPtr, castPtrToFunPtr)
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)
import Data.Bits((.|.))
rrt's avatar
rrt committed
96 97
#endif

98
import System.Process
Ian Lynagh's avatar
Ian Lynagh committed
99
import Control.Concurrent
100
import FastString
101
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
102 103 104 105 106 107 108 109 110 111

#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
112

Austin Seipp's avatar
Austin Seipp committed
113
{-
114 115
How GHC finds its files
~~~~~~~~~~~~~~~~~~~~~~~
116

117
[Note topdir]
118 119

GHC needs various support files (library packages, RTS etc), plus
Ian Lynagh's avatar
Ian Lynagh committed
120 121
various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
the root of GHC's support files
122

123 124
On Unix:
  - ghc always has a shell wrapper that passes a -B<dir> option
125

126 127 128
On Windows:
  - ghc never has a shell wrapper.
  - we can find the location of the ghc binary, which is
Ian Lynagh's avatar
Ian Lynagh committed
129 130 131
        $topdir/bin/<something>.exe
    where <something> may be "ghc", "ghc-stage2", or similar
  - we strip off the "bin/<something>.exe" to leave $topdir.
132

Ian Lynagh's avatar
Ian Lynagh committed
133
from topdir we can find package.conf, ghc-asm, etc.
134 135 136 137 138 139 140 141 142


SysTools.initSysProgs figures out exactly where all the auxiliary programs
are, and initialises mutable variables to make it easy to call them.
To to this, it makes use of definitions in Config.hs, which is a Haskell
file containing variables whose value is figured out by the build system.

Config.hs contains two sorts of things

Ian Lynagh's avatar
Ian Lynagh committed
143 144 145 146 147
  cGCC,         The *names* of the programs
  cCPP            e.g.  cGCC = gcc
  cUNLIT                cCPP = gcc -E
  etc           They do *not* include paths

148

Ian Lynagh's avatar
Ian Lynagh committed
149 150
  cUNLIT_DIR   The *path* to the directory containing unlit, split etc
  cSPLIT_DIR   *relative* to the root of the build tree,
Ian Lynagh's avatar
Ian Lynagh committed
151 152
                   for use when running *in-place* in a build tree (only)

153 154


155 156 157 158 159 160 161 162 163 164 165 166 167 168
---------------------------------------------
NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):

Another hair-brained scheme for simplifying the current tool location
nightmare in GHC: Simon originally suggested using another
configuration file along the lines of GCC's specs file - which is fine
except that it means adding code to read yet another configuration
file.  What I didn't notice is that the current package.conf is
general enough to do this:

Package
    {name = "tools",    import_dirs = [],  source_dirs = [],
     library_dirs = [], hs_libraries = [], extra_libraries = [],
     include_dirs = [], c_includes = [],   package_deps = [],
169
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
170 171 172 173 174
     extra_cc_opts = [], extra_ld_opts = []}

Which would have the advantage that we get to collect together in one
place the path-specific package stuff with the path-specific tool
stuff.
Ian Lynagh's avatar
Ian Lynagh committed
175
                End of NOTES
176 177
---------------------------------------------

Austin Seipp's avatar
Austin Seipp committed
178 179
************************************************************************
*                                                                      *
180
\subsection{Initialisation}
Austin Seipp's avatar
Austin Seipp committed
181 182 183
*                                                                      *
************************************************************************
-}
184

Ian Lynagh's avatar
Ian Lynagh committed
185
initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
186
             -> IO Settings     -- Set all the mutable variables above, holding
Ian Lynagh's avatar
Ian Lynagh committed
187 188 189
                                --      (a) the system programs
                                --      (b) the package-config file
                                --      (c) the GHC usage message
190
initSysTools mbMinusB
191 192 193 194 195 196
  = do top_dir <- findTopDir mbMinusB
             -- see [Note topdir]
             -- NB: top_dir is assumed to be in standard Unix
             -- format, '/' separated

       let settingsFile = top_dir </> "settings"
197
           platformConstantsFile = top_dir </> "platformConstants"
198 199
           installed :: FilePath -> FilePath
           installed file = top_dir </> file
200 201
           libexec :: FilePath -> FilePath
           libexec file = top_dir </> "bin" </> file
202 203

       settingsStr <- readFile settingsFile
204
       platformConstantsStr <- readFile platformConstantsFile
205 206 207 208 209
       mySettings <- case maybeReadFuzzy settingsStr of
                     Just s ->
                         return s
                     Nothing ->
                         pgmError ("Can't parse " ++ show settingsFile)
210 211 212 213 214 215
       platformConstants <- case maybeReadFuzzy platformConstantsStr of
                            Just s ->
                                return s
                            Nothing ->
                                pgmError ("Can't parse " ++
                                          show platformConstantsFile)
216 217 218 219 220 221 222 223 224 225 226
       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)
227 228 229 230 231
           getBooleanSetting key = case lookup key mySettings of
                                   Just "YES" -> return True
                                   Just "NO" -> return False
                                   Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
                                   Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
232 233 234 235 236 237
           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)
238
       crossCompiling <- getBooleanSetting "cross compiling"
239 240 241
       targetArch <- readSetting "target arch"
       targetOS <- readSetting "target os"
       targetWordSize <- readSetting "target word size"
242
       targetUnregisterised <- getBooleanSetting "Unregisterised"
243 244 245 246 247 248 249 250 251 252 253
       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"
Ben Gamari's avatar
Ben Gamari committed
254
       gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
255 256
       cpp_prog <- getSetting "Haskell CPP command"
       cpp_args_str <- getSetting "Haskell CPP flags"
257 258 259
       let unreg_gcc_args = if targetUnregisterised
                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
                            else []
260 261
           -- TABLES_NEXT_TO_CODE affects the info table layout.
           tntc_gcc_args
262 263 264
            | mkTablesNextToCode targetUnregisterised
               = ["-DTABLES_NEXT_TO_CODE"]
            | otherwise = []
265
           cpp_args= map Option (words cpp_args_str)
266 267 268
           gcc_args = map Option (words gcc_args_str
                               ++ unreg_gcc_args
                               ++ tntc_gcc_args)
269 270
       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
271
       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
272
       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
273 274 275 276 277 278 279 280
       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
281
           unlit_path = libexec cGHC_UNLIT_PGM
282 283

             -- split is a Perl script
284
           split_script  = libexec cGHC_SPLIT_PGM
285 286

       windres_path <- getSetting "windres command"
287
       libtool_path <- getSetting "libtool command"
288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307

       tmpdir <- getTemporaryDirectory

       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
           -- to wire-in our knowledge of $(PERL) on the host system here.
           (split_prog,  split_args)
             | isWindowsHost = (perl_path,    [Option split_script])
             | otherwise     = (split_script, [])
       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.
308

309 310

       -- Other things being equal, as and ld are simply gcc
311
       gcc_link_args_str <- getSetting "C compiler link flags"
312 313 314
       let   as_prog  = gcc_prog
             as_args  = gcc_args
             ld_prog  = gcc_prog
315
             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)
316 317 318 319 320

       -- We just assume on command line
       lc_prog <- getSetting "LLVM llc command"
       lo_prog <- getSetting "LLVM opt command"

321 322
       let iserv_prog = libexec "ghc-iserv"

323 324 325 326
       let platform = Platform {
                          platformArch = targetArch,
                          platformOS   = targetOS,
                          platformWordSize = targetWordSize,
327
                          platformUnregisterised = targetUnregisterised,
328 329
                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,
                          platformHasIdentDirective = targetHasIdentDirective,
330 331
                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
                          platformIsCrossCompiling = crossCompiling
332 333 334 335 336 337 338 339 340 341 342
                      }

       return $ Settings {
                    sTargetPlatform = platform,
                    sTmpDir         = normalise tmpdir,
                    sGhcUsagePath   = ghc_usage_msg_path,
                    sGhciUsagePath  = ghci_usage_msg_path,
                    sTopDir         = top_dir,
                    sRawSettings    = mySettings,
                    sExtraGccViaCFlags = words myExtraGccViaCFlags,
                    sSystemPackageConfig = pkgconfig_path,
343 344
                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
                    sLdSupportsBuildId       = ldSupportsBuildId,
345
                    sLdSupportsFilelist      = ldSupportsFilelist,
346
                    sLdIsGnuLd               = ldIsGnuLd,
Ben Gamari's avatar
Ben Gamari committed
347
                    sGccSupportsNoPie        = gccSupportsNoPie,
348 349
                    sProgramName             = "ghc",
                    sProjectVersion          = cProjectVersion,
350 351 352 353 354 355 356 357 358 359
                    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_windres = windres_path,
360
                    sPgm_libtool = libtool_path,
361 362
                    sPgm_lo  = (lo_prog,[]),
                    sPgm_lc  = (lc_prog,[]),
363
                    sPgm_i   = iserv_prog,
364 365 366 367 368 369 370 371
                    sOpt_L       = [],
                    sOpt_P       = [],
                    sOpt_F       = [],
                    sOpt_c       = [],
                    sOpt_a       = [],
                    sOpt_l       = [],
                    sOpt_windres = [],
                    sOpt_lo      = [],
372
                    sOpt_lc      = [],
373
                    sOpt_i       = [],
374
                    sPlatformConstants = platformConstants
375
             }
376

Ian Lynagh's avatar
Ian Lynagh committed
377 378 379 380 381 382 383 384 385
-- 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
386
             Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
Ian Lynagh's avatar
Ian Lynagh committed
387
             Just dir -> return dir
388

Austin Seipp's avatar
Austin Seipp committed
389 390 391
{-
************************************************************************
*                                                                      *
392
\subsection{Running an external program}
Austin Seipp's avatar
Austin Seipp committed
393 394 395
*                                                                      *
************************************************************************
-}
396

397
runUnlit :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
398
runUnlit dflags args = do
399 400 401 402
  let prog = pgm_L dflags
      opts = getOpts dflags opt_L
  runSomething dflags "Literate pre-processor" prog
               (map Option opts ++ args)
403 404

runCpp :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
405
runCpp dflags args =   do
406
  let (p,args0) = pgm_P dflags
407
      args1 = map Option (getOpts dflags opt_P)
408 409
      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
410
  mb_env <- getGccEnv args2
411 412
  runSomethingFiltered dflags id  "C pre-processor" p
                       (args0 ++ args1 ++ args2 ++ args) mb_env
413 414

runPp :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
415
runPp dflags args =   do
416 417
  let prog = pgm_F dflags
      opts = map Option (getOpts dflags opt_F)
418
  runSomething dflags "Haskell pre-processor" prog (args ++ opts)
419 420

runCc :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
421
runCc dflags args =   do
422
  let (p,args0) = pgm_c dflags
423 424 425
      args1 = map Option (getOpts dflags opt_c)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
426
  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
427 428
 where
  -- discard some harmless warnings from gcc that we can't turn off
429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479
  cc_filter = unlines . doFilter . lines

  {-
  gcc gives warnings in chunks like so:
      In file included from /foo/bar/baz.h:11,
                       from /foo/bar/baz2.h:22,
                       from wibble.c:33:
      /foo/flibble:14: global register variable ...
      /foo/flibble:15: warning: call-clobbered r...
  We break it up into its chunks, remove any call-clobbered register
  warnings from each chunk, and then delete any chunks that we have
  emptied of warnings.
  -}
  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
  -- We can't assume that the output will start with an "In file inc..."
  -- line, so we start off expecting a list of warnings rather than a
  -- location stack.
  chunkWarnings :: [String] -- The location stack to use for the next
                            -- list of warnings
                -> [String] -- The remaining lines to look at
                -> [([String], [String])]
  chunkWarnings loc_stack [] = [(loc_stack, [])]
  chunkWarnings loc_stack xs
      = case break loc_stack_start xs of
        (warnings, lss:xs') ->
            case span loc_start_continuation xs' of
            (lsc, xs'') ->
                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
        _ -> [(loc_stack, xs)]

  filterWarnings :: [([String], [String])] -> [([String], [String])]
  filterWarnings [] = []
  -- If the warnings are already empty then we are probably doing
  -- something wrong, so don't delete anything
  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
                                       [] -> filterWarnings zs
                                       ys' -> (xs, ys') : filterWarnings zs

  unChunkWarnings :: [([String], [String])] -> [String]
  unChunkWarnings [] = []
  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs

  loc_stack_start        s = "In file included from " `isPrefixOf` s
  loc_start_continuation s = "                 from " `isPrefixOf` s
  wantedWarning w
   | "warning: call-clobbered register used" `isContainedIn` w = False
   | otherwise = True

isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
480

481 482 483
askCc :: DynFlags -> [Option] -> IO String
askCc dflags args = do
  let (p,args0) = pgm_c dflags
484 485 486 487
      args1 = map Option (getOpts dflags opt_c)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
  runSomethingWith dflags "gcc" p args2 $ \real_args ->
thomie's avatar
thomie committed
488
    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
489

thomie's avatar
thomie committed
490 491 492
-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
-- inherited from the parent process, and output to stderr is not captured.
readCreateProcessWithExitCode'
493 494
    :: CreateProcess
    -> IO (ExitCode, String)    -- ^ stdout
thomie's avatar
thomie committed
495
readCreateProcessWithExitCode' proc = do
496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512
    (_, 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)

513 514 515 516 517 518
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.
519 520 521
readProcessEnvWithExitCode
    :: String -- ^ program path
    -> [String] -- ^ program args
522
    -> (String, String) -- ^ addition to the environment
523 524 525
    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
readProcessEnvWithExitCode prog args env_update = do
    current_env <- getEnvironment
526 527
    readCreateProcessWithExitCode (proc prog args) {
        env = Just (replaceVar env_update current_env) } ""
528 529

-- Don't let gcc localize version info string, #8825
530 531
c_locale_env :: (String, String)
c_locale_env = ("LANGUAGE", "C")
532

533 534 535 536
-- 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).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
Ian Lynagh's avatar
Ian Lynagh committed
537
getGccEnv opts =
538
  if null b_dirs
539
     then return Nothing
540
     else do env <- getEnvironment
541
             return (Just (map mangle_path env))
542
 where
543
  (b_dirs, _) = partitionWith get_b_opt opts
544 545

  get_b_opt (Option ('-':'B':dir)) = Left dir
Ian Lynagh's avatar
Ian Lynagh committed
546
  get_b_opt other = Right other
547

Ian Lynagh's avatar
Ian Lynagh committed
548
  mangle_path (path,paths) | map toUpper path == "PATH"
549
        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
550
  mangle_path other = other
551

552
runSplit :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
553
runSplit dflags args = do
554
  let (p,args0) = pgm_s dflags
555 556 557
  runSomething dflags "Splitter" p (args0++args)

runAs :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
558
runAs dflags args = do
559
  let (p,args0) = pgm_a dflags
560 561 562 563
      args1 = map Option (getOpts dflags opt_a)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags id "Assembler" p args2 mb_env
564

565
-- | Run the LLVM Optimiser
566 567 568
runLlvmOpt :: DynFlags -> [Option] -> IO ()
runLlvmOpt dflags args = do
  let (p,args0) = pgm_lo dflags
569 570
      args1 = map Option (getOpts dflags opt_lo)
  runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)
571

572
-- | Run the LLVM Compiler
573 574 575
runLlvmLlc :: DynFlags -> [Option] -> IO ()
runLlvmLlc dflags args = do
  let (p,args0) = pgm_lc dflags
576 577
      args1 = map Option (getOpts dflags opt_lc)
  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
578

579 580 581 582 583 584 585
-- | 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"
586 587 588
      -- be careful what options we call clang with
      -- see #5903 and #7617 for bugs caused by this.
      (_,args0) = pgm_a dflags
589 590 591
      args1 = map Option (getOpts dflags opt_a)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
592
  Exception.catch (do
593
        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
594 595
    )
    (\(err :: SomeException) -> do
596 597
        errorMsg dflags $
            text ("Error running clang! you need clang installed to use the" ++
598
                  " LLVM backend") $+$
599
            text "(or GHC tried to execute clang incorrectly)"
600
        throwIO err
601 602
    )

603
-- | Figure out which version of LLVM we are running this session
604
figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
605 606 607 608 609 610 611 612 613 614 615
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
dterei's avatar
dterei committed
616
             {- > llc -version
617 618
                  LLVM (http://llvm.org/):
                    LLVM version 3.5.2
619 620 621 622
                    ...
             -}
             hSetBinaryMode pout False
             _     <- hGetLine pout
623 624 625 626 627 628
             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)

629 630 631 632 633 634
             hClose pin
             hClose pout
             hClose perr
             return $ Just v
            )
            (\err -> do
635 636 637
                debugTraceMsg dflags 2
                    (text "Error (figuring out LLVM version):" <+>
                     text (show err))
638
                errorMsg dflags $ vcat
639 640
                    [ text "Warning:", nest 9 $
                          text "Couldn't figure out LLVM version!" $$
641 642
                          text ("Make sure you have installed LLVM " ++
                                llvmVersionStr supportedLlvmVersion) ]
643 644
                return Nothing)
  return ver
645

Austin Seipp's avatar
Austin Seipp committed
646 647
{- Note [Windows stack usage]

648
See: Trac #8870 (and #8834 for related info) and #12186
Austin Seipp's avatar
Austin Seipp committed
649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668

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
catch on Windows.

If the stack pointer is bumped by more than a single page, then the
pages between the initial pointer and the resulting location must be
properly committed by the Windows virtual memory subsystem. This is
only needed in the event we bump by more than one page (i.e 4097 bytes
or more).

Windows compilers solve this by emitting a call to a special function
called _chkstk, which does this committing of the pages for you.

The reason this was causing a segfault was because due to the fact the
new code generator tends to generate larger functions, we needed more
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.

669 670
GCC can emit such a check for us automatically but only when the flag
-fstack-check is used.
Austin Seipp's avatar
Austin Seipp committed
671

672 673
See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html
for more information.
Austin Seipp's avatar
Austin Seipp committed
674 675

-}
676 677 678

{- Note [Run-time linker info]

679
See also: Trac #5240, Trac #6063, Trac #10110
680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705

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
options. For example, GNU ld requires '--reduce-memory-overheads' and
'--hash-size=31' in order to use reasonable amounts of memory (see
trac #5240.) But this isn't supported in GNU gold.

Generally, the linker changing from what was detected at ./configure
time has always been possible using -pgml, but on Linux it can happen
'transparently' by installing packages like binutils-gold, which
change what /usr/bin/ld actually points to.

Clang vs GCC notes:

For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
invoke the linker before the version information string. For 'clang',
the version information for 'ld' is all that's output. For this
reason, we typically need to slurp up all of the standard error output
and look through it.

Other notes:

We cache the LinkerInfo inside DynFlags, since clients may link
multiple times. The definition of LinkerInfo is there to avoid a
circular dependency.

706 707 708 709
-}

{- Note [ELF needed shared libs]

710 711 712 713 714 715 716
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.

717 718
The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
(Mach-O) the flag is not needed.
719

720
-}
721

722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745
{- 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’. "

-}

746 747 748 749
neededLinkArgs :: LinkerInfo -> [Option]
neededLinkArgs (GnuLD o)     = o
neededLinkArgs (GnuGold o)   = o
neededLinkArgs (DarwinLD o)  = o
750
neededLinkArgs (SolarisLD o) = o
751
neededLinkArgs (AixLD o)     = o
752 753 754 755 756
neededLinkArgs UnknownLD     = []

-- Grab linker info and cache it in DynFlags.
getLinkerInfo :: DynFlags -> IO LinkerInfo
getLinkerInfo dflags = do
Austin Seipp's avatar
Austin Seipp committed
757
  info <- readIORef (rtldInfo dflags)
758 759 760 761
  case info of
    Just v  -> return v
    Nothing -> do
      v <- getLinkerInfo' dflags
Austin Seipp's avatar
Austin Seipp committed
762
      writeIORef (rtldInfo dflags) (Just v)
763 764 765 766 767 768 769
      return v

-- See Note [Run-time linker info].
getLinkerInfo' :: DynFlags -> IO LinkerInfo
getLinkerInfo' dflags = do
  let platform = targetPlatform dflags
      os = platformOS platform
770 771 772 773
      (pgm,args0) = pgm_l dflags
      args1     = map Option (getOpts dflags opt_l)
      args2     = args0 ++ args1
      args3     = filter notNull (map showOpt args2)
774 775 776 777 778 779

      -- Try to grab the info from the process output.
      parseLinkerInfo stdo _stde _exitc
        | any ("GNU ld" `isPrefixOf`) stdo =
          -- GNU ld specifically needs to use less memory. This especially
          -- hurts on small object files. Trac #5240.
780
          -- Set DT_NEEDED for all shared libraries. Trac #10110.
781
          -- TODO: Investigate if these help or hurt when using split sections.
782
          return (GnuLD $ map Option ["-Wl,--hash-size=31",
783
                                      "-Wl,--reduce-memory-overheads",
784 785
                                      -- ELF specific flag
                                      -- see Note [ELF needed shared libs]
786
                                      "-Wl,--no-as-needed"])
787 788

        | any ("GNU gold" `isPrefixOf`) stdo =
789
          -- GNU gold only needs --no-as-needed. Trac #10110.
790
          -- ELF specific flag, see Note [ELF needed shared libs]
791
          return (GnuGold [Option "-Wl,--no-as-needed"])
792 793 794 795 796 797 798

         -- Unknown linker.
        | otherwise = fail "invalid --version output, or linker is unsupported"

  -- Process the executable call
  info <- catchIO (do
             case os of
799 800
               OSSolaris2 ->
                 -- Solaris uses its own Solaris linker. Even all
Gabor Greif's avatar
Gabor Greif committed
801
                 -- GNU C are recommended to configure with Solaris
802 803 804 805 806
                 -- linker instead of using GNU binutils linker. Also
                 -- all GCC distributed with Solaris follows this rule
                 -- precisely so we assume here, the Solaris linker is
                 -- used.
                 return $ SolarisLD []
807 808 809
               OSAIX ->
                 -- IBM AIX uses its own non-binutils linker as well
                 return $ AixLD []
810 811 812 813 814
               OSDarwin ->
                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
                 -- that doesn't support --version. We can just assume that's
                 -- what we're using.
                 return $ DarwinLD []
Austin Seipp's avatar
Austin Seipp committed
815
               OSiOS ->
816 817
                 -- Ditto for iOS
                 return $ DarwinLD []
818 819 820 821
               OSMinGW32 ->
                 -- GHC doesn't support anything but GNU ld on Windows anyway.
                 -- Process creation is also fairly expensive on win32, so
                 -- we short-circuit here.
Austin Seipp's avatar
Austin Seipp committed
822 823 824 825
                 return $ GnuLD $ map Option
                   [ -- Reduce ld memory usage
                     "-Wl,--hash-size=31"
                   , "-Wl,--reduce-memory-overheads"
826
                     -- Emit gcc stack checks
Austin Seipp's avatar
Austin Seipp committed
827
                     -- Note [Windows stack usage]
828
                   , "-fstack-check"
829 830
                     -- Force static linking of libGCC
                     -- Note [Windows static libGCC]
831
                   , "-static-libgcc" ]
832 833 834
               _ -> do
                 -- In practice, we use the compiler as the linker here. Pass
                 -- -Wl,--version to get linker version info.
835
                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
836
                                        (["-Wl,--version"] ++ args3)
837
                                        c_locale_env
838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853
                 -- 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
                 -- it's still easy to figure out.
                 parseLinkerInfo (lines stdo) (lines stde) exitc
            )
            (\err -> do
                debugTraceMsg dflags 2
                    (text "Error (figuring out linker information):" <+>
                     text (show err))
                errorMsg dflags $ hang (text "Warning:") 9 $
                  text "Couldn't figure out linker information!" $$
                  text "Make sure you're using GNU ld, GNU gold" <+>
                  text "or the built in OS X linker, etc."
                return UnknownLD)
  return info
854

Austin Seipp's avatar
Austin Seipp committed
855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872
-- Grab compiler info and cache it in DynFlags.
getCompilerInfo :: DynFlags -> IO CompilerInfo
getCompilerInfo dflags = do
  info <- readIORef (rtccInfo dflags)
  case info of
    Just v  -> return v
    Nothing -> do
      v <- getCompilerInfo' dflags
      writeIORef (rtccInfo dflags) (Just v)
      return v

-- See Note [Run-time linker info].
getCompilerInfo' :: DynFlags -> IO CompilerInfo
getCompilerInfo' dflags = do
  let (pgm,_) = pgm_c dflags
      -- Try to grab the info from the process output.
      parseCompilerInfo _stdo stde _exitc
        -- Regular GCC
873
        | any ("gcc version" `isInfixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
874 875
          return GCC
        -- Regular clang
876
        | any ("clang version" `isInfixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
877
          return Clang
Austin Seipp's avatar
Austin Seipp committed
878 879 880
        -- XCode 5.1 clang
        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
          return AppleClang51
Austin Seipp's avatar
Austin Seipp committed
881 882
        -- XCode 5 clang
        | any ("Apple LLVM version" `isPrefixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
883
          return AppleClang
Austin Seipp's avatar
Austin Seipp committed
884 885
        -- XCode 4.1 clang
        | any ("Apple clang version" `isPrefixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
886
          return AppleClang
Austin Seipp's avatar
Austin Seipp committed
887 888 889 890 891
         -- Unknown linker.
        | otherwise = fail "invalid -v output, or compiler is unsupported"

  -- Process the executable call
  info <- catchIO (do
892
                (exitc, stdo, stde) <-
893
                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env
Austin Seipp's avatar
Austin Seipp committed
894 895 896 897 898 899
                -- Split the output by lines to make certain kinds
                -- of processing easier.
                parseCompilerInfo (lines stdo) (lines stde) exitc
            )
            (\err -> do
                debugTraceMsg dflags 2
900
                    (text "Error (figuring out C compiler information):" <+>
Austin Seipp's avatar
Austin Seipp committed
901 902
                     text (show err))
                errorMsg dflags $ hang (text "Warning:") 9 $
903
                  text "Couldn't figure out C compiler information!" $$
Austin Seipp's avatar
Austin Seipp committed
904 905 906 907
                  text "Make sure you're using GNU gcc, or clang"
                return UnknownCC)
  return info

908
runLink :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
909
runLink dflags args = do
910 911
  -- See Note [Run-time linker info]
  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
912
  let (p,args0) = pgm_l dflags
913
      args1     = map Option (getOpts dflags opt_l)
914
      args2     = args0 ++ linkargs ++ args1 ++ args
Simon Marlow's avatar
Simon Marlow committed
915 916
  mb_env <- getGccEnv args2
  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
917 918 919 920 921 922
  where
    ld_filter = case (platformOS (targetPlatform dflags)) of
                  OSSolaris2 -> sunos_ld_filter
                  _ -> id
{-
  SunOS/Solaris ld emits harmless warning messages about unresolved
Gabor Greif's avatar
Gabor Greif committed
923
  symbols in case of compiling into shared library when we do not
924 925
  link against all the required libs. That is the case of GHC which
  does not link against RTS library explicitly in order to be able to
Gabor Greif's avatar
Gabor Greif committed
926
  choose the library later based on binary application linking
927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949
  parameters. The warnings look like:

Undefined                       first referenced
 symbol                             in file
stg_ap_n_fast                       ./T2386_Lib.o
stg_upd_frame_info                  ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
newCAF                              ./T2386_Lib.o
stg_bh_upd_frame_info               ./T2386_Lib.o
stg_ap_ppp_fast                     ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
stg_ap_p_fast                       ./T2386_Lib.o
stg_ap_pp_fast                      ./T2386_Lib.o
ld: warning: symbol referencing errors

  this is actually coming from T2386 testcase. The emitting of those
  warnings is also a reason why so many TH testcases fail on Solaris.

  Following filter code is SunOS/Solaris linker specific and should
  filter out only linker warnings. Please note that the logic is a
Gabor Greif's avatar
Gabor Greif committed
950
  little bit more complex due to the simple reason that we need to preserve
951 952
  any other linker emitted messages. If there are any. Simply speaking
  if we see "Undefined" and later "ld: warning:..." then we omit all
Gabor Greif's avatar
Gabor Greif committed
953
  text between (including) the marks. Otherwise we copy the whole output.
954 955 956 957 958 959 960 961 962 963 964 965 966
-}
    sunos_ld_filter :: String -> String
    sunos_ld_filter = unlines . sunos_ld_filter' . lines
    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
                         then (ld_prefix x) ++ (ld_postfix x)
                         else x
    breakStartsWith x y = break (isPrefixOf x) y
    ld_prefix = fst . breakStartsWith "Undefined"
    undefined_found = not . null . snd . breakStartsWith "Undefined"
    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
    ld_postfix = tail . snd . ld_warn_break
    ld_warning_found = not . null . snd . ld_warn_break

967

968 969 970 971 972
runLibtool :: DynFlags -> [Option] -> IO ()
runLibtool dflags args = do
  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
  let args1      = map Option (getOpts dflags opt_l)
      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
Austin Seipp's avatar
Austin Seipp committed
973
      libtool    = pgm_libtool dflags
974 975