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