SysTools.lhs 53.5 KB
Newer Older
1
-----------------------------------------------------------------------------
2
--
3
-- (c) The University of Glasgow 2001-2003
4
--
5
-- Access to system tools: gcc, cp, rm etc
6 7 8 9 10
--
-----------------------------------------------------------------------------

\begin{code}
module SysTools (
Ian Lynagh's avatar
Ian Lynagh committed
11 12 13 14 15 16
        -- Initialisation
        initSysTools,

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

27 28
        getLinkerInfo,

29 30
        linkDynLib,

31 32
        askCc,

Ian Lynagh's avatar
Ian Lynagh committed
33 34
        touch,                  -- String -> String -> IO ()
        copy,
35
        copyWithHeader,
36

Ian Lynagh's avatar
Ian Lynagh committed
37 38 39 40 41 42 43
        -- Temporary-file management
        setTmpDir,
        newTempName,
        cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
        addFilesToClean,

        Option(..)
44 45 46

 ) where

47 48
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
49
import DriverPhases
50 51
import Module
import Packages
52
import Config
53
import Outputable
Simon Marlow's avatar
Simon Marlow committed
54 55
import ErrUtils
import Panic
56
import Platform
Simon Marlow's avatar
Simon Marlow committed
57 58
import Util
import DynFlags
59
import Exception
60

Simon Marlow's avatar
Simon Marlow committed
61 62 63 64
import Data.IORef
import Control.Monad
import System.Exit
import System.Environment
Ian Lynagh's avatar
Ian Lynagh committed
65
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
66
import System.IO
67
import System.IO.Error as IO
Simon Marlow's avatar
Simon Marlow committed
68
import System.Directory
69
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
70
import Data.List
71
import qualified Data.Map as Map
72 73
import Text.ParserCombinators.ReadP hiding (char)
import qualified Text.ParserCombinators.ReadP as R
74

75
#ifndef mingw32_HOST_OS
76
import qualified System.Posix.Internals
77
#else /* Must be Win32 */
sof's avatar
sof committed
78
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
79
import Foreign.C.String
rrt's avatar
rrt committed
80 81
#endif

82
import System.Process
Ian Lynagh's avatar
Ian Lynagh committed
83
import Control.Concurrent
84
import FastString
85
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
86 87 88 89 90 91 92 93 94 95

#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
96 97
\end{code}

98 99
How GHC finds its files
~~~~~~~~~~~~~~~~~~~~~~~
100

101
[Note topdir]
102 103

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

107 108
On Unix:
  - ghc always has a shell wrapper that passes a -B<dir> option
109

110 111 112
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
113 114 115
        $topdir/bin/<something>.exe
    where <something> may be "ghc", "ghc-stage2", or similar
  - we strip off the "bin/<something>.exe" to leave $topdir.
116

Ian Lynagh's avatar
Ian Lynagh committed
117
from topdir we can find package.conf, ghc-asm, etc.
118 119 120 121 122 123 124 125 126


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
127 128 129 130 131
  cGCC,         The *names* of the programs
  cCPP            e.g.  cGCC = gcc
  cUNLIT                cCPP = gcc -E
  etc           They do *not* include paths

132

Ian Lynagh's avatar
Ian Lynagh committed
133 134
  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
135 136
                   for use when running *in-place* in a build tree (only)

137 138


139 140 141 142 143 144 145 146 147 148 149 150 151 152
---------------------------------------------
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 = [],
153
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
154 155 156 157 158
     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
159
                End of NOTES
160 161
---------------------------------------------

162
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
163
%*                                                                      *
164
\subsection{Initialisation}
Ian Lynagh's avatar
Ian Lynagh committed
165
%*                                                                      *
166 167 168
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
169
initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
170
             -> IO Settings     -- Set all the mutable variables above, holding
Ian Lynagh's avatar
Ian Lynagh committed
171 172 173
                                --      (a) the system programs
                                --      (b) the package-config file
                                --      (c) the GHC usage message
174
initSysTools mbMinusB
175 176 177 178 179 180
  = 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"
