compiler/main/SysTools.lhs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2001-2003
   4 --
   5 -- Access to system tools: gcc, cp, rm etc
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 \begin{code}
  10 module SysTools (
  11         -- Initialisation
  12         initSysTools,
  13
  14         -- Interface to system tools
  15         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  16         runPp,                   -- [Option] -> IO ()
  17         runMangle, runSplit,     -- [Option] -> IO ()
  18         runAs, runLink,          -- [Option] -> IO ()
  19         runMkDLL,
  20         runWindres,
  21
  22         touch,                  -- String -> String -> IO ()
  23         copy,
  24         copyWithHeader,
  25         getExtraViaCOpts,
  26
  27         -- Temporary-file management
  28         setTmpDir,
  29         newTempName,
  30         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
  31         addFilesToClean,
  32
  33         Option(..)
  34
  35  ) where
  36
  37 #include "HsVersions.h"
  38
  39 import DriverPhases
  40 import Config
  41 import Outputable
  42 import ErrUtils
  43 import Panic
  44 import Util
  45 import DynFlags
  46 import FiniteMap
  47
  48 import Exception
  49 import Data.IORef
  50 import Control.Monad
  51 import System.Exit
  52 import System.Environment
  53 import System.FilePath
  54 import System.IO
  55 import System.IO.Error as IO
  56 import System.Directory
  57 import Data.Char
  58 import Data.List
  59
  60 #ifndef mingw32_HOST_OS
  61 import qualified System.Posix.Internals
  62 #else /* Must be Win32 */
  63 import Foreign
  64 import Foreign.C.String
  65 #endif
  66
  67 import System.Process   ( runInteractiveProcess, getProcessExitCode )
  68 import Control.Concurrent
  69 import FastString
  70 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
  71 \end{code}
  72
  73 How GHC finds its files
  74 ~~~~~~~~~~~~~~~~~~~~~~~
  75
  76 [Note topdir]
  77
  78 GHC needs various support files (library packages, RTS etc), plus
  79 various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
  80 the root of GHC's support files
  81
  82 On Unix:
  83   - ghc always has a shell wrapper that passes a -B<dir> option
  84
  85 On Windows:
  86   - ghc never has a shell wrapper.
  87   - we can find the location of the ghc binary, which is
  88         $topdir/bin/<something>.exe
  89     where <something> may be "ghc", "ghc-stage2", or similar
  90   - we strip off the "bin/<something>.exe" to leave $topdir.
  91
  92 from topdir we can find package.conf, ghc-asm, etc.
  93
  94
  95 SysTools.initSysProgs figures out exactly where all the auxiliary programs
  96 are, and initialises mutable variables to make it easy to call them.
  97 To to this, it makes use of definitions in Config.hs, which is a Haskell
  98 file containing variables whose value is figured out by the build system.
  99
 100 Config.hs contains two sorts of things
 101
 102   cGCC,         The *names* of the programs
 103   cCPP            e.g.  cGCC = gcc
 104   cUNLIT                cCPP = gcc -E
 105   etc           They do *not* include paths
 106
 107
 108   cUNLIT_DIR   The *path* to the directory containing unlit, split etc
 109   cSPLIT_DIR   *relative* to the root of the build tree,
 110                    for use when running *in-place* in a build tree (only)
 111
 112
 113
 114 ---------------------------------------------
 115 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 116
 117 Another hair-brained scheme for simplifying the current tool location
 118 nightmare in GHC: Simon originally suggested using another
 119 configuration file along the lines of GCC's specs file - which is fine
 120 except that it means adding code to read yet another configuration
 121 file.  What I didn't notice is that the current package.conf is
 122 general enough to do this:
 123
 124 Package
 125     {name = "tools",    import_dirs = [],  source_dirs = [],
 126      library_dirs = [], hs_libraries = [], extra_libraries = [],
 127      include_dirs = [], c_includes = [],   package_deps = [],
 128      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
 129      extra_cc_opts = [], extra_ld_opts = []}
 130
 131 Which would have the advantage that we get to collect together in one
 132 place the path-specific package stuff with the path-specific tool
 133 stuff.
 134                 End of NOTES
 135 ---------------------------------------------
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection{Initialisation}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
 145
 146              -> DynFlags
 147              -> IO DynFlags     -- Set all the mutable variables above, holding
 148                                 --      (a) the system programs
 149                                 --      (b) the package-config file
 150                                 --      (c) the GHC usage message
 151
 152
 153 initSysTools mbMinusB dflags0
 154   = do  { top_dir <- findTopDir mbMinusB
 155                 -- see [Note topdir]
 156                 -- NB: top_dir is assumed to be in standard Unix
 157                 -- format, '/' separated
 158
 159         ; let installed :: FilePath -> FilePath
 160               installed file = top_dir </> file
 161               installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file
 162
 163         ; let pkgconfig_path = installed "package.conf.d"
 164               ghc_usage_msg_path  = installed "ghc-usage.txt"
 165               ghci_usage_msg_path = installed "ghci-usage.txt"
 166
 167                 -- For all systems, unlit, split, mangle are GHC utilities
 168                 -- architecture-specific stuff is done when building Config.hs
 169               unlit_path = installed cGHC_UNLIT_PGM
 170
 171                 -- split and mangle are Perl scripts
 172               split_script  = installed cGHC_SPLIT_PGM
 173               mangle_script = installed cGHC_MANGLER_PGM
 174
 175               windres_path  = installed_mingw_bin "windres"
 176
 177         ; tmpdir <- getTemporaryDirectory
 178         ; let dflags1 = setTmpDir tmpdir dflags0
 179
 180         -- On Windows, mingw is distributed with GHC,
 181         --      so we look in TopDir/../mingw/bin
 182         ; let
 183               gcc_prog
 184                 | isWindowsHost = installed_mingw_bin "gcc"
 185                 | otherwise     = cGCC
 186               perl_path
 187                 | isWindowsHost = installed cGHC_PERL
 188                 | otherwise     = cGHC_PERL
 189               -- 'touch' is a GHC util for Windows
 190               touch_path
 191                 | isWindowsHost = installed cGHC_TOUCHY_PGM
 192                 | otherwise     = "touch"
 193               -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 194               -- a call to Perl to get the invocation of split and mangle.
 195               -- On Unix, scripts are invoked using the '#!' method.  Binary
 196               -- installations of GHC on Unix place the correct line on the
 197               -- front of the script at installation time, so we don't want
 198               -- to wire-in our knowledge of $(PERL) on the host system here.
 199               (split_prog,  split_args)
 200                 | isWindowsHost = (perl_path,    [Option split_script])
 201                 | otherwise     = (split_script, [])
 202               (mangle_prog, mangle_args)
 203                 | isWindowsHost = (perl_path,   [Option mangle_script])
 204                 | otherwise     = (mangle_script, [])
 205               (mkdll_prog, mkdll_args)
 206                 | not isWindowsHost
 207                     = panic "Can't build DLLs on a non-Win32 system"
 208                 | otherwise =
 209                     (installed_mingw_bin cMKDLL, [])
 210
 211         -- cpp is derived from gcc on all platforms
 212         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
 213         -- Config.hs one day.
 214         ; let cpp_path  = (gcc_prog,
 215                            (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 216
 217         -- Other things being equal, as and ld are simply gcc
 218         ; let   as_prog  = gcc_prog
 219                 ld_prog  = gcc_prog
 220
 221         ; return dflags1{
 222                         ghcUsagePath = ghc_usage_msg_path,
 223                         ghciUsagePath = ghci_usage_msg_path,
 224                         topDir  = top_dir,
 225                         systemPackageConfig = pkgconfig_path,
 226                         pgm_L   = unlit_path,
 227                         pgm_P   = cpp_path,
 228                         pgm_F   = "",
 229                         pgm_c   = (gcc_prog,[]),
 230                         pgm_m   = (mangle_prog,mangle_args),
 231                         pgm_s   = (split_prog,split_args),
 232                         pgm_a   = (as_prog,[]),
 233                         pgm_l   = (ld_prog,[]),
 234                         pgm_dll = (mkdll_prog,mkdll_args),
 235                         pgm_T   = touch_path,
 236                         pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
 237                         pgm_windres = windres_path
 238                         -- Hans: this isn't right in general, but you can
 239                         -- elaborate it in the same way as the others
 240                 }
 241         }
 242 \end{code}
 243
 244 \begin{code}
 245 -- returns a Unix-format path (relying on getBaseDir to do so too)
 246 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
 247            -> IO String    -- TopDir (in Unix format '/' separated)
 248 findTopDir (Just minusb) = return (normalise minusb)
 249 findTopDir Nothing
 250     = do -- Get directory of executable
 251          maybe_exec_dir <- getBaseDir
 252          case maybe_exec_dir of
 253              -- "Just" on Windows, "Nothing" on unix
 254              Nothing  -> ghcError (InstallationError "missing -B<dir> option")
 255              Just dir -> return dir
 256 \end{code}
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsection{Running an external program}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265
 266 \begin{code}
 267 runUnlit :: DynFlags -> [Option] -> IO ()
 268 runUnlit dflags args = do
 269   let p = pgm_L dflags
 270   runSomething dflags "Literate pre-processor" p args
 271
 272 runCpp :: DynFlags -> [Option] -> IO ()
 273 runCpp dflags args =   do
 274   let (p,args0) = pgm_P dflags
 275       args1 = args0 ++ args
 276       args2 = if dopt Opt_WarnIsError dflags
 277               then Option "-Werror" : args1
 278               else                    args1
 279   mb_env <- getGccEnv args2
 280   runSomethingFiltered dflags id  "C pre-processor" p args2 mb_env
 281
 282 runPp :: DynFlags -> [Option] -> IO ()
 283 runPp dflags args =   do
 284   let p = pgm_F dflags
 285   runSomething dflags "Haskell pre-processor" p args
 286
 287 runCc :: DynFlags -> [Option] -> IO ()
 288 runCc dflags args =   do
 289   let (p,args0) = pgm_c dflags
 290       args1 = args0 ++ args
 291   mb_env <- getGccEnv args1
 292   runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
 293  where
 294   -- discard some harmless warnings from gcc that we can't turn off
 295   cc_filter = unlines . doFilter . lines
 296
 297   {-
 298   gcc gives warnings in chunks like so:
 299       In file included from /foo/bar/baz.h:11,
 300                        from /foo/bar/baz2.h:22,
 301                        from wibble.c:33:
 302       /foo/flibble:14: global register variable ...
 303       /foo/flibble:15: warning: call-clobbered r...
 304   We break it up into its chunks, remove any call-clobbered register
 305   warnings from each chunk, and then delete any chunks that we have
 306   emptied of warnings.
 307   -}
 308   doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
 309   -- We can't assume that the output will start with an "In file inc..."
 310   -- line, so we start off expecting a list of warnings rather than a
 311   -- location stack.
 312   chunkWarnings :: [String] -- The location stack to use for the next
 313                             -- list of warnings
 314                 -> [String] -- The remaining lines to look at
 315                 -> [([String], [String])]
 316   chunkWarnings loc_stack [] = [(loc_stack, [])]
 317   chunkWarnings loc_stack xs
 318       = case break loc_stack_start xs of
 319         (warnings, lss:xs') ->
 320             case span loc_start_continuation xs' of
 321             (lsc, xs'') ->
 322                 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
 323         _ -> [(loc_stack, xs)]
 324
 325   filterWarnings :: [([String], [String])] -> [([String], [String])]
 326   filterWarnings [] = []
 327   -- If the warnings are already empty then we are probably doing
 328   -- something wrong, so don't delete anything
 329   filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
 330   filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
 331                                        [] -> filterWarnings zs
 332                                        ys' -> (xs, ys') : filterWarnings zs
 333
 334   unChunkWarnings :: [([String], [String])] -> [String]
 335   unChunkWarnings [] = []
 336   unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
 337
 338   loc_stack_start        s = "In file included from " `isPrefixOf` s
 339   loc_start_continuation s = "                 from " `isPrefixOf` s
 340   wantedWarning w
 341    | "warning: call-clobbered register used" `isContainedIn` w = False
 342    | otherwise = True
 343
 344 isContainedIn :: String -> String -> Bool
 345 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
 346
 347 -- If the -B<dir> option is set, add <dir> to PATH.  This works around
 348 -- a bug in gcc on Windows Vista where it can't find its auxiliary
 349 -- binaries (see bug #1110).
 350 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
 351 getGccEnv opts =
 352   if null b_dirs
 353      then return Nothing
 354      else do env <- getEnvironment
 355              return (Just (map mangle_path env))
 356  where
 357   (b_dirs, _) = partitionWith get_b_opt opts
 358
 359   get_b_opt (Option ('-':'B':dir)) = Left dir
 360   get_b_opt other = Right other
 361
 362   mangle_path (path,paths) | map toUpper path == "PATH"
 363         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
 364   mangle_path other = other
 365
 366 runMangle :: DynFlags -> [Option] -> IO ()
 367 runMangle dflags args = do
 368   let (p,args0) = pgm_m dflags
 369   runSomething dflags "Mangler" p (args0++args)
 370
 371 runSplit :: DynFlags -> [Option] -> IO ()
 372 runSplit dflags args = do
 373   let (p,args0) = pgm_s dflags
 374   runSomething dflags "Splitter" p (args0++args)
 375
 376 runAs :: DynFlags -> [Option] -> IO ()
 377 runAs dflags args = do
 378   let (p,args0) = pgm_a dflags
 379       args1 = args0 ++ args
 380   mb_env <- getGccEnv args1
 381   runSomethingFiltered dflags id "Assembler" p args1 mb_env
 382
 383 runLink :: DynFlags -> [Option] -> IO ()
 384 runLink dflags args = do
 385   let (p,args0) = pgm_l dflags
 386       args1 = args0 ++ args
 387   mb_env <- getGccEnv args1
 388   runSomethingFiltered dflags id "Linker" p args1 mb_env
 389
 390 runMkDLL :: DynFlags -> [Option] -> IO ()
 391 runMkDLL dflags args = do
 392   let (p,args0) = pgm_dll dflags
 393       args1 = args0 ++ args
 394   mb_env <- getGccEnv (args0++args)
 395   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
 396
 397 runWindres :: DynFlags -> [Option] -> IO ()
 398 runWindres dflags args = do
 399   let (gcc, gcc_args) = pgm_c dflags
 400       windres = pgm_windres dflags
 401       quote x = "\"" ++ x ++ "\""
 402       args' = -- If windres.exe and gcc.exe are in a directory containing
 403               -- spaces then windres fails to run gcc. We therefore need
 404               -- to tell it what command to use...
 405               Option ("--preprocessor=" ++
 406                       unwords (map quote (gcc :
 407                                           map showOpt gcc_args ++
 408                                           ["-E", "-xc", "-DRC_INVOKED"])))
 409               -- ...but if we do that then if windres calls popen then
 410               -- it can't understand the quoting, so we have to use
 411               -- --use-temp-file so that it interprets it correctly.
 412               -- See #1828.
 413             : Option "--use-temp-file"
 414             : args
 415   mb_env <- getGccEnv gcc_args
 416   runSomethingFiltered dflags id "Windres" windres args' mb_env
 417
 418 touch :: DynFlags -> String -> String -> IO ()
 419 touch dflags purpose arg =
 420   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
 421
 422 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
 423 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
 424
 425 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
 426                -> IO ()
 427 copyWithHeader dflags purpose maybe_header from to = do
 428   showPass dflags purpose
 429
 430   hout <- openBinaryFile to   WriteMode
 431   hin  <- openBinaryFile from ReadMode
 432   ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
 433   maybe (return ()) (hPutStr hout) maybe_header
 434   hPutStr hout ls
 435   hClose hout
 436   hClose hin
 437
 438 getExtraViaCOpts :: DynFlags -> IO [String]
 439 getExtraViaCOpts dflags = do
 440   f <- readFile (topDir dflags </> "extra-gcc-opts")
 441   return (words f)
 442 \end{code}
 443
 444 %************************************************************************
 445 %*                                                                      *
 446 \subsection{Managing temporary files
 447 %*                                                                      *
 448 %************************************************************************
 449
 450 \begin{code}
 451 cleanTempDirs :: DynFlags -> IO ()
 452 cleanTempDirs dflags
 453    = unless (dopt Opt_KeepTmpFiles dflags)
 454    $ do let ref = dirsToClean dflags
 455         ds <- readIORef ref
 456         removeTmpDirs dflags (eltsFM ds)
 457         writeIORef ref emptyFM
 458
 459 cleanTempFiles :: DynFlags -> IO ()
 460 cleanTempFiles dflags
 461    = unless (dopt Opt_KeepTmpFiles dflags)
 462    $ do let ref = filesToClean dflags
 463         fs <- readIORef ref
 464         removeTmpFiles dflags fs
 465         writeIORef ref []
 466
 467 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 468 cleanTempFilesExcept dflags dont_delete
 469    = unless (dopt Opt_KeepTmpFiles dflags)
 470    $ do let ref = filesToClean dflags
 471         files <- readIORef ref
 472         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 473         removeTmpFiles dflags to_delete
 474         writeIORef ref to_keep
 475
 476
 477 -- find a temporary name that doesn't already exist.
 478 newTempName :: DynFlags -> Suffix -> IO FilePath
 479 newTempName dflags extn
 480   = do d <- getTempDir dflags
 481        x <- getProcessID
 482        findTempName (d ++ "/ghc" ++ show x ++ "_") 0
 483   where
 484     findTempName :: FilePath -> Integer -> IO FilePath
 485     findTempName prefix x
 486       = do let filename = (prefix ++ show x) <.> extn
 487            b  <- doesFileExist filename
 488            if b then findTempName prefix (x+1)
 489                 else do -- clean it up later
 490                         consIORef (filesToClean dflags) filename
 491                         return filename
 492
 493 -- return our temporary directory within tmp_dir, creating one if we
 494 -- don't have one yet
 495 getTempDir :: DynFlags -> IO FilePath
 496 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
 497   = do let ref = dirsToClean dflags
 498        mapping <- readIORef ref
 499        case lookupFM mapping tmp_dir of
 500            Nothing ->
 501                do x <- getProcessID
 502                   let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
 503                   let
 504                       mkTempDir :: Integer -> IO FilePath
 505                       mkTempDir x
 506                        = let dirname = prefix ++ show x
 507                          in do createDirectory dirname
 508                                let mapping' = addToFM mapping tmp_dir dirname
 509                                writeIORef ref mapping'
 510                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
 511                                return dirname
 512                             `IO.catch` \e ->
 513                                     if isAlreadyExistsError e
 514                                     then mkTempDir (x+1)
 515                                     else ioError e
 516                   mkTempDir 0
 517            Just d -> return d
 518
 519 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
 520 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 521 addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
 522
 523 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
 524 removeTmpDirs dflags ds
 525   = traceCmd dflags "Deleting temp dirs"
 526              ("Deleting: " ++ unwords ds)
 527              (mapM_ (removeWith dflags removeDirectory) ds)
 528
 529 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
 530 removeTmpFiles dflags fs
 531   = warnNon $
 532     traceCmd dflags "Deleting temp files"
 533              ("Deleting: " ++ unwords deletees)
 534              (mapM_ (removeWith dflags removeFile) deletees)
 535   where
 536      -- Flat out refuse to delete files that are likely to be source input
 537      -- files (is there a worse bug than having a compiler delete your source
 538      -- files?)
 539      --
 540      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 541      -- the condition.
 542     warnNon act
 543      | null non_deletees = act
 544      | otherwise         = do
 545         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
 546         act
 547
 548     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 549
 550 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
 551 removeWith dflags remover f = remover f `IO.catch`
 552   (\e ->
 553    let msg = if isDoesNotExistError e
 554              then ptext (sLit "Warning: deleting non-existent") <+> text f
 555              else ptext (sLit "Warning: exception raised when deleting")
 556                                             <+> text f <> colon
 557                $$ text (show e)
 558    in debugTraceMsg dflags 2 msg
 559   )
 560
 561 -----------------------------------------------------------------------------
 562 -- Running an external program
 563
 564 runSomething :: DynFlags
 565              -> String          -- For -v message
 566              -> String          -- Command name (possibly a full path)
 567                                 --      assumed already dos-ified
 568              -> [Option]        -- Arguments
 569                                 --      runSomething will dos-ify them
 570              -> IO ()
 571
 572 runSomething dflags phase_name pgm args =
 573   runSomethingFiltered dflags id phase_name pgm args Nothing
 574
 575 runSomethingFiltered
 576   :: DynFlags -> (String->String) -> String -> String -> [Option]
 577   -> Maybe [(String,String)] -> IO ()
 578
 579 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
 580   let real_args = filter notNull (map showOpt args)
 581   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
 582   (exit_code, doesn'tExist) <-
 583      IO.catch (do
 584          rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
 585          case rc of
 586            ExitSuccess{} -> return (rc, False)
 587            ExitFailure n
 588              -- rawSystem returns (ExitFailure 127) if the exec failed for any
 589              -- reason (eg. the program doesn't exist).  This is the only clue
 590              -- we have, but we need to report something to the user because in
 591              -- the case of a missing program there will otherwise be no output
 592              -- at all.
 593             | n == 127  -> return (rc, True)
 594             | otherwise -> return (rc, False))
 595                 -- Should 'rawSystem' generate an IO exception indicating that
 596                 -- 'pgm' couldn't be run rather than a funky return code, catch
 597                 -- this here (the win32 version does this, but it doesn't hurt
 598                 -- to test for this in general.)
 599               (\ err ->
 600                 if IO.isDoesNotExistError err
 601                  then return (ExitFailure 1, True)
 602                  else IO.ioError err)
 603   case (doesn'tExist, exit_code) of
 604      (True, _)        -> ghcError (InstallationError ("could not execute: " ++ pgm))
 605      (_, ExitSuccess) -> return ()
 606      _                -> ghcError (PhaseFailed phase_name exit_code)
 607
 608 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
 609                 -> [String] -> Maybe [(String, String)]
 610                 -> IO ExitCode
 611 builderMainLoop dflags filter_fn pgm real_args mb_env = do
 612   chan <- newChan
 613   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
 614
 615   -- and run a loop piping the output from the compiler to the log_action in DynFlags
 616   hSetBuffering hStdOut LineBuffering
 617   hSetBuffering hStdErr LineBuffering
 618   _ <- forkIO (readerProc chan hStdOut filter_fn)
 619   _ <- forkIO (readerProc chan hStdErr filter_fn)
 620   -- we don't want to finish until 2 streams have been completed
 621   -- (stdout and stderr)
 622   -- nor until 1 exit code has been retrieved.
 623   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
 624   -- after that, we're done here.
 625   hClose hStdIn
 626   hClose hStdOut
 627   hClose hStdErr
 628   return rc
 629   where
 630     -- status starts at zero, and increments each time either
 631     -- a reader process gets EOF, or the build proc exits.  We wait
 632     -- for all of these to happen (status==3).
 633     -- ToDo: we should really have a contingency plan in case any of
 634     -- the threads dies, such as a timeout.
 635     loop _    _        0 0 exitcode = return exitcode
 636     loop chan hProcess t p exitcode = do
 637       mb_code <- if p > 0
 638                    then getProcessExitCode hProcess
 639                    else return Nothing
 640       case mb_code of
 641         Just code -> loop chan hProcess t (p-1) code
 642         Nothing
 643           | t > 0 -> do
 644               msg <- readChan chan
 645               case msg of
 646                 BuildMsg msg -> do
 647                   log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 648                   loop chan hProcess t p exitcode
 649                 BuildError loc msg -> do
 650                   log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
 651                   loop chan hProcess t p exitcode
 652                 EOF ->
 653                   loop chan hProcess (t-1) p exitcode
 654           | otherwise -> loop chan hProcess t p exitcode
 655
 656 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
 657 readerProc chan hdl filter_fn =
 658     (do str <- hGetContents hdl
 659         loop (linesPlatform (filter_fn str)) Nothing)
 660     `finally`
 661        writeChan chan EOF
 662         -- ToDo: check errors more carefully
 663         -- ToDo: in the future, the filter should be implemented as
 664         -- a stream transformer.
 665     where
 666         loop []     Nothing    = return ()
 667         loop []     (Just err) = writeChan chan err
 668         loop (l:ls) in_err     =
 669                 case in_err of
 670                   Just err@(BuildError srcLoc msg)
 671                     | leading_whitespace l -> do
 672                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
 673                     | otherwise -> do
 674                         writeChan chan err
 675                         checkError l ls
 676                   Nothing -> do
 677                         checkError l ls
 678                   _ -> panic "readerProc/loop"
 679
 680         checkError l ls
 681            = case parseError l of
 682                 Nothing -> do
 683                     writeChan chan (BuildMsg (text l))
 684                     loop ls Nothing
 685                 Just (file, lineNum, colNum, msg) -> do
 686                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
 687                     loop ls (Just (BuildError srcLoc (text msg)))
 688
 689         leading_whitespace []    = False
 690         leading_whitespace (x:_) = isSpace x
 691
 692 parseError :: String -> Maybe (String, Int, Int, String)
 693 parseError s0 = case breakColon s0 of
 694                 Just (filename, s1) ->
 695                     case breakIntColon s1 of
 696                     Just (lineNum, s2) ->
 697                         case breakIntColon s2 of
 698                         Just (columnNum, s3) ->
 699                             Just (filename, lineNum, columnNum, s3)
 700                         Nothing ->
 701                             Just (filename, lineNum, 0, s2)
 702                     Nothing -> Nothing
 703                 Nothing -> Nothing
 704
 705 breakColon :: String -> Maybe (String, String)
 706 breakColon xs = case break (':' ==) xs of
 707                     (ys, _:zs) -> Just (ys, zs)
 708                     _ -> Nothing
 709
 710 breakIntColon :: String -> Maybe (Int, String)
 711 breakIntColon xs = case break (':' ==) xs of
 712                        (ys, _:zs)
 713                         | not (null ys) && all isAscii ys && all isDigit ys ->
 714                            Just (read ys, zs)
 715                        _ -> Nothing
 716
 717 data BuildMessage
 718   = BuildMsg   !SDoc
 719   | BuildError !SrcLoc !SDoc
 720   | EOF
 721
 722 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 723 -- a) trace the command (at two levels of verbosity)
 724 -- b) don't do it at all if dry-run is set
 725 traceCmd dflags phase_name cmd_line action
 726  = do   { let verb = verbosity dflags
 727         ; showPass dflags phase_name
 728         ; debugTraceMsg dflags 3 (text cmd_line)
 729         ; hFlush stderr
 730
 731            -- Test for -n flag
 732         ; unless (dopt Opt_DryRun dflags) $ do {
 733
 734            -- And run it!
 735         ; action `IO.catch` handle_exn verb
 736         }}
 737   where
 738     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
 739                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
 740                               ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
 741 \end{code}
 742
 743 %************************************************************************
 744 %*                                                                      *
 745 \subsection{Support code}
 746 %*                                                                      *
 747 %************************************************************************
 748
 749 \begin{code}
 750 -----------------------------------------------------------------------------
 751 -- Define       getBaseDir     :: IO (Maybe String)
 752
 753 getBaseDir :: IO (Maybe String)
 754 #if defined(mingw32_HOST_OS)
 755 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
 756 -- return the path $(stuff)/lib.
 757 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 758                 buf <- mallocArray len
 759                 ret <- getModuleFileName nullPtr buf len
 760                 if ret == 0 then free buf >> return Nothing
 761                             else do s <- peekCString buf
 762                                     free buf
 763                                     return (Just (rootDir s))
 764   where
 765     rootDir s = case splitFileName $ normalise s of
 766                 (d, ghc_exe)
 767                  | lower ghc_exe `elem` ["ghc.exe",
 768                                          "ghc-stage1.exe",
 769                                          "ghc-stage2.exe",
 770                                          "ghc-stage3.exe"] ->
 771                     case splitFileName $ takeDirectory d of
 772                     -- ghc is in $topdir/bin/ghc.exe
 773                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
 774                     _ -> fail
 775                 _ -> fail
 776         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
 777               lower = map toLower
 778
 779 foreign import stdcall unsafe "GetModuleFileNameA"
 780   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 781 #else
 782 getBaseDir = return Nothing
 783 #endif
 784
 785 #ifdef mingw32_HOST_OS
 786 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 787 #else
 788 getProcessID :: IO Int
 789 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 790 #endif
 791
 792 -- Divvy up text stream into lines, taking platform dependent
 793 -- line termination into account.
 794 linesPlatform :: String -> [String]
 795 #if !defined(mingw32_HOST_OS)
 796 linesPlatform ls = lines ls
 797 #else
 798 linesPlatform "" = []
 799 linesPlatform xs =
 800   case lineBreak xs of
 801     (as,xs1) -> as : linesPlatform xs1
 802   where
 803    lineBreak "" = ("","")
 804    lineBreak ('\r':'\n':xs) = ([],xs)
 805    lineBreak ('\n':xs) = ([],xs)
 806    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
 807
 808 #endif
 809
 810 \end{code}