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