181
           platformConstantsFile = top_dir </> "platformConstants"
182 183 184 185
           installed :: FilePath -> FilePath
           installed file = top_dir </> file

       settingsStr <- readFile settingsFile
186
       platformConstantsStr <- readFile platformConstantsFile
187 188 189 190 191
       mySettings <- case maybeReadFuzzy settingsStr of
                     Just s ->
                         return s
                     Nothing ->
                         pgmError ("Can't parse " ++ show settingsFile)
192 193 194 195 196 197
       platformConstants <- case maybeReadFuzzy platformConstantsStr of
                            Just s ->
                                return s
                            Nothing ->
                                pgmError ("Can't parse " ++
                                          show platformConstantsFile)
198 199 200 201 202 203 204 205 206 207 208
       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)
209 210 211 212 213
           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)
214 215 216 217 218 219 220 221 222
           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"
223
       targetUnregisterised <- getBooleanSetting "Unregisterised"
224 225 226 227 228 229 230 231 232 233 234
       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"
235 236 237
       let unreg_gcc_args = if targetUnregisterised
                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
                            else []
238 239
           -- TABLES_NEXT_TO_CODE affects the info table layout.
           tntc_gcc_args
240 241 242 243 244 245
            | mkTablesNextToCode targetUnregisterised
               = ["-DTABLES_NEXT_TO_CODE"]
            | otherwise = []
           gcc_args = map Option (words gcc_args_str
                               ++ unreg_gcc_args
                               ++ tntc_gcc_args)
246 247
       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
248
       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
249
       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
250 251 252 253 254 255 256 257 258 259 260 261 262 263
       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 = installed cGHC_UNLIT_PGM

             -- split is a Perl script
           split_script  = installed cGHC_SPLIT_PGM

       windres_path <- getSetting "windres command"
264
       libtool_path <- getSetting "libtool command"
265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290

       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.
       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
291
       gcc_link_args_str <- getSetting "C compiler link flags"
292 293 294
       let   as_prog  = gcc_prog
             as_args  = gcc_args
             ld_prog  = gcc_prog
295
             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)
296 297 298 299 300 301 302 303 304

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

       let platform = Platform {
                          platformArch = targetArch,
                          platformOS   = targetOS,
                          platformWordSize = targetWordSize,
305
                          platformUnregisterised = targetUnregisterised,
306 307 308 309 310 311 312 313 314 315 316 317 318 319
                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,
                          platformHasIdentDirective = targetHasIdentDirective,
                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
                      }

       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,
320 321
                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
                    sLdSupportsBuildId       = ldSupportsBuildId,
322
                    sLdSupportsFilelist      = ldSupportsFilelist,
323
                    sLdIsGnuLd               = ldIsGnuLd,
324 325 326 327 328 329 330 331 332 333 334
                    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,
335
                    sPgm_libtool = libtool_path,
336 337 338 339 340 341 342 343 344 345 346 347
                    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       = [],
                    sOpt_F       = [],
                    sOpt_c       = [],
                    sOpt_a       = [],
                    sOpt_l       = [],
                    sOpt_windres = [],
                    sOpt_lo      = [],
348 349
                    sOpt_lc      = [],
                    sPlatformConstants = platformConstants
350
             }
351 352
\end{code}

353
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
354 355 356 357 358 359 360 361 362
-- 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
363
             Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
Ian Lynagh's avatar
Ian Lynagh committed
364
             Just dir -> return dir
365 366 367
\end{code}


368
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
369
%*                                                                      *
370
\subsection{Running an external program}
Ian Lynagh's avatar
Ian Lynagh committed
371
%*                                                                      *
372 373 374 375
%************************************************************************


\begin{code}
376
runUnlit :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
377
runUnlit dflags args = do
378 379 380 381
  let prog = pgm_L dflags
      opts = getOpts dflags opt_L
  runSomething dflags "Literate pre-processor" prog
               (map Option opts ++ args)
382 383

runCpp :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
384
runCpp dflags args =   do
385
  let (p,args0) = pgm_P dflags
386
      args1 = map Option (getOpts dflags opt_P)
