ghc/compiler/main/SysTools.lhs

   1 -----------------------------------------------------------------------------
   2 -- $Id: SysTools.lhs,v 1.53 2001/08/16 14:43:59 rrt Exp $
   3 --
   4 -- (c) The University of Glasgow 2001
   5 --
   6 -- Access to system tools: gcc, cp, rm etc
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 \begin{code}
  11 module SysTools (
  12         -- Initialisation
  13         initSysTools,
  14         setPgm,                 -- String -> IO ()
  15                                 -- Command-line override
  16         setDryRun,
  17
  18         getTopDir,              -- IO String    -- The value of $libdir
  19         getPackageConfigPath,   -- IO String    -- Where package.conf is
  20
  21         -- Interface to system tools
  22         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  23         runMangle, runSplit,     -- [Option] -> IO ()
  24         runAs, runLink,          -- [Option] -> IO ()
  25         runMkDLL,
  26 #ifdef ILX
  27         runIlx2il, runIlasm,     -- [String] -> IO ()
  28 #endif
  29
  30
  31         touch,                  -- String -> String -> IO ()
  32         copy,                   -- String -> String -> String -> IO ()
  33         unDosifyPath,           -- String -> String
  34
  35         -- Temporary-file management
  36         setTmpDir,
  37         newTempName,
  38         cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
  39         addFilesToClean,
  40
  41         -- System interface
  42         getProcessID,           -- IO Int
  43         system,                 -- String -> IO ExitCode
  44
  45         -- Misc
  46         showGhcUsage,           -- IO ()        Shows usage message and exits
  47         getSysMan,              -- IO String    Parallel system only
  48
  49         Option(..)
  50
  51  ) where
  52
  53 import DriverUtil
  54 import Config
  55 import Outputable
  56 import Panic            ( progName, GhcException(..) )
  57 import Util             ( global )
  58 import CmdLineOpts      ( dynFlag, verbosity )
  59
  60 import Exception        ( throwDyn, catchAllIO )
  61 import IO
  62 import Directory        ( doesFileExist, removeFile )
  63 import IOExts           ( IORef, readIORef, writeIORef )
  64 import Monad            ( when, unless )
  65 import System           ( ExitCode(..), exitWith, getEnv, system )
  66 import CString
  67 import Int
  68 import Addr
  69
  70 #include "../includes/config.h"
  71
  72 #ifndef mingw32_TARGET_OS
  73 import qualified Posix
  74 #else
  75 import List             ( isPrefixOf )
  76 import MarshalArray
  77 #endif
  78
  79 -- use the line below when we can be sure of compiling with GHC >=
  80 -- 5.02, and remove the implementation of rawSystem at the end of this
  81 -- file
  82 import PrelIOBase -- this can be removed when SystemExts is used
  83 import CError     ( throwErrnoIfMinus1 ) -- as can this
  84 -- import SystemExts       ( rawSystem )
  85
  86 #include "HsVersions.h"
  87
  88 \end{code}
  89
  90
  91                 The configuration story
  92                 ~~~~~~~~~~~~~~~~~~~~~~~
  93
  94 GHC needs various support files (library packages, RTS etc), plus
  95 various auxiliary programs (cp, gcc, etc).  It finds these in one
  96 of two places:
  97
  98 * When running as an *installed program*, GHC finds most of this support
  99   stuff in the installed library tree.  The path to this tree is passed
 100   to GHC via the -B flag, and given to initSysTools .
 101
 102 * When running *in-place* in a build tree, GHC finds most of this support
 103   stuff in the build tree.  The path to the build tree is, again passed
 104   to GHC via -B.
 105
 106 GHC tells which of the two is the case by seeing whether package.conf
 107 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
 108
 109
 110 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 111 are, and initialises mutable variables to make it easy to call them.
 112 To to this, it makes use of definitions in Config.hs, which is a Haskell
 113 file containing variables whose value is figured out by the build system.
 114
 115 Config.hs contains two sorts of things
 116
 117   cGCC,         The *names* of the programs
 118   cCPP            e.g.  cGCC = gcc
 119   cUNLIT                cCPP = gcc -E
 120   etc           They do *not* include paths
 121
 122
 123   cUNLIT_DIR    The *path* to the directory containing unlit, split etc
 124   cSPLIT_DIR    *relative* to the root of the build tree,
 125                 for use when running *in-place* in a build tree (only)
 126
 127
 128
 129 ---------------------------------------------
 130 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 131
 132 Another hair-brained scheme for simplifying the current tool location
 133 nightmare in GHC: Simon originally suggested using another
 134 configuration file along the lines of GCC's specs file - which is fine
 135 except that it means adding code to read yet another configuration
 136 file.  What I didn't notice is that the current package.conf is
 137 general enough to do this:
 138
 139 Package
 140     {name = "tools",    import_dirs = [],  source_dirs = [],
 141      library_dirs = [], hs_libraries = [], extra_libraries = [],
 142      include_dirs = [], c_includes = [],   package_deps = [],
 143      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
 144      extra_cc_opts = [], extra_ld_opts = []}
 145
 146 Which would have the advantage that we get to collect together in one
 147 place the path-specific package stuff with the path-specific tool
 148 stuff.
 149                 End of NOTES
 150 ---------------------------------------------
 151
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection{Global variables to contain system programs}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
 160 (See remarks under pathnames below)
 161
 162 \begin{code}
 163 GLOBAL_VAR(v_Pgm_L,     error "pgm_L",   String)        -- unlit
 164 GLOBAL_VAR(v_Pgm_P,     error "pgm_P",   String)        -- cpp
 165 GLOBAL_VAR(v_Pgm_c,     error "pgm_c",   String)        -- gcc
 166 GLOBAL_VAR(v_Pgm_m,     error "pgm_m",   String)        -- asm code mangler
 167 GLOBAL_VAR(v_Pgm_s,     error "pgm_s",   String)        -- asm code splitter
 168 GLOBAL_VAR(v_Pgm_a,     error "pgm_a",   String)        -- as
 169 #ifdef ILX
 170 GLOBAL_VAR(v_Pgm_I,     error "pgm_I",   String)        -- ilx2il
 171 GLOBAL_VAR(v_Pgm_i,     error "pgm_i",   String)        -- ilasm
 172 #endif
 173 GLOBAL_VAR(v_Pgm_l,     error "pgm_l",   String)        -- ld
 174 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)        -- mkdll
 175
 176 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 177 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 178
 179 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 180 GLOBAL_VAR(v_Path_usage,          error "ghc_usage.txt",       String)
 181
 182 GLOBAL_VAR(v_TopDir,    error "TopDir", String)         -- -B<dir>
 183
 184 -- Parallel system only
 185 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 186
 187 -- ways to get at some of these variables from outside this module
 188 getPackageConfigPath = readIORef v_Path_package_config
 189 getTopDir            = readIORef v_TopDir
 190 \end{code}
 191
 192
 193 %************************************************************************
 194 %*                                                                      *
 195 \subsection{Initialisation}
 196 %*                                                                      *
 197 %************************************************************************
 198
 199 \begin{code}
 200 initSysTools :: [String]        -- Command-line arguments starting "-B"
 201
 202              -> IO ()           -- Set all the mutable variables above, holding
 203                                 --      (a) the system programs
 204                                 --      (b) the package-config file
 205                                 --      (c) the GHC usage message
 206
 207
 208 initSysTools minusB_args
 209   = do  { (am_installed, top_dir) <- findTopDir minusB_args
 210         ; writeIORef v_TopDir top_dir
 211                 -- top_dir
 212                 --      for "installed" this is the root of GHC's support files
 213                 --      for "in-place" it is the root of the build tree
 214                 -- NB: top_dir is assumed to be in standard Unix format '/' separated
 215
 216         ; let installed, installed_bin :: FilePath -> FilePath
 217               installed_bin pgm   =  pgmPath (top_dir `slash` "extra-bin") pgm
 218               installed     file  =  pgmPath top_dir file
 219               inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm
 220
 221         ; let pkgconfig_path
 222                 | am_installed = installed "package.conf"
 223                 | otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"
 224
 225               ghc_usage_msg_path
 226                 | am_installed = installed "ghc-usage.txt"
 227                 | otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
 228
 229                 -- For all systems, unlit, split, mangle are GHC utilities
 230                 -- architecture-specific stuff is done when building Config.hs
 231               unlit_path
 232                 | am_installed = installed_bin cGHC_UNLIT
 233                 | otherwise    = inplace cGHC_UNLIT_DIR cGHC_UNLIT
 234
 235                 -- split and mangle are Perl scripts
 236               split_script
 237                 | am_installed = installed_bin cGHC_SPLIT
 238                 | otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
 239
 240               mangle_script
 241                 | am_installed = installed_bin cGHC_MANGLER
 242                 | otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER
 243
 244 #ifndef mingw32_TARGET_OS
 245         -- check whether TMPDIR is set in the environment
 246         ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
 247                      setTmpDir dir
 248                      return ()
 249                  )
 250 #endif
 251
 252         -- Check that the package config exists
 253         ; config_exists <- doesFileExist pkgconfig_path
 254         ; when (not config_exists) $
 255              throwDyn (InstallationError
 256                          ("Can't find package.conf as " ++ pkgconfig_path))
 257
 258 #if defined(mingw32_TARGET_OS)
 259         --              WINDOWS-SPECIFIC STUFF
 260         -- On Windows, gcc and friends are distributed with GHC,
 261         --      so when "installed" we look in TopDir/bin
 262         -- When "in-place" we look wherever the build-time configure
 263         --      script found them
 264         -- When "install" we tell gcc where its specs file + exes are (-B)
 265         --      and also some places to pick up include files.  We need
 266         --      to be careful to put all necessary exes in the -B place
 267         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 268         --      then tries to run unadorned "as", "ld", etc, and will
 269         --      pick up whatever happens to be lying around in the path,
 270         --      possibly including those from a cygwin install on the target,
 271         --      which is exactly what we're trying to avoid.
 272         ; let gcc_path  | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
 273                         | otherwise    = cGCC
 274                 -- The trailing "/" is absolutely essential; gcc seems
 275                 -- to construct file names simply by concatenating to this
 276                 -- -B path with no extra slash
 277                 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
 278                 -- later on; although gcc_path is in NATIVE format, gcc can cope
 279                 --      (see comments with declarations of global variables)
 280                 --
 281                 -- The quotes round the -B argument are in case TopDir has spaces in it
 282
 283               perl_path | am_installed = installed_bin cGHC_PERL
 284                         | otherwise    = cGHC_PERL
 285
 286         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 287         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
 288                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 289
 290         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 291         -- a call to Perl to get the invocation of split and mangle
 292         ; let split_path  = perl_path ++ " \"" ++ split_script ++ "\""
 293               mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
 294
 295         ; let mkdll_path = cMKDLL
 296 #else
 297         --              UNIX-SPECIFIC STUFF
 298         -- On Unix, the "standard" tools are assumed to be
 299         -- in the same place whether we are running "in-place" or "installed"
 300         -- That place is wherever the build-time configure script found them.
 301         ; let   gcc_path   = cGCC
 302                 touch_path = cGHC_TOUCHY
 303                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 304
 305         -- On Unix, scripts are invoked using the '#!' method.  Binary
 306         -- installations of GHC on Unix place the correct line on the front
 307         -- of the script at installation time, so we don't want to wire-in
 308         -- our knowledge of $(PERL) on the host system here.
 309         ; let split_path  = split_script
 310               mangle_path = mangle_script
 311 #endif
 312
 313         -- cpp is derived from gcc on all platforms
 314         ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
 315
 316         -- For all systems, copy and remove are provided by the host
 317         -- system; architecture-specific stuff is done when building Config.hs
 318         ; let   cp_path = cGHC_CP
 319
 320         -- Other things being equal, as and ld are simply gcc
 321         ; let   as_path  = gcc_path
 322                 ld_path  = gcc_path
 323
 324 #ifdef ILX
 325        -- ilx2il and ilasm are specified in Config.hs
 326        ; let    ilx2il_path = cILX2IL
 327                 ilasm_path  = cILASM
 328 #endif
 329
 330         -- Initialise the global vars
 331         ; writeIORef v_Path_package_config pkgconfig_path
 332         ; writeIORef v_Path_usage          ghc_usage_msg_path
 333
 334         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 335                 -- Hans: this isn't right in general, but you can
 336                 -- elaborate it in the same way as the others
 337
 338         ; writeIORef v_Pgm_L               unlit_path
 339         ; writeIORef v_Pgm_P               cpp_path
 340         ; writeIORef v_Pgm_c               gcc_path
 341         ; writeIORef v_Pgm_m               mangle_path
 342         ; writeIORef v_Pgm_s               split_path
 343         ; writeIORef v_Pgm_a               as_path
 344 #ifdef ILX
 345         ; writeIORef v_Pgm_I               ilx2il_path
 346         ; writeIORef v_Pgm_i               ilasm_path
 347 #endif
 348         ; writeIORef v_Pgm_l               ld_path
 349         ; writeIORef v_Pgm_MkDLL           mkdll_path
 350         ; writeIORef v_Pgm_T               touch_path
 351         ; writeIORef v_Pgm_CP              cp_path
 352
 353         ; return ()
 354         }
 355 \end{code}
 356
 357 setPgm is called when a command-line option like
 358         -pgmLld
 359 is used to override a particular program with a new one
 360
 361 \begin{code}
 362 setPgm :: String -> IO ()
 363 -- The string is the flag, minus the '-pgm' prefix
 364 -- So the first character says which program to override
 365
 366 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 367 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 368 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 369 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 370 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 371 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 372 #ifdef ILX
 373 setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
 374 setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
 375 #endif
 376 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 377 \end{code}
 378
 379
 380 \begin{code}
 381 -- Find TopDir
 382 --      for "installed" this is the root of GHC's support files
 383 --      for "in-place" it is the root of the build tree
 384 --
 385 -- Plan of action:
 386 -- 1. Set proto_top_dir
 387 --      a) look for (the last) -B flag, and use it
 388 --      b) if there are no -B flags, get the directory
 389 --         where GHC is running (only on Windows)
 390 --
 391 -- 2. If package.conf exists in proto_top_dir, we are running
 392 --      installed; and TopDir = proto_top_dir
 393 --
 394 -- 3. Otherwise we are running in-place, so
 395 --      proto_top_dir will be /...stuff.../ghc/compiler
 396 --      Set TopDir to /...stuff..., which is the root of the build tree
 397 --
 398 -- This is very gruesome indeed
 399
 400 findTopDir :: [String]
 401           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 402                  String)        -- TopDir (in Unix format '/' separated)
 403
 404 findTopDir minusbs
 405   = do { top_dir <- get_proto
 406         -- Discover whether we're running in a build tree or in an installation,
 407         -- by looking for the package configuration file.
 408        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 409
 410        ; return (am_installed, top_dir)
 411        }
 412   where
 413     -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
 414     get_proto | not (null minusbs)
 415               = return (unDosifyPath (drop 2 (last minusbs)))   -- 2 for "-B"
 416               | otherwise
 417               = do { maybe_exec_dir <- getExecDir -- Get directory of executable
 418                    ; case maybe_exec_dir of       -- (only works on Windows;
 419                                                   --  returns Nothing on Unix)
 420                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 421                         Just dir -> return dir
 422                    }
 423 \end{code}
 424
 425
 426 %************************************************************************
 427 %*                                                                      *
 428 \subsection{Command-line options}
 429 n%*                                                                     *
 430 %************************************************************************
 431
 432 When invoking external tools as part of the compilation pipeline, we
 433 pass these a sequence of options on the command-line. Rather than
 434 just using a list of Strings, we use a type that allows us to distinguish
 435 between filepaths and 'other stuff'. [The reason being, of course, that
 436 this type gives us a handle on transforming filenames, and filenames only,
 437 to whatever format they're expected to be on a particular platform.]
 438
 439
 440 \begin{code}
 441 data Option
 442  = FileOption String
 443  | Option     String
 444
 445 showOptions :: [Option] -> String
 446 showOptions ls = unwords (map (quote.showOpt) ls)
 447  where
 448    showOpt (FileOption f) = dosifyPath f
 449    showOpt (Option s)     = s
 450
 451 #if defined(mingw32_TARGET_OS)
 452    quote "" = ""
 453    quote s  = "\"" ++ s ++ "\""
 454 #else
 455    quote = id
 456 #endif
 457
 458 \end{code}
 459
 460
 461 %************************************************************************
 462 %*                                                                      *
 463 \subsection{Running an external program}
 464 n%*                                                                     *
 465 %************************************************************************
 466
 467
 468 \begin{code}
 469 runUnlit :: [Option] -> IO ()
 470 runUnlit args = do p <- readIORef v_Pgm_L
 471                    runSomething "Literate pre-processor" p args
 472
 473 runCpp :: [Option] -> IO ()
 474 runCpp args =   do p <- readIORef v_Pgm_P
 475                    runSomething "C pre-processor" p args
 476
 477 runCc :: [Option] -> IO ()
 478 runCc args =   do p <- readIORef v_Pgm_c
 479                   runSomething "C Compiler" p args
 480
 481 runMangle :: [Option] -> IO ()
 482 runMangle args = do p <- readIORef v_Pgm_m
 483                     runSomething "Mangler" p args
 484
 485 runSplit :: [Option] -> IO ()
 486 runSplit args = do p <- readIORef v_Pgm_s
 487                    runSomething "Splitter" p args
 488
 489 runAs :: [Option] -> IO ()
 490 runAs args = do p <- readIORef v_Pgm_a
 491                 runSomething "Assembler" p args
 492
 493 runLink :: [Option] -> IO ()
 494 runLink args = do p <- readIORef v_Pgm_l
 495                   runSomething "Linker" p args
 496
 497 #ifdef ILX
 498 runIlx2il :: [Option] -> IO ()
 499 runIlx2il args = do p <- readIORef v_Pgm_I
 500                     runSomething "Ilx2Il" p args
 501
 502 runIlasm :: [Option] -> IO ()
 503 runIlasm args = do p <- readIORef v_Pgm_i
 504                    runSomething "Ilasm" p args
 505 #endif
 506
 507 runMkDLL :: [Option] -> IO ()
 508 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 509                    runSomething "Make DLL" p args
 510
 511 touch :: String -> String -> IO ()
 512 touch purpose arg =  do p <- readIORef v_Pgm_T
 513                         runSomething purpose p [FileOption arg]
 514
 515 copy :: String -> String -> String -> IO ()
 516 copy purpose from to = do
 517   verb <- dynFlag verbosity
 518   when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 519
 520   h <- openFile to WriteMode
 521   ls <- readFile from -- inefficient, but it'll do for now.
 522                       -- ToDo: speed up via slurping.
 523   hPutStr h ls
 524   hClose h
 525 \end{code}
 526
 527 \begin{code}
 528 getSysMan :: IO String  -- How to invoke the system manager
 529                         -- (parallel system only)
 530 getSysMan = readIORef v_Pgm_sysman
 531 \end{code}
 532
 533 %************************************************************************
 534 %*                                                                      *
 535 \subsection{GHC Usage message}
 536 %*                                                                      *
 537 %************************************************************************
 538
 539 Show the usage message and exit
 540
 541 \begin{code}
 542 showGhcUsage = do { usage_path <- readIORef v_Path_usage
 543                   ; usage      <- readFile usage_path
 544                   ; dump usage
 545                   ; exitWith ExitSuccess }
 546   where
 547      dump ""          = return ()
 548      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 549      dump (c:s)       = hPutChar stderr c >> dump s
 550 \end{code}
 551
 552
 553 %************************************************************************
 554 %*                                                                      *
 555 \subsection{Managing temporary files
 556 %*                                                                      *
 557 %************************************************************************
 558
 559 \begin{code}
 560 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 561 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 562         -- v_TmpDir has no closing '/'
 563 \end{code}
 564
 565 \begin{code}
 566 setTmpDir dir = writeIORef v_TmpDir dir
 567
 568 cleanTempFiles :: Int -> IO ()
 569 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
 570                          removeTmpFiles verb fs
 571
 572 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 573 cleanTempFilesExcept verb dont_delete
 574   = do fs <- readIORef v_FilesToClean
 575        let leftovers = filter (`notElem` dont_delete) fs
 576        removeTmpFiles verb leftovers
 577        writeIORef v_FilesToClean dont_delete
 578
 579
 580 -- find a temporary name that doesn't already exist.
 581 newTempName :: Suffix -> IO FilePath
 582 newTempName extn
 583   = do x <- getProcessID
 584        tmp_dir <- readIORef v_TmpDir
 585        findTempName tmp_dir x
 586   where
 587     findTempName tmp_dir x
 588       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 589            b  <- doesFileExist filename
 590            if b then findTempName tmp_dir (x+1)
 591                 else do add v_FilesToClean filename -- clean it up later
 592                         return filename
 593
 594 addFilesToClean :: [FilePath] -> IO ()
 595 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 596 addFilesToClean files = mapM_ (add v_FilesToClean) files
 597
 598 removeTmpFiles :: Int -> [FilePath] -> IO ()
 599 removeTmpFiles verb fs
 600   = traceCmd "Deleting temp files"
 601              ("Deleting: " ++ unwords fs)
 602              (mapM_ rm fs)
 603   where
 604     rm f = removeFile f `catchAllIO`
 605                 (\_ignored ->
 606                     when (verb >= 2) $
 607                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 608                 )
 609
 610 \end{code}
 611
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection{Running a program}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 \begin{code}
 620 GLOBAL_VAR(v_Dry_run, False, Bool)
 621
 622 setDryRun :: IO ()
 623 setDryRun = writeIORef v_Dry_run True
 624
 625 -----------------------------------------------------------------------------
 626 -- Running an external program
 627
 628 runSomething :: String          -- For -v message
 629              -> String          -- Command name (possibly a full path)
 630                                 --      assumed already dos-ified
 631              -> [Option]        -- Arguments
 632                                 --      runSomething will dos-ify them
 633              -> IO ()
 634
 635 runSomething phase_name pgm args
 636  = traceCmd phase_name cmd_line $
 637    do   {
 638 #ifndef mingw32_TARGET_OS
 639           exit_code <- system cmd_line
 640 #else
 641           exit_code <- rawSystem cmd_line
 642 #endif
 643         ; if exit_code /= ExitSuccess
 644           then throwDyn (PhaseFailed phase_name exit_code)
 645           else return ()
 646         }
 647   where
 648     cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
 649         -- The pgm is already in native format (appropriate dir separators)
 650 #if defined(mingw32_TARGET_OS)
 651     quote "" = ""
 652     quote s  = "\"" ++ s ++ "\""
 653 #else
 654     quote = id
 655 #endif
 656
 657 traceCmd :: String -> String -> IO () -> IO ()
 658 -- a) trace the command (at two levels of verbosity)
 659 -- b) don't do it at all if dry-run is set
 660 traceCmd phase_name cmd_line action
 661  = do   { verb <- dynFlag verbosity
 662         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 663         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 664         ; hFlush stderr
 665
 666            -- Test for -n flag
 667         ; n <- readIORef v_Dry_run
 668         ; unless n $ do {
 669
 670            -- And run it!
 671         ; action `catchAllIO` handle_exn verb
 672         }}
 673   where
 674     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 675                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
 676                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 677 \end{code}
 678
 679
 680 %************************************************************************
 681 %*                                                                      *
 682 \subsection{Path names}
 683 %*                                                                      *
 684 %************************************************************************
 685
 686 We maintain path names in Unix form ('/'-separated) right until
 687 the last moment.  On Windows we dos-ify them just before passing them
 688 to the Windows command.
 689
 690 The alternative, of using '/' consistently on Unix and '\' on Windows,
 691 proved quite awkward.  There were a lot more calls to dosifyPath,
 692 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 693 interpreted a command line 'foo\baz' as 'foobaz'.
 694
 695 \begin{code}
 696 -----------------------------------------------------------------------------
 697 -- Convert filepath into MSDOS form.
 698
 699 dosifyPaths :: [String] -> [String]
 700 -- dosifyPaths does two things
 701 -- a) change '/' to '\'
 702 -- b) remove initial '/cygdrive/'
 703
 704 unDosifyPath :: String -> String
 705 -- Just change '\' to '/'
 706
 707 pgmPath :: String               -- Directory string in Unix format
 708         -> String               -- Program name with no directory separators
 709                                 --      (e.g. copy /y)
 710         -> String               -- Program invocation string in native format
 711
 712
 713
 714 #if defined(mingw32_TARGET_OS)
 715
 716 --------------------- Windows version ------------------
 717 dosifyPaths xs = map dosifyPath xs
 718
 719 unDosifyPath xs = subst '\\' '/' xs
 720
 721 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
 722
 723 dosifyPath stuff
 724   = subst '/' '\\' real_stuff
 725  where
 726    -- fully convince myself that /cygdrive/ prefixes cannot
 727    -- really appear here.
 728   cygdrive_prefix = "/cygdrive/"
 729
 730   real_stuff
 731     | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 732     | otherwise = stuff
 733
 734 #else
 735
 736 --------------------- Unix version ---------------------
 737 dosifyPaths  ps  = ps
 738 unDosifyPath xs  = xs
 739 pgmPath dir pgm  = dir ++ '/' : pgm
 740 dosifyPath stuff = stuff
 741 --------------------------------------------------------
 742 #endif
 743
 744 subst a b ls = map (\ x -> if x == a then b else x) ls
 745 \end{code}
 746
 747
 748 -----------------------------------------------------------------------------
 749    Path name construction
 750
 751 \begin{code}
 752 slash            :: String -> String -> String
 753 absPath, relPath :: [String] -> String
 754
 755 isSlash '/'   = True
 756 isSlash other = False
 757
 758 relPath [] = ""
 759 relPath xs = foldr1 slash xs
 760
 761 absPath xs = "" `slash` relPath xs
 762
 763 slash s1 s2 = s1 ++ ('/' : s2)
 764 \end{code}
 765
 766
 767 %************************************************************************
 768 %*                                                                      *
 769 \subsection{Support code}
 770 %*                                                                      *
 771 %************************************************************************
 772
 773 \begin{code}
 774 -----------------------------------------------------------------------------
 775 -- Define       getExecDir     :: IO (Maybe String)
 776
 777 #if defined(mingw32_TARGET_OS)
 778 getExecDir :: IO (Maybe String)
 779 getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
 780                 buf <- mallocArray (fromIntegral len)
 781                 ret <- getModuleFileName nullAddr buf len
 782                 if ret == 0 then return Nothing
 783                             else do s <- peekCString buf
 784                                     destructArray (fromIntegral len) buf
 785                                     return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
 786
 787
 788 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
 789 #else
 790 getExecDir :: IO (Maybe String) = do return Nothing
 791 #endif
 792
 793 #ifdef mingw32_TARGET_OS
 794 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 795 #else
 796 getProcessID :: IO Int
 797 getProcessID = Posix.getProcessID
 798 #endif
 799
 800 rawSystem :: String -> IO ExitCode
 801 rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
 802 rawSystem cmd =
 803   withCString cmd $ \s -> do
 804     status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
 805     case status of
 806         0  -> return ExitSuccess
 807         n  -> return (ExitFailure n)
 808
 809 foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int
 810
 811 \end{code}