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