ian@well-typed.com's avatar
ian@well-typed.com committed
387
      args2 = if gopt Opt_WarnIsError dflags
388 389
                 then [Option "-Werror"]
                 else []
390
  mb_env <- getGccEnv args2
391 392
  runSomethingFiltered dflags id  "C pre-processor" p
                       (args0 ++ args1 ++ args2 ++ args) mb_env
393 394

runPp :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
395
runPp dflags args =   do
396 397 398
  let prog = pgm_F dflags
      opts = map Option (getOpts dflags opt_F)
  runSomething dflags "Haskell pre-processor" prog (opts ++ args)
399 400

runCc :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
401
runCc dflags args =   do
402
  let (p,args0) = pgm_c dflags
403 404 405 406
      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
407 408
 where
  -- discard some harmless warnings from gcc that we can't turn off
409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 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
  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)
460

461 462 463
askCc :: DynFlags -> [Option] -> IO String
askCc dflags args = do
  let (p,args0) = pgm_c dflags
464 465 466 467
      args1 = map Option (getOpts dflags opt_c)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
  runSomethingWith dflags "gcc" p args2 $ \real_args ->
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492
    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)


493 494 495 496
-- 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
497
getGccEnv opts =
498
  if null b_dirs
499
     then return Nothing
500
     else do env <- getEnvironment
501
             return (Just (map mangle_path env))
502
 where
503
  (b_dirs, _) = partitionWith get_b_opt opts
504 505

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

Ian Lynagh's avatar
Ian Lynagh committed
508
  mangle_path (path,paths) | map toUpper path == "PATH"
509
        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
510
  mangle_path other = other
511

512
runSplit :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
513
runSplit dflags args = do
514
  let (p,args0) = pgm_s dflags
515 516 517
  runSomething dflags "Splitter" p (args0++args)

runAs :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
518
runAs dflags args = do
519
  let (p,args0) = pgm_a dflags
520 521 522 523
      args1 = map Option (getOpts dflags opt_a)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags id "Assembler" p args2 mb_env
524

525
-- | Run the LLVM Optimiser
526 527 528
runLlvmOpt :: DynFlags -> [Option] -> IO ()
runLlvmOpt dflags args = do
  let (p,args0) = pgm_lo dflags
529 530
      args1 = map Option (getOpts dflags opt_lo)
  runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)
531

532
-- | Run the LLVM Compiler
533 534 535
runLlvmLlc :: DynFlags -> [Option] -> IO ()
runLlvmLlc dflags args = do
  let (p,args0) = pgm_lc dflags
536 537
      args1 = map Option (getOpts dflags opt_lc)
  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
538

539 540 541 542 543 544 545
-- | 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"
546 547 548
      -- be careful what options we call clang with
      -- see #5903 and #7617 for bugs caused by this.
      (_,args0) = pgm_a dflags
549 550 551
      args1 = map Option (getOpts dflags opt_a)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
552
  Exception.catch (do
553
        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
554 555
    )
    (\(err :: SomeException) -> do
556 557 558 559
        errorMsg dflags $
            text ("Error running clang! you need clang installed to use the" ++
                "LLVM backend") $+$
            text "(or GHC tried to execute clang incorrectly)"
560
        throwIO err
561 562
    )

563 564 565 566 567 568 569 570 571 572 573 574 575
-- | 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
dterei's avatar
dterei committed
576
             {- > llc -version
577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593
                  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
594 595 596
                debugTraceMsg dflags 2
                    (text "Error (figuring out LLVM version):" <+>
                     text (show err))
597
                errorMsg dflags $ vcat
598 599 600
                    [ text "Warning:", nest 9 $
                          text "Couldn't figure out LLVM version!" $$
                          text "Make sure you have installed LLVM"]
601 602
                return Nothing)
  return ver
603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683


{- Note [Run-time linker info]

See also: Trac #5240, Trac #6063

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.

-}


neededLinkArgs :: LinkerInfo -> [Option]
neededLinkArgs (GnuLD o)     = o
neededLinkArgs (GnuGold o)   = o
neededLinkArgs (DarwinLD o)  = o
neededLinkArgs UnknownLD     = []

