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