ghc/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 module SysTools (
  11         -- Initialisation
  12         initSysTools,
  13
  14         getTopDir,              -- IO String    -- The value of $topdir
  15         getPackageConfigPath,   -- IO String    -- Where package.conf is
  16         getUsageMsgPaths,       -- IO (String,String)
  17
  18         -- Interface to system tools
  19         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  20         runPp,                   -- [Option] -> IO ()
  21         runMangle, runSplit,     -- [Option] -> IO ()
  22         runAs, runLink,          -- [Option] -> IO ()
  23         runMkDLL,
  24
  25         touch,                  -- String -> String -> IO ()
  26         copy,                   -- String -> String -> String -> IO ()
  27         normalisePath,          -- FilePath -> FilePath
  28
  29         -- Temporary-file management
  30         setTmpDir,
  31         newTempName,
  32         cleanTempFiles, cleanTempFilesExcept,
  33         addFilesToClean,
  34
  35         -- System interface
  36         system,                 -- String -> IO ExitCode
  37
  38         -- Misc
  39         getSysMan,              -- IO String    Parallel system only
  40
  41         Option(..)
  42
  43  ) where
  44
  45 #include "HsVersions.h"
  46
  47 import DriverPhases     ( isHaskellUserSrcFilename )
  48 import Config
  49 import Outputable
  50 import Panic            ( GhcException(..) )
  51 import Util             ( Suffix, global, notNull, consIORef )
  52 import DynFlags         ( DynFlags(..), DynFlag(..), dopt, Option(..) )
  53
  54 import EXCEPTION        ( throwDyn )
  55 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  56 import DATA_INT
  57
  58 import Monad            ( when, unless )
  59 import System           ( ExitCode(..), getEnv, system )
  60 import IO               ( try, catch,
  61                           openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
  62                           stderr )
  63 import Directory        ( doesFileExist, removeFile )
  64 import List             ( partition )
  65
  66 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
  67 -- lines on mingw32, so we disallow it now.
  68 #if __GLASGOW_HASKELL__ < 500
  69 #error GHC >= 5.00 is required for bootstrapping GHC
  70 #endif
  71
  72 #ifndef mingw32_HOST_OS
  73 #if __GLASGOW_HASKELL__ > 504
  74 import qualified System.Posix.Internals
  75 #else
  76 import qualified Posix
  77 #endif
  78 #else /* Must be Win32 */
  79 import List             ( isPrefixOf )
  80 import Util             ( dropList )
  81 import Foreign
  82 import CString          ( CString, peekCString )
  83 #endif
  84
  85 #if __GLASGOW_HASKELL__ < 603
  86 -- rawSystem comes from libghccompat.a in stage1
  87 import Compat.RawSystem ( rawSystem )
  88 #else
  89 import System.Cmd       ( rawSystem )
  90 #endif
  91 \end{code}
  92
  93
  94                 The configuration story
  95                 ~~~~~~~~~~~~~~~~~~~~~~~
  96
  97 GHC needs various support files (library packages, RTS etc), plus
  98 various auxiliary programs (cp, gcc, etc).  It finds these in one
  99 of two places:
 100
 101 * When running as an *installed program*, GHC finds most of this support
 102   stuff in the installed library tree.  The path to this tree is passed
 103   to GHC via the -B flag, and given to initSysTools .
 104
 105 * When running *in-place* in a build tree, GHC finds most of this support
 106   stuff in the build tree.  The path to the build tree is, again passed
 107   to GHC via -B.
 108
 109 GHC tells which of the two is the case by seeing whether package.conf
 110 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
 111
 112
 113 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 114 are, and initialises mutable variables to make it easy to call them.
 115 To to this, it makes use of definitions in Config.hs, which is a Haskell
 116 file containing variables whose value is figured out by the build system.
 117
 118 Config.hs contains two sorts of things
 119
 120   cGCC,         The *names* of the programs
 121   cCPP            e.g.  cGCC = gcc
 122   cUNLIT                cCPP = gcc -E
 123   etc           They do *not* include paths
 124
 125
 126   cUNLIT_DIR_REL   The *path* to the directory containing unlit, split etc
 127   cSPLIT_DIR_REL   *relative* to the root of the build tree,
 128                    for use when running *in-place* in a build tree (only)
 129
 130
 131
 132 ---------------------------------------------
 133 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 134
 135 Another hair-brained scheme for simplifying the current tool location
 136 nightmare in GHC: Simon originally suggested using another
 137 configuration file along the lines of GCC's specs file - which is fine
 138 except that it means adding code to read yet another configuration
 139 file.  What I didn't notice is that the current package.conf is
 140 general enough to do this:
 141
 142 Package
 143     {name = "tools",    import_dirs = [],  source_dirs = [],
 144      library_dirs = [], hs_libraries = [], extra_libraries = [],
 145      include_dirs = [], c_includes = [],   package_deps = [],
 146      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
 147      extra_cc_opts = [], extra_ld_opts = []}
 148
 149 Which would have the advantage that we get to collect together in one
 150 place the path-specific package stuff with the path-specific tool
 151 stuff.
 152                 End of NOTES
 153 ---------------------------------------------
 154
 155
 156 %************************************************************************
 157 %*                                                                      *
 158 \subsection{Global variables to contain system programs}
 159 %*                                                                      *
 160 %************************************************************************
 161
 162 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
 163 (See remarks under pathnames below)
 164
 165 \begin{code}
 166 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 167 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 168
 169 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 170 GLOBAL_VAR(v_Path_usages,         error "ghc_usage.txt",       (String,String))
 171
 172 GLOBAL_VAR(v_TopDir,    error "TopDir", String)         -- -B<dir>
 173
 174 -- Parallel system only
 175 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 176
 177 -- ways to get at some of these variables from outside this module
 178 getPackageConfigPath = readIORef v_Path_package_config
 179 getTopDir            = readIORef v_TopDir
 180 \end{code}
 181
 182
 183 %************************************************************************
 184 %*                                                                      *
 185 \subsection{Initialisation}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 \begin{code}
 190 initSysTools :: [String]        -- Command-line arguments starting "-B"
 191
 192              -> DynFlags
 193              -> IO DynFlags     -- Set all the mutable variables above, holding
 194                                 --      (a) the system programs
 195                                 --      (b) the package-config file
 196                                 --      (c) the GHC usage message
 197
 198
 199 initSysTools minusB_args dflags
 200   = do  { (am_installed, top_dir) <- findTopDir minusB_args
 201         ; writeIORef v_TopDir top_dir
 202                 -- top_dir
 203                 --      for "installed" this is the root of GHC's support files
 204                 --      for "in-place" it is the root of the build tree
 205                 -- NB: top_dir is assumed to be in standard Unix format '/' separated
 206
 207         ; let installed, installed_bin :: FilePath -> FilePath
 208               installed_bin pgm   =  pgmPath top_dir pgm
 209               installed     file  =  pgmPath top_dir file
 210               inplace dir   pgm   =  pgmPath (top_dir `slash`
 211                                                 cPROJECT_DIR `slash` dir) pgm
 212
 213         ; let pkgconfig_path
 214                 | am_installed = installed "package.conf"
 215                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
 216
 217               ghc_usage_msg_path
 218                 | am_installed = installed "ghc-usage.txt"
 219                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
 220
 221               ghci_usage_msg_path
 222                 | am_installed = installed "ghci-usage.txt"
 223                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
 224
 225                 -- For all systems, unlit, split, mangle are GHC utilities
 226                 -- architecture-specific stuff is done when building Config.hs
 227               unlit_path
 228                 | am_installed = installed_bin cGHC_UNLIT_PGM
 229                 | otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
 230
 231                 -- split and mangle are Perl scripts
 232               split_script
 233                 | am_installed = installed_bin cGHC_SPLIT_PGM
 234                 | otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
 235
 236               mangle_script
 237                 | am_installed = installed_bin cGHC_MANGLER_PGM
 238                 | otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
 239
 240 #ifndef mingw32_HOST_OS
 241         -- check whether TMPDIR is set in the environment
 242         ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
 243                      setTmpDir dir
 244                      return ()
 245                  )
 246 #else
 247           -- On Win32, consult GetTempPath() for a temp dir.
 248           --  => it first tries TMP, TEMP, then finally the
 249           --   Windows directory(!). The directory is in short-path
 250           --   form.
 251         ; IO.try (do
 252                 let len = (2048::Int)
 253                 buf  <- mallocArray len
 254                 ret  <- getTempPath len buf
 255                 tdir <-
 256                   if ret == 0 then do
 257                       -- failed, consult TMPDIR.
 258                      free buf
 259                      getEnv "TMPDIR"
 260                    else do
 261                      s <- peekCString buf
 262                      free buf
 263                      return s
 264                 setTmpDir tdir)
 265 #endif
 266
 267         -- Check that the package config exists
 268         ; config_exists <- doesFileExist pkgconfig_path
 269         ; when (not config_exists) $
 270              throwDyn (InstallationError
 271                          ("Can't find package.conf as " ++ pkgconfig_path))
 272
 273 #if defined(mingw32_HOST_OS)
 274         --              WINDOWS-SPECIFIC STUFF
 275         -- On Windows, gcc and friends are distributed with GHC,
 276         --      so when "installed" we look in TopDir/bin
 277         -- When "in-place" we look wherever the build-time configure
 278         --      script found them
 279         -- When "install" we tell gcc where its specs file + exes are (-B)
 280         --      and also some places to pick up include files.  We need
 281         --      to be careful to put all necessary exes in the -B place
 282         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 283         --      then tries to run unadorned "as", "ld", etc, and will
 284         --      pick up whatever happens to be lying around in the path,
 285         --      possibly including those from a cygwin install on the target,
 286         --      which is exactly what we're trying to avoid.
 287         ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
 288               (gcc_prog,gcc_args)
 289                 | am_installed = (installed_bin "gcc", [gcc_b_arg])
 290                 | otherwise    = (cGCC, [])
 291                 -- The trailing "/" is absolutely essential; gcc seems
 292                 -- to construct file names simply by concatenating to
 293                 -- this -B path with no extra slash We use "/" rather
 294                 -- than "\\" because otherwise "\\\" is mangled
 295                 -- later on; although gcc_args are in NATIVE format,
 296                 -- gcc can cope
 297                 --      (see comments with declarations of global variables)
 298                 --
 299                 -- The quotes round the -B argument are in case TopDir
 300                 -- has spaces in it
 301
 302               perl_path | am_installed = installed_bin cGHC_PERL
 303                         | otherwise    = cGHC_PERL
 304
 305         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 306         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY_PGM
 307                           | otherwise    = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
 308
 309         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 310         -- a call to Perl to get the invocation of split and mangle
 311         ; let (split_prog,  split_args)  = (perl_path, [Option split_script])
 312               (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
 313
 314         ; let (mkdll_prog, mkdll_args)
 315                 | am_installed =
 316                     (pgmPath (installed "gcc-lib/") cMKDLL,
 317                      [ Option "--dlltool-name",
 318                        Option (pgmPath (installed "gcc-lib/") "dlltool"),
 319                        Option "--driver-name",
 320                        Option gcc_prog, gcc_b_arg ])
 321                 | otherwise    = (cMKDLL, [])
 322 #else
 323         --              UNIX-SPECIFIC STUFF
 324         -- On Unix, the "standard" tools are assumed to be
 325         -- in the same place whether we are running "in-place" or "installed"
 326         -- That place is wherever the build-time configure script found them.
 327         ; let   gcc_prog   = cGCC
 328                 gcc_args   = []
 329                 touch_path = "touch"
 330                 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
 331                 mkdll_args = []
 332
 333         -- On Unix, scripts are invoked using the '#!' method.  Binary
 334         -- installations of GHC on Unix place the correct line on the front
 335         -- of the script at installation time, so we don't want to wire-in
 336         -- our knowledge of $(PERL) on the host system here.
 337         ; let (split_prog,  split_args)  = (split_script,  [])
 338               (mangle_prog, mangle_args) = (mangle_script, [])
 339 #endif
 340
 341         -- cpp is derived from gcc on all platforms
 342         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
 343         -- Config.hs one day.
 344         ; let cpp_path  = (gcc_prog, gcc_args ++
 345                            (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 346
 347         -- For all systems, copy and remove are provided by the host
 348         -- system; architecture-specific stuff is done when building Config.hs
 349         ; let   cp_path = cGHC_CP
 350
 351         -- Other things being equal, as and ld are simply gcc
 352         ; let   (as_prog,as_args)  = (gcc_prog,gcc_args)
 353                 (ld_prog,ld_args)  = (gcc_prog,gcc_args)
 354
 355         -- Initialise the global vars
 356         ; writeIORef v_Path_package_config pkgconfig_path
 357         ; writeIORef v_Path_usages         (ghc_usage_msg_path,
 358                                             ghci_usage_msg_path)
 359
 360         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 361                 -- Hans: this isn't right in general, but you can
 362                 -- elaborate it in the same way as the others
 363
 364         ; writeIORef v_Pgm_T               touch_path
 365         ; writeIORef v_Pgm_CP              cp_path
 366
 367         ; return dflags{
 368                         pgm_L   = unlit_path,
 369                         pgm_P   = cpp_path,
 370                         pgm_F   = "",
 371                         pgm_c   = (gcc_prog,gcc_args),
 372                         pgm_m   = (mangle_prog,mangle_args),
 373                         pgm_s   = (split_prog,split_args),
 374                         pgm_a   = (as_prog,as_args),
 375                         pgm_l   = (ld_prog,ld_args),
 376                         pgm_dll = (mkdll_prog,mkdll_args) }
 377         }
 378
 379 #if defined(mingw32_HOST_OS)
 380 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
 381 #endif
 382 \end{code}
 383
 384 \begin{code}
 385 -- Find TopDir
 386 --      for "installed" this is the root of GHC's support files
 387 --      for "in-place" it is the root of the build tree
 388 --
 389 -- Plan of action:
 390 -- 1. Set proto_top_dir
 391 --      a) look for (the last) -B flag, and use it
 392 --      b) if there are no -B flags, get the directory
 393 --         where GHC is running (only on Windows)
 394 --
 395 -- 2. If package.conf exists in proto_top_dir, we are running
 396 --      installed; and TopDir = proto_top_dir
 397 --
 398 -- 3. Otherwise we are running in-place, so
 399 --      proto_top_dir will be /...stuff.../ghc/compiler
 400 --      Set TopDir to /...stuff..., which is the root of the build tree
 401 --
 402 -- This is very gruesome indeed
 403
 404 findTopDir :: [String]
 405           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 406                  String)        -- TopDir (in Unix format '/' separated)
 407
 408 findTopDir minusbs
 409   = do { top_dir <- get_proto
 410         -- Discover whether we're running in a build tree or in an installation,
 411         -- by looking for the package configuration file.
 412        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 413
 414        ; return (am_installed, top_dir)
 415        }
 416   where
 417     -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
 418     get_proto | notNull minusbs
 419               = return (normalisePath (drop 2 (last minusbs)))  -- 2 for "-B"
 420               | otherwise
 421               = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
 422                    ; case maybe_exec_dir of       -- (only works on Windows;
 423                                                   --  returns Nothing on Unix)
 424                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 425                         Just dir -> return dir
 426                    }
 427 \end{code}
 428
 429
 430 %************************************************************************
 431 %*                                                                      *
 432 \subsection{Running an external program}
 433 %*                                                                      *
 434 %************************************************************************
 435
 436
 437 \begin{code}
 438 runUnlit :: DynFlags -> [Option] -> IO ()
 439 runUnlit dflags args = do
 440   let p = pgm_L dflags
 441   runSomething dflags "Literate pre-processor" p args
 442
 443 runCpp :: DynFlags -> [Option] -> IO ()
 444 runCpp dflags args =   do
 445   let (p,args0) = pgm_P dflags
 446   runSomething dflags "C pre-processor" p (args0 ++ args)
 447
 448 runPp :: DynFlags -> [Option] -> IO ()
 449 runPp dflags args =   do
 450   let p = pgm_F dflags
 451   runSomething dflags "Haskell pre-processor" p args
 452
 453 runCc :: DynFlags -> [Option] -> IO ()
 454 runCc dflags args =   do
 455   let (p,args0) = pgm_c dflags
 456   runSomething dflags "C Compiler" p (args0++args)
 457
 458 runMangle :: DynFlags -> [Option] -> IO ()
 459 runMangle dflags args = do
 460   let (p,args0) = pgm_m dflags
 461   runSomething dflags "Mangler" p (args0++args)
 462
 463 runSplit :: DynFlags -> [Option] -> IO ()
 464 runSplit dflags args = do
 465   let (p,args0) = pgm_s dflags
 466   runSomething dflags "Splitter" p (args0++args)
 467
 468 runAs :: DynFlags -> [Option] -> IO ()
 469 runAs dflags args = do
 470   let (p,args0) = pgm_a dflags
 471   runSomething dflags "Assembler" p (args0++args)
 472
 473 runLink :: DynFlags -> [Option] -> IO ()
 474 runLink dflags args = do
 475   let (p,args0) = pgm_l dflags
 476   runSomething dflags "Linker" p (args0++args)
 477
 478 runMkDLL :: DynFlags -> [Option] -> IO ()
 479 runMkDLL dflags args = do
 480   let (p,args0) = pgm_dll dflags
 481   runSomething dflags "Make DLL" p (args0++args)
 482
 483 touch :: DynFlags -> String -> String -> IO ()
 484 touch dflags purpose arg =  do
 485   p <- readIORef v_Pgm_T
 486   runSomething dflags purpose p [FileOption "" arg]
 487
 488 copy :: DynFlags -> String -> String -> String -> IO ()
 489 copy dflags purpose from to = do
 490   when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 491
 492   h <- openFile to WriteMode
 493   ls <- readFile from -- inefficient, but it'll do for now.
 494                       -- ToDo: speed up via slurping.
 495   hPutStr h ls
 496   hClose h
 497
 498 \end{code}
 499
 500 \begin{code}
 501 getSysMan :: IO String  -- How to invoke the system manager
 502                         -- (parallel system only)
 503 getSysMan = readIORef v_Pgm_sysman
 504 \end{code}
 505
 506 \begin{code}
 507 getUsageMsgPaths :: IO (FilePath,FilePath)
 508           -- the filenames of the usage messages (ghc, ghci)
 509 getUsageMsgPaths = readIORef v_Path_usages
 510 \end{code}
 511
 512
 513 %************************************************************************
 514 %*                                                                      *
 515 \subsection{Managing temporary files
 516 %*                                                                      *
 517 %************************************************************************
 518
 519 \begin{code}
 520 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 521 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 522         -- v_TmpDir has no closing '/'
 523 \end{code}
 524
 525 \begin{code}
 526 setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
 527     where
 528 #if !defined(mingw32_HOST_OS)
 529      canonicalise p = normalisePath p
 530 #else
 531         -- Canonicalisation of temp path under win32 is a bit more
 532         -- involved: (a) strip trailing slash,
 533         --           (b) normalise slashes
 534         --           (c) just in case, if there is a prefix /cygdrive/x/, change to x:
 535         --
 536      canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
 537
 538         -- if we're operating under cygwin, and TMP/TEMP is of
 539         -- the form "/cygdrive/drive/path", translate this to
 540         -- "drive:/path" (as GHC isn't a cygwin app and doesn't
 541         -- understand /cygdrive paths.)
 542      xltCygdrive path
 543       | "/cygdrive/" `isPrefixOf` path =
 544           case drop (length "/cygdrive/") path of
 545             drive:xs@('/':_) -> drive:':':xs
 546             _ -> path
 547       | otherwise = path
 548
 549         -- strip the trailing backslash (awful, but we only do this once).
 550      removeTrailingSlash path =
 551        case last path of
 552          '/'  -> init path
 553          '\\' -> init path
 554          _    -> path
 555 #endif
 556
 557 cleanTempFiles :: DynFlags -> IO ()
 558 cleanTempFiles dflags
 559    = do fs <- readIORef v_FilesToClean
 560         removeTmpFiles dflags fs
 561         writeIORef v_FilesToClean []
 562
 563 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 564 cleanTempFilesExcept dflags dont_delete
 565    = do files <- readIORef v_FilesToClean
 566         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 567         removeTmpFiles dflags to_delete
 568         writeIORef v_FilesToClean to_keep
 569
 570
 571 -- find a temporary name that doesn't already exist.
 572 newTempName :: Suffix -> IO FilePath
 573 newTempName extn
 574   = do x <- getProcessID
 575        tmp_dir <- readIORef v_TmpDir
 576        findTempName tmp_dir x
 577   where
 578     findTempName tmp_dir x
 579       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 580            b  <- doesFileExist filename
 581            if b then findTempName tmp_dir (x+1)
 582                 else do consIORef v_FilesToClean filename -- clean it up later
 583                         return filename
 584
 585 addFilesToClean :: [FilePath] -> IO ()
 586 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 587 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
 588
 589 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
 590 removeTmpFiles dflags fs
 591   = warnNon $
 592     traceCmd dflags "Deleting temp files"
 593              ("Deleting: " ++ unwords deletees)
 594              (mapM_ rm deletees)
 595   where
 596     verb = verbosity dflags
 597
 598      -- Flat out refuse to delete files that are likely to be source input
 599      -- files (is there a worse bug than having a compiler delete your source
 600      -- files?)
 601      --
 602      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 603      -- the condition.
 604     warnNon act
 605      | null non_deletees = act
 606      | otherwise         = do
 607         hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
 608         act
 609
 610     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 611
 612     rm f = removeFile f `IO.catch`
 613                 (\_ignored ->
 614                     when (verb >= 2) $
 615                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 616                 )
 617
 618
 619 -----------------------------------------------------------------------------
 620 -- Running an external program
 621
 622 runSomething :: DynFlags
 623              -> String          -- For -v message
 624              -> String          -- Command name (possibly a full path)
 625                                 --      assumed already dos-ified
 626              -> [Option]        -- Arguments
 627                                 --      runSomething will dos-ify them
 628              -> IO ()
 629
 630 runSomething dflags phase_name pgm args = do
 631   let real_args = filter notNull (map showOpt args)
 632   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
 633   exit_code <- rawSystem pgm real_args
 634   case exit_code of
 635      ExitSuccess ->
 636         return ()
 637      -- rawSystem returns (ExitFailure 127) if the exec failed for any
 638      -- reason (eg. the program doesn't exist).  This is the only clue
 639      -- we have, but we need to report something to the user because in
 640      -- the case of a missing program there will otherwise be no output
 641      -- at all.
 642      ExitFailure 127 ->
 643         throwDyn (InstallationError ("could not execute: " ++ pgm))
 644      ExitFailure _other ->
 645         throwDyn (PhaseFailed phase_name exit_code)
 646
 647 showOpt (FileOption pre f) = pre ++ platformPath f
 648 showOpt (Option "") = ""
 649 showOpt (Option s)  = s
 650
 651 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 652 -- a) trace the command (at two levels of verbosity)
 653 -- b) don't do it at all if dry-run is set
 654 traceCmd dflags phase_name cmd_line action
 655  = do   { let verb = verbosity dflags
 656         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 657         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 658         ; hFlush stderr
 659
 660            -- Test for -n flag
 661         ; unless (dopt Opt_DryRun dflags) $ do {
 662
 663            -- And run it!
 664         ; action `IO.catch` handle_exn verb
 665         }}
 666   where
 667     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 668                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
 669                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 670 \end{code}
 671
 672
 673 %************************************************************************
 674 %*                                                                      *
 675 \subsection{Path names}
 676 %*                                                                      *
 677 %************************************************************************
 678
 679 We maintain path names in Unix form ('/'-separated) right until
 680 the last moment.  On Windows we dos-ify them just before passing them
 681 to the Windows command.
 682
 683 The alternative, of using '/' consistently on Unix and '\' on Windows,
 684 proved quite awkward.  There were a lot more calls to platformPath,
 685 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 686 interpreted a command line 'foo\baz' as 'foobaz'.
 687
 688 \begin{code}
 689 -----------------------------------------------------------------------------
 690 -- Convert filepath into platform / MSDOS form.
 691
 692 normalisePath :: String -> String
 693 -- Just changes '\' to '/'
 694
 695 pgmPath :: String               -- Directory string in Unix format
 696         -> String               -- Program name with no directory separators
 697                                 --      (e.g. copy /y)
 698         -> String               -- Program invocation string in native format
 699
 700
 701
 702 #if defined(mingw32_HOST_OS)
 703 --------------------- Windows version ------------------
 704 normalisePath xs = subst '\\' '/' xs
 705 platformPath p   = subst '/' '\\' p
 706 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 707
 708 subst a b ls = map (\ x -> if x == a then b else x) ls
 709 #else
 710 --------------------- Non-Windows version --------------
 711 normalisePath xs   = xs
 712 pgmPath dir pgm    = dir ++ '/' : pgm
 713 platformPath stuff = stuff
 714 --------------------------------------------------------
 715 #endif
 716
 717 \end{code}
 718
 719
 720 -----------------------------------------------------------------------------
 721    Path name construction
 722
 723 \begin{code}
 724 slash            :: String -> String -> String
 725 slash s1 s2 = s1 ++ ('/' : s2)
 726 \end{code}
 727
 728
 729 %************************************************************************
 730 %*                                                                      *
 731 \subsection{Support code}
 732 %*                                                                      *
 733 %************************************************************************
 734
 735 \begin{code}
 736 -----------------------------------------------------------------------------
 737 -- Define       getBaseDir     :: IO (Maybe String)
 738
 739 #if defined(mingw32_HOST_OS)
 740 getBaseDir :: IO (Maybe String)
 741 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 742 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 743 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 744                 buf <- mallocArray len
 745                 ret <- getModuleFileName nullPtr buf len
 746                 if ret == 0 then free buf >> return Nothing
 747                             else do s <- peekCString buf
 748                                     free buf
 749                                     return (Just (rootDir s))
 750   where
 751     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 752
 753 foreign import stdcall unsafe "GetModuleFileNameA"
 754   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 755 #else
 756 getBaseDir :: IO (Maybe String) = do return Nothing
 757 #endif
 758
 759 #ifdef mingw32_HOST_OS
 760 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 761 #elif __GLASGOW_HASKELL__ > 504
 762 getProcessID :: IO Int
 763 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 764 #else
 765 getProcessID :: IO Int
 766 getProcessID = Posix.getProcessID
 767 #endif
 768
 769 \end{code}