-- Grab linker info and cache it in DynFlags.
getLinkerInfo :: DynFlags -> IO LinkerInfo
getLinkerInfo dflags = do
  info <- readIORef (rtldFlags dflags)
  case info of
    Just v  -> return v
    Nothing -> do
      v <- getLinkerInfo' dflags
      writeIORef (rtldFlags dflags) (Just v)
      return v

-- See Note [Run-time linker info].
getLinkerInfo' :: DynFlags -> IO LinkerInfo
getLinkerInfo' dflags = do
  let platform = targetPlatform dflags
      os = platformOS platform
      (pgm,_) = pgm_l dflags

      -- 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.
          return (GnuLD $ map Option ["-Wl,--hash-size=31",
                                      "-Wl,--reduce-memory-overheads"])

        | any ("GNU gold" `isPrefixOf`) stdo =
          -- GNU gold does not require any special arguments.
          return (GnuGold [])

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

  -- Process the executable call
  info <- catchIO (do
             case os of
               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 []
684 685 686
               OSiOS -> 
                 -- Ditto for iOS
                 return $ DarwinLD []
687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713
               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.
                 return $ GnuLD $ map Option ["-Wl,--hash-size=31",
                                              "-Wl,--reduce-memory-overheads"]
               _ -> do
                 -- In practice, we use the compiler as the linker here. Pass
                 -- -Wl,--version to get linker version info.
                 (exitc, stdo, stde) <- readProcessWithExitCode pgm
                                        ["-Wl,--version"] ""
                 -- 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
714

715
runLink :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
716
runLink dflags args = do
717 718
  -- See Note [Run-time linker info]
  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
719
  let (p,args0) = pgm_l dflags
720 721
      args1     = map Option (getOpts dflags opt_l)
      args2     = args0 ++ args1 ++ args ++ linkargs
722 723
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags id "Linker" p args2 mb_env
724

725 726 727 728 729 730 731 732 733
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
      libtool    = pgm_libtool dflags    
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags id "Linker" libtool args2 mb_env

734 735
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
736
  let (p,args0) = pgm_dll dflags
737 738
      args1 = args0 ++ args
  mb_env <- getGccEnv (args0++args)
739
  runSomethingFiltered dflags id "Make DLL" p args1 mb_env
740

741 742
runWindres :: DynFlags -> [Option] -> IO ()
runWindres dflags args = do
743 744
  let (gcc, gcc_args) = pgm_c dflags
      windres = pgm_windres dflags
745
      opts = map Option (getOpts dflags opt_windres)
746 747 748 749 750 751 752
      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 ++
753
                                          map showOpt opts ++
754 755 756 757 758 759 760
                                          ["-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
761
  mb_env <- getGccEnv gcc_args
762
  runSomethingFiltered dflags id "Windres" windres args' mb_env
763

764
touch :: DynFlags -> String -> String -> IO ()
765 766
touch dflags purpose arg =
  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
767

768 769 770 771 772 773
copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to

copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
               -> IO ()
copyWithHeader dflags purpose maybe_header from to = do
774
  showPass dflags purpose
775

776 777 778
  hout <- openBinaryFile to   WriteMode
  hin  <- openBinaryFile from ReadMode
  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
779
  maybe (return ()) (header hout) maybe_header
780 781 782
  hPutStr hout ls
  hClose hout
  hClose hin
783 784 785 786 787 788 789 790
 where
  -- 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
791

792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
-- | 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
Ian Lynagh's avatar
Ian Lynagh committed
810 811 812 813 814
           skipSpaces
           _ <- R.char '['
           skipSpaces
           _ <- string "0]"
           skipSpaces
815
           munch (const True)
816 817 818
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
819
%*                                                                      *
820
\subsection{Managing temporary files
Ian Lynagh's avatar
Ian Lynagh committed
821
%*                                                                      *
822 823 824
%************************************************************************

\begin{code}
825 826
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
827
   = unless (gopt Opt_KeepTmpFiles dflags)
828 829
   $ do let ref = dirsToClean dflags
        ds <- readIORef ref
830 831
        removeTmpDirs dflags (Map.elems ds)
        writeIORef ref Map.empty
832

833 834
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
835
   = unless (gopt Opt_KeepTmpFiles dflags)
836 837
   $ do let ref = filesToClean dflags
        fs <- readIORef ref
838
        removeTmpFiles dflags fs
839
        writeIORef ref []
840

841 842
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
ian@well-typed.com's avatar
ian@well-typed.com committed
843
   = unless (gopt Opt_KeepTmpFiles dflags)
844 845
   $ do let ref = filesToClean dflags
        files <- readIORef ref
846
        let (to_keep, to_delete) = partition (`elem` dont_delete) files
847
        writeIORef ref to_keep
Simon Marlow's avatar
Simon Marlow committed
848
        removeTmpFiles dflags to_delete
849 850 851


-- find a temporary name that doesn't already exist.
852
newTempName :: DynFlags -> Suffix -> IO FilePath
853 854 855
newTempName dflags extn
  = do d <- getTempDir dflags
       x <- getProcessID
Ian Lynagh's avatar
Ian Lynagh committed
856
       findTempName (d </> "ghc" ++ show x ++ "_") 0
857 858
  where
    findTempName :: FilePath -> Integer -> IO FilePath
859
    findTempName prefix x
Ian Lynagh's avatar
Ian Lynagh committed
860 861 862
      = do let filename = (prefix ++ show x) <.> extn
           b  <- doesFileExist filename
           if b then findTempName prefix (x+1)
863 864
                else do -- clean it up later
                        consIORef (filesToClean dflags) filename
Ian Lynagh's avatar
Ian Lynagh committed
865
                        return filename
866

867 868 869
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
getTempDir :: DynFlags -> IO FilePath
870
getTempDir dflags
871
  = do let ref = dirsToClean dflags
872
           tmp_dir = tmpDir dflags
873
       mapping <- readIORef ref
874
       case Map.lookup tmp_dir mapping of
875 876
           Nothing ->
               do x <- getProcessID
877
                  let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
878 879
                  let
                      mkTempDir :: Integer -> IO FilePath
880 881 882
                      mkTempDir x
                       = let dirname = prefix ++ show x
                         in do createDirectory dirname
883
                               let mapping' = Map.insert tmp_dir dirname mapping
884
                               writeIORef ref mapping'
Ian Lynagh's avatar
Ian Lynagh committed
885
                               debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
886
                               return dirname
887
                            `catchIO` \e ->
888 889 890 891 892 893
                                    if isAlreadyExistsError e
                                    then mkTempDir (x+1)
                                    else ioError e
                  mkTempDir 0
           Just d -> return d

894
addFilesToClean :: DynFlags -> [FilePath] -> IO ()
895
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
896
addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
897

898 899 900
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
  = traceCmd dflags "Deleting temp dirs"
Ian Lynagh's avatar
Ian Lynagh committed
901 902
             ("Deleting: " ++ unwords ds)
             (mapM_ (removeWith dflags removeDirectory) ds)
903

904 905
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
906
  = warnNon $
Ian Lynagh's avatar
Ian Lynagh committed
907 908 909
    traceCmd dflags "Deleting temp files"
             ("Deleting: " ++ unwords deletees)
             (mapM_ (removeWith dflags removeFile) deletees)
910
  where
911 912 913
     -- Flat out refuse to delete files that are likely to be source input
     -- files (is there a worse bug than having a compiler delete your source
     -- files?)
Ian Lynagh's avatar
Ian Lynagh committed
914
     --
915 916 917 918 919
     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
     -- the condition.
    warnNon act
     | null non_deletees = act
     | otherwise         = do
920
        putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
Ian Lynagh's avatar
Ian Lynagh committed
921
        act
922

923
    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
924

925
removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
926
removeWith dflags remover f = remover f `catchIO`
927 928
  (\e ->
   let msg = if isDoesNotExistError e
Ian Lynagh's avatar
Ian Lynagh committed
929 930
             then ptext (sLit "Warning: deleting non-existent") <+> text f
             else ptext (sLit "Warning: exception raised when deleting")
931 932 933 934
                                            <+> text f <> colon
               $$ text (show e)
   in debugTraceMsg dflags 2 msg
  )
935 936 937 938

-----------------------------------------------------------------------------
-- Running an external program

939
runSomething :: DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
940 941 942 943 944 945 946 947
             -> String          -- For -v message
             -> String          -- Command name (possibly a full path)
                                --      assumed already dos-ified
             -> [Option]        -- Arguments
                                --      runSomething will dos-ify them
             -> IO ()

runSomething dflags phase_name pgm args =
948
  runSomethingFiltered dflags id phase_name pgm args Nothing
949 950

runSomethingFiltered
951 952
  :: DynFlags -> (String->String) -> String -> String -> [Option]
  -> Maybe [(String,String)] -> IO ()
953

954
runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
955 956 957 958 959 960 961 962 963 964
    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
965
  let real_args = filter notNull (map showOpt args)
966
      cmdLine = showCommandForUser pgm real_args
967
  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
968 969 970 971 972 973 974 975 976 977 978 979 980

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
981
       | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
982 983 984 985 986 987
  where
    handler err =
       if IO.isDoesNotExistError err
          then does_not_exist
          else IO.ioError err

988
    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
989

990

Ian Lynagh's avatar
Ian Lynagh committed
991 992 993
builderMainLoop :: DynFlags -> (String -> String) -> FilePath
                -> [String] -> Maybe [(String, String)]
                -> IO ExitCode
994
builderMainLoop dflags filter_fn pgm real_args mb_env = do
995
  chan <- newChan
996
  (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
997 998 999 1000

  -- and run a loop piping the output from the compiler to the log_action in DynFlags
  hSetBuffering hStdOut LineBuffering
  hSetBuffering hStdErr LineBuffering
1001 1002
  _ <- forkIO (readerProc chan hStdOut filter_fn)
  _ <- forkIO (readerProc chan hStdErr filter_fn)
1003 1004 1005 1006 1007
  -- we don't want to finish until 2 streams have been completed
  -- (stdout and stderr)
  -- nor until 1 exit code has been retrieved.
  rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
  -- after that, we're done here.
1008 1009 1010 1011 1012 1013 1014 1015 1016 1017
  hClose hStdIn
  hClose hStdOut
  hClose hStdErr
  return rc
  where
    -- status starts at zero, and increments each time either
    -- a reader process gets EOF, or the build proc exits.  We wait
    -- for all of these to happen (status==3).
    -- ToDo: we should really have a contingency plan in case any of
    -- the threads dies, such as a timeout.
Ian Lynagh's avatar
Ian Lynagh committed
1018
    loop _    _        0 0 exitcode = return exitcode
1019 1020 1021 1022 1023 1024
    loop chan hProcess t p exitcode = do
      mb_code <- if p > 0
                   then getProcessExitCode hProcess
                   else return Nothing
      case mb_code of
        Just code -> loop chan hProcess t (p-1) code
Ian Lynagh's avatar
Ian Lynagh committed
1025 1026 1027
        Nothing
          | t > 0 -> do
              msg <- readChan chan
1028 1029
              case msg of
                BuildMsg msg -> do
Ian Lynagh's avatar
Ian Lynagh committed
1030
                  log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
1031 1032
                  loop chan hProcess t p exitcode
                BuildError loc msg -> do
Ian Lynagh's avatar
Ian Lynagh committed
1033
                  log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
1034 1035 1036 1037 1038
                  loop chan hProcess t p exitcode
                EOF ->
                  loop chan hProcess (t-1) p exitcode
          | otherwise -> loop chan hProcess t p exitcode

Ian Lynagh's avatar
Ian Lynagh committed
1039
readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
1040 1041
readerProc chan hdl filter_fn =
    (do str <- hGetContents hdl
Ian Lynagh's avatar
Ian Lynagh committed
1042
        loop (linesPlatform (filter_fn str)) Nothing)
1043 1044
    `finally`
       writeChan chan EOF
Ian Lynagh's avatar
Ian Lynagh committed
1045 1046 1047
        -- ToDo: check errors more carefully
        -- ToDo: in the future, the filter should be implemented as
        -- a stream transformer.
1048
    where
Ian Lynagh's avatar
Ian Lynagh committed
1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060
        loop []     Nothing    = return ()
        loop []     (Just err) = writeChan chan err
        loop (l:ls) in_err     =
                case in_err of
                  Just err@(BuildError srcLoc msg)
                    | leading_whitespace l -> do
                        loop ls (Just (BuildError srcLoc (msg $$ text l)))
                    | otherwise -> do
                        writeChan chan err
                        checkError l ls
                  Nothing -> do
                        checkError l ls
Ian Lynagh's avatar
Ian Lynagh committed
1061
                  _ -> panic "readerProc/loop"
Ian Lynagh's avatar
Ian Lynagh committed
1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073

        checkError l ls
           = case parseError l of
                Nothing -> do
                    writeChan chan (BuildMsg (text l))
                    loop ls Nothing
                Just (file, lineNum, colNum, msg) -> do
                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
                    loop ls (Just (BuildError srcLoc (text msg)))

        leading_whitespace []    = False
        leading_whitespace (x:_) = isSpace x
1074

1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098
parseError :: String -> Maybe (String, Int, Int, String)
parseError s0 = case breakColon s0 of
                Just (filename, s1) ->
                    case breakIntColon s1 of
                    Just (lineNum, s2) ->
                        case breakIntColon s2 of
                        Just (columnNum, s3) ->
                            Just (filename, lineNum, columnNum, s3)
                        Nothing ->
                            Just (filename, lineNum, 0, s2)
                    Nothing -> Nothing
                Nothing -> Nothing

breakColon :: String -> Maybe (String, String)
breakColon xs = case break (':' ==) xs of
                    (ys, _:zs) -> Just (ys, zs)
                    _ -> Nothing

breakIntColon :: String -> Maybe (Int, String)
breakIntColon xs = case break (':' ==) xs of
                       (ys, _:zs)
                        | not (null ys) && all isAscii ys && all isDigit ys ->
                           Just (read ys, zs)
                       _ -> Nothing
1099 1100 1101 1102 1103 1104

data BuildMessage
  = BuildMsg   !SDoc
  | BuildError !SrcLoc !SDoc
  | EOF

1105
traceCmd :: DynFlags -> String -> String -> IO a -> IO a
Simon Marlow's avatar
Simon Marlow committed
1106
-- trace the command (at two levels of verbosity)
1107
traceCmd dflags phase_name cmd_line action
Ian Lynagh's avatar
Ian Lynagh committed
1108 1109 1110
 = do   { let verb = verbosity dflags
        ; showPass dflags phase_name
        ; debugTraceMsg dflags 3 (text cmd_line)
1111 1112
        ; case flushErr dflags of
              FlushErr io -> io
Ian Lynagh's avatar
Ian Lynagh committed
1113 1114

           -- And run it!
1115
        ; action `catchIO` handle_exn verb
Simon Marlow's avatar
Simon Marlow committed
1116
        }
1117
  where
Ian Lynagh's avatar
Ian Lynagh committed
1118 1119
    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
                              ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
1120
                              ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
1121 1122
\end{code}

1123
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
1124
%*                                                                      *
1125
\subsection{Support code}
Ian Lynagh's avatar
Ian Lynagh committed
1126
%*                                                                      *
1127 1128 1129
%************************************************************************

\begin{code}
1130
-----------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
1131
-- Define       getBaseDir     :: IO (Maybe String)
1132

1133
getBaseDir :: IO (Maybe String)
1134
#if defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
1135 1136
-- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
-- return the path $(stuff)/lib.
1137
getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
sof's avatar
sof committed
1138
  where
1139 1140 1141 1142 1143 1144 1145
    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)
    
Ian Lynagh's avatar
Ian Lynagh committed <