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