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
  49 import Exception
  50 import Data.IORef
  51 import Control.Monad
  52 import System.Exit
  53 import System.Environment
  54 import System.FilePath
  55 import System.IO
  56 import System.IO.Error as IO
  57 import System.Directory
  58 import Data.Char
  59 import Data.List
  60 import qualified Data.Map as Map
  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
  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 (Map.elems ds)
 476         writeIORef ref Map.empty
 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 Map.lookup tmp_dir mapping 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' = Map.insert tmp_dir dirname mapping
 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 #if __GLASGOW_HASKELL__ >= 701
 601       cmdLine = showCommandForUser pgm real_args
 602 #else
 603       cmdLine = unwords (pgm:real_args)
 604 #endif
 605   traceCmd dflags phase_name cmdLine $ do
 606   (exit_code, doesn'tExist) <-
 607      IO.catch (do
 608          rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
 609          case rc of
 610            ExitSuccess{} -> return (rc, False)
 611            ExitFailure n
 612              -- rawSystem returns (ExitFailure 127) if the exec failed for any
 613              -- reason (eg. the program doesn't exist).  This is the only clue
 614              -- we have, but we need to report something to the user because in
 615              -- the case of a missing program there will otherwise be no output
 616              -- at all.
 617             | n == 127  -> return (rc, True)
 618             | otherwise -> return (rc, False))
 619                 -- Should 'rawSystem' generate an IO exception indicating that
 620                 -- 'pgm' couldn't be run rather than a funky return code, catch
 621                 -- this here (the win32 version does this, but it doesn't hurt
 622                 -- to test for this in general.)
 623               (\ err ->
 624                 if IO.isDoesNotExistError err
 625                  then return (ExitFailure 1, True)
 626                  else IO.ioError err)
 627   case (doesn'tExist, exit_code) of
 628      (True, _)        -> ghcError (InstallationError ("could not execute: " ++ pgm))
 629      (_, ExitSuccess) -> return ()
 630      _                -> ghcError (PhaseFailed phase_name exit_code)
 631
 632 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
 633                 -> [String] -> Maybe [(String, String)]
 634                 -> IO ExitCode
 635 builderMainLoop dflags filter_fn pgm real_args mb_env = do
 636   chan <- newChan
 637   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
 638
 639   -- and run a loop piping the output from the compiler to the log_action in DynFlags
 640   hSetBuffering hStdOut LineBuffering
 641   hSetBuffering hStdErr LineBuffering
 642   _ <- forkIO (readerProc chan hStdOut filter_fn)
 643   _ <- forkIO (readerProc chan hStdErr filter_fn)
 644   -- we don't want to finish until 2 streams have been completed
 645   -- (stdout and stderr)
 646   -- nor until 1 exit code has been retrieved.
 647   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
 648   -- after that, we're done here.
 649   hClose hStdIn
 650   hClose hStdOut
 651   hClose hStdErr
 652   return rc
 653   where
 654     -- status starts at zero, and increments each time either
 655     -- a reader process gets EOF, or the build proc exits.  We wait
 656     -- for all of these to happen (status==3).
 657     -- ToDo: we should really have a contingency plan in case any of
 658     -- the threads dies, such as a timeout.
 659     loop _    _        0 0 exitcode = return exitcode
 660     loop chan hProcess t p exitcode = do
 661       mb_code <- if p > 0
 662                    then getProcessExitCode hProcess
 663                    else return Nothing
 664       case mb_code of
 665         Just code -> loop chan hProcess t (p-1) code
 666         Nothing
 667           | t > 0 -> do
 668               msg <- readChan chan
 669               case msg of
 670                 BuildMsg msg -> do
 671                   log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 672                   loop chan hProcess t p exitcode
 673                 BuildError loc msg -> do
 674                   log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
 675                   loop chan hProcess t p exitcode
 676                 EOF ->
 677                   loop chan hProcess (t-1) p exitcode
 678           | otherwise -> loop chan hProcess t p exitcode
 679
 680 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
 681 readerProc chan hdl filter_fn =
 682     (do str <- hGetContents hdl
 683         loop (linesPlatform (filter_fn str)) Nothing)
 684     `finally`
 685        writeChan chan EOF
 686         -- ToDo: check errors more carefully
 687         -- ToDo: in the future, the filter should be implemented as
 688         -- a stream transformer.
 689     where
 690         loop []     Nothing    = return ()
 691         loop []     (Just err) = writeChan chan err
 692         loop (l:ls) in_err     =
 693                 case in_err of
 694                   Just err@(BuildError srcLoc msg)
 695                     | leading_whitespace l -> do
 696                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
 697                     | otherwise -> do
 698                         writeChan chan err
 699                         checkError l ls
 700                   Nothing -> do
 701                         checkError l ls
 702                   _ -> panic "readerProc/loop"
 703
 704         checkError l ls
 705            = case parseError l of
 706                 Nothing -> do
 707                     writeChan chan (BuildMsg (text l))
 708                     loop ls Nothing
 709                 Just (file, lineNum, colNum, msg) -> do
 710                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
 711                     loop ls (Just (BuildError srcLoc (text msg)))
 712
 713         leading_whitespace []    = False
 714         leading_whitespace (x:_) = isSpace x
 715
 716 parseError :: String -> Maybe (String, Int, Int, String)
 717 parseError s0 = case breakColon s0 of
 718                 Just (filename, s1) ->
 719                     case breakIntColon s1 of
 720                     Just (lineNum, s2) ->
 721                         case breakIntColon s2 of
 722                         Just (columnNum, s3) ->
 723                             Just (filename, lineNum, columnNum, s3)
 724                         Nothing ->
 725                             Just (filename, lineNum, 0, s2)
 726                     Nothing -> Nothing
 727                 Nothing -> Nothing
 728
 729 breakColon :: String -> Maybe (String, String)
 730 breakColon xs = case break (':' ==) xs of
 731                     (ys, _:zs) -> Just (ys, zs)
 732                     _ -> Nothing
 733
 734 breakIntColon :: String -> Maybe (Int, String)
 735 breakIntColon xs = case break (':' ==) xs of
 736                        (ys, _:zs)
 737                         | not (null ys) && all isAscii ys && all isDigit ys ->
 738                            Just (read ys, zs)
 739                        _ -> Nothing
 740
 741 data BuildMessage
 742   = BuildMsg   !SDoc
 743   | BuildError !SrcLoc !SDoc
 744   | EOF
 745
 746 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 747 -- a) trace the command (at two levels of verbosity)
 748 -- b) don't do it at all if dry-run is set
 749 traceCmd dflags phase_name cmd_line action
 750  = do   { let verb = verbosity dflags
 751         ; showPass dflags phase_name
 752         ; debugTraceMsg dflags 3 (text cmd_line)
 753         ; hFlush stderr
 754
 755            -- Test for -n flag
 756         ; unless (dopt Opt_DryRun dflags) $ do {
 757
 758            -- And run it!
 759         ; action `IO.catch` handle_exn verb
 760         }}
 761   where
 762     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
 763                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
 764                               ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
 765 \end{code}
 766
 767 %************************************************************************
 768 %*                                                                      *
 769 \subsection{Support code}
 770 %*                                                                      *
 771 %************************************************************************
 772
 773 \begin{code}
 774 -----------------------------------------------------------------------------
 775 -- Define       getBaseDir     :: IO (Maybe String)
 776
 777 getBaseDir :: IO (Maybe String)
 778 #if defined(mingw32_HOST_OS)
 779 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
 780 -- return the path $(stuff)/lib.
 781 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 782                 buf <- mallocArray len
 783                 ret <- getModuleFileName nullPtr buf len
 784                 if ret == 0 then free buf >> return Nothing
 785                             else do s <- peekCString buf
 786                                     free buf
 787                                     return (Just (rootDir s))
 788   where
 789     rootDir s = case splitFileName $ normalise s of
 790                 (d, ghc_exe)
 791                  | lower ghc_exe `elem` ["ghc.exe",
 792                                          "ghc-stage1.exe",
 793                                          "ghc-stage2.exe",
 794                                          "ghc-stage3.exe"] ->
 795                     case splitFileName $ takeDirectory d of
 796                     -- ghc is in $topdir/bin/ghc.exe
 797                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
 798                     _ -> fail
 799                 _ -> fail
 800         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
 801               lower = map toLower
 802
 803 foreign import stdcall unsafe "GetModuleFileNameA"
 804   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 805 #else
 806 getBaseDir = return Nothing
 807 #endif
 808
 809 #ifdef mingw32_HOST_OS
 810 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 811 #else
 812 getProcessID :: IO Int
 813 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 814 #endif
 815
 816 -- Divvy up text stream into lines, taking platform dependent
 817 -- line termination into account.
 818 linesPlatform :: String -> [String]
 819 #if !defined(mingw32_HOST_OS)
 820 linesPlatform ls = lines ls
 821 #else
 822 linesPlatform "" = []
 823 linesPlatform xs =
 824   case lineBreak xs of
 825     (as,xs1) -> as : linesPlatform xs1
 826   where
 827    lineBreak "" = ("","")
 828    lineBreak ('\r':'\n':xs) = ([],xs)
 829    lineBreak ('\n':xs) = ([],xs)
 830    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
 831
 832 #endif
 833
 834 \end{code}