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