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