ghc/compiler/main/SysTools.lhs

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