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