ghc/compiler/main/SysTools.lhs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2001
   4 --
   5 -- Access to system tools: gcc, cp, rm etc
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 \begin{code}
  10 module SysTools (
  11         -- Initialisation
  12         initSysTools,
  13         setPgm,                 -- String -> IO ()
  14                                 -- Command-line override
  15         setDryRun,
  16
  17         getTopDir,              -- IO String    -- The value of $libdir
  18         getPackageConfigPath,   -- IO String    -- Where package.conf is
  19
  20         -- Interface to system tools
  21         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  22         runMangle, runSplit,     -- [Option] -> IO ()
  23         runAs, runLink,          -- [Option] -> IO ()
  24         runMkDLL,
  25 #ifdef ILX
  26         runIlx2il, runIlasm,     -- [String] -> IO ()
  27 #endif
  28
  29
  30         touch,                  -- String -> String -> IO ()
  31         copy,                   -- String -> String -> String -> IO ()
  32         unDosifyPath,           -- String -> String
  33
  34         -- Temporary-file management
  35         setTmpDir,
  36         newTempName,
  37         cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
  38         addFilesToClean,
  39
  40         -- System interface
  41         getProcessID,           -- IO Int
  42         system,                 -- String -> IO ExitCode
  43
  44         -- Misc
  45         showGhcUsage,           -- IO ()        Shows usage message and exits
  46         getSysMan,              -- IO String    Parallel system only
  47
  48         Option(..)
  49
  50  ) where
  51
  52 import DriverUtil
  53 import Config
  54 import Outputable
  55 import Panic            ( progName, GhcException(..) )
  56 import Util             ( global )
  57 import CmdLineOpts      ( dynFlag, verbosity )
  58
  59 import Exception        ( throwDyn, catchAllIO )
  60 import IO
  61 import Directory        ( doesFileExist, removeFile )
  62 import IOExts           ( IORef, readIORef, writeIORef )
  63 import Monad            ( when, unless )
  64 import System           ( ExitCode(..), exitWith, getEnv, system )
  65 import CString
  66 import Int
  67 import Addr
  68
  69 #include "../includes/config.h"
  70
  71 #ifndef mingw32_TARGET_OS
  72 import qualified Posix
  73 #else
  74 import List             ( isPrefixOf )
  75 import MarshalArray
  76 #endif
  77
  78 -- This is a kludge for bootstrapping with 4.08.X.  Given that
  79 -- all distributed compilers >= 5.0 will be compiled with themselves.
  80 -- I don't think this kludge is a problem.  And we have to start
  81 -- building with >= 5.0 on Win32 anyway.
  82 #if __GLASGOW_HASKELL__ > 408
  83 -- use the line below when we can be sure of compiling with GHC >=
  84 -- 5.02, and remove the implementation of rawSystem at the end of this
  85 -- file
  86 import PrelIOBase -- this can be removed when SystemExts is used
  87 import CError     ( throwErrnoIfMinus1 ) -- as can this
  88 -- import SystemExts       ( rawSystem )
  89 #else
  90 import System           ( system )
  91 #endif
  92
  93 #include "HsVersions.h"
  94
  95 \end{code}
  96
  97
  98                 The configuration story
  99                 ~~~~~~~~~~~~~~~~~~~~~~~
 100
 101 GHC needs various support files (library packages, RTS etc), plus
 102 various auxiliary programs (cp, gcc, etc).  It finds these in one
 103 of two places:
 104
 105 * When running as an *installed program*, GHC finds most of this support
 106   stuff in the installed library tree.  The path to this tree is passed
 107   to GHC via the -B flag, and given to initSysTools .
 108
 109 * When running *in-place* in a build tree, GHC finds most of this support
 110   stuff in the build tree.  The path to the build tree is, again passed
 111   to GHC via -B.
 112
 113 GHC tells which of the two is the case by seeing whether package.conf
 114 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
 115
 116
 117 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 118 are, and initialises mutable variables to make it easy to call them.
 119 To to this, it makes use of definitions in Config.hs, which is a Haskell
 120 file containing variables whose value is figured out by the build system.
 121
 122 Config.hs contains two sorts of things
 123
 124   cGCC,         The *names* of the programs
 125   cCPP            e.g.  cGCC = gcc
 126   cUNLIT                cCPP = gcc -E
 127   etc           They do *not* include paths
 128
 129
 130   cUNLIT_DIR    The *path* to the directory containing unlit, split etc
 131   cSPLIT_DIR    *relative* to the root of the build tree,
 132                 for use when running *in-place* in a build tree (only)
 133
 134
 135
 136 ---------------------------------------------
 137 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 138
 139 Another hair-brained scheme for simplifying the current tool location
 140 nightmare in GHC: Simon originally suggested using another
 141 configuration file along the lines of GCC's specs file - which is fine
 142 except that it means adding code to read yet another configuration
 143 file.  What I didn't notice is that the current package.conf is
 144 general enough to do this:
 145
 146 Package
 147     {name = "tools",    import_dirs = [],  source_dirs = [],
 148      library_dirs = [], hs_libraries = [], extra_libraries = [],
 149      include_dirs = [], c_includes = [],   package_deps = [],
 150      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
 151      extra_cc_opts = [], extra_ld_opts = []}
 152
 153 Which would have the advantage that we get to collect together in one
 154 place the path-specific package stuff with the path-specific tool
 155 stuff.
 156                 End of NOTES
 157 ---------------------------------------------
 158
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsection{Global variables to contain system programs}
 163 %*                                                                      *
 164 %************************************************************************
 165
 166 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
 167 (See remarks under pathnames below)
 168
 169 \begin{code}
 170 GLOBAL_VAR(v_Pgm_L,     error "pgm_L",   String)        -- unlit
 171 GLOBAL_VAR(v_Pgm_P,     error "pgm_P",   String)        -- cpp
 172 GLOBAL_VAR(v_Pgm_c,     error "pgm_c",   String)        -- gcc
 173 GLOBAL_VAR(v_Pgm_m,     error "pgm_m",   String)        -- asm code mangler
 174 GLOBAL_VAR(v_Pgm_s,     error "pgm_s",   String)        -- asm code splitter
 175 GLOBAL_VAR(v_Pgm_a,     error "pgm_a",   String)        -- as
 176 #ifdef ILX
 177 GLOBAL_VAR(v_Pgm_I,     error "pgm_I",   String)        -- ilx2il
 178 GLOBAL_VAR(v_Pgm_i,     error "pgm_i",   String)        -- ilasm
 179 #endif
 180 GLOBAL_VAR(v_Pgm_l,     error "pgm_l",   String)        -- ld
 181 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)        -- mkdll
 182
 183 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 184 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 185
 186 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 187 GLOBAL_VAR(v_Path_usage,          error "ghc_usage.txt",       String)
 188
 189 GLOBAL_VAR(v_TopDir,    error "TopDir", String)         -- -B<dir>
 190
 191 -- Parallel system only
 192 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 193
 194 -- ways to get at some of these variables from outside this module
 195 getPackageConfigPath = readIORef v_Path_package_config
 196 getTopDir            = readIORef v_TopDir
 197 \end{code}
 198
 199
 200 %************************************************************************
 201 %*                                                                      *
 202 \subsection{Initialisation}
 203 %*                                                                      *
 204 %************************************************************************
 205
 206 \begin{code}
 207 initSysTools :: [String]        -- Command-line arguments starting "-B"
 208
 209              -> IO ()           -- Set all the mutable variables above, holding
 210                                 --      (a) the system programs
 211                                 --      (b) the package-config file
 212                                 --      (c) the GHC usage message
 213
 214
 215 initSysTools minusB_args
 216   = do  { (am_installed, top_dir) <- findTopDir minusB_args
 217         ; writeIORef v_TopDir top_dir
 218                 -- top_dir
 219                 --      for "installed" this is the root of GHC's support files
 220                 --      for "in-place" it is the root of the build tree
 221                 -- NB: top_dir is assumed to be in standard Unix format '/' separated
 222
 223         ; let installed, installed_bin :: FilePath -> FilePath
 224               installed_bin pgm   =  pgmPath (top_dir `slash` "extra-bin") pgm
 225               installed     file  =  pgmPath top_dir file
 226               inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm
 227
 228         ; let pkgconfig_path
 229                 | am_installed = installed "package.conf"
 230                 | otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"
 231
 232               ghc_usage_msg_path
 233                 | am_installed = installed "ghc-usage.txt"
 234                 | otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
 235
 236                 -- For all systems, unlit, split, mangle are GHC utilities
 237                 -- architecture-specific stuff is done when building Config.hs
 238               unlit_path
 239                 | am_installed = installed_bin cGHC_UNLIT
 240                 | otherwise    = inplace cGHC_UNLIT_DIR cGHC_UNLIT
 241
 242                 -- split and mangle are Perl scripts
 243               split_script
 244                 | am_installed = installed_bin cGHC_SPLIT
 245                 | otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
 246
 247               mangle_script
 248                 | am_installed = installed_bin cGHC_MANGLER
 249                 | otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER
 250
 251 #ifndef mingw32_TARGET_OS
 252         -- check whether TMPDIR is set in the environment
 253         ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
 254                      setTmpDir dir
 255                      return ()
 256                  )
 257 #endif
 258
 259         -- Check that the package config exists
 260         ; config_exists <- doesFileExist pkgconfig_path
 261         ; when (not config_exists) $
 262              throwDyn (InstallationError
 263                          ("Can't find package.conf as " ++ pkgconfig_path))
 264
 265 #if defined(mingw32_TARGET_OS)
 266         --              WINDOWS-SPECIFIC STUFF
 267         -- On Windows, gcc and friends are distributed with GHC,
 268         --      so when "installed" we look in TopDir/bin
 269         -- When "in-place" we look wherever the build-time configure
 270         --      script found them
 271         -- When "install" we tell gcc where its specs file + exes are (-B)
 272         --      and also some places to pick up include files.  We need
 273         --      to be careful to put all necessary exes in the -B place
 274         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 275         --      then tries to run unadorned "as", "ld", etc, and will
 276         --      pick up whatever happens to be lying around in the path,
 277         --      possibly including those from a cygwin install on the target,
 278         --      which is exactly what we're trying to avoid.
 279         ; let gcc_path  | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
 280                         | otherwise    = cGCC
 281                 -- The trailing "/" is absolutely essential; gcc seems
 282                 -- to construct file names simply by concatenating to this
 283                 -- -B path with no extra slash
 284                 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
 285                 -- later on; although gcc_path is in NATIVE format, gcc can cope
 286                 --      (see comments with declarations of global variables)
 287                 --
 288                 -- The quotes round the -B argument are in case TopDir has spaces in it
 289
 290               perl_path | am_installed = installed_bin cGHC_PERL
 291                         | otherwise    = cGHC_PERL
 292
 293         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 294         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
 295                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 296
 297         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 298         -- a call to Perl to get the invocation of split and mangle
 299         ; let split_path  = perl_path ++ " \"" ++ split_script ++ "\""
 300               mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
 301
 302         ; let mkdll_path = cMKDLL
 303 #else
 304         --              UNIX-SPECIFIC STUFF
 305         -- On Unix, the "standard" tools are assumed to be
 306         -- in the same place whether we are running "in-place" or "installed"
 307         -- That place is wherever the build-time configure script found them.
 308         ; let   gcc_path   = cGCC
 309                 touch_path = cGHC_TOUCHY
 310                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 311
 312         -- On Unix, scripts are invoked using the '#!' method.  Binary
 313         -- installations of GHC on Unix place the correct line on the front
 314         -- of the script at installation time, so we don't want to wire-in
 315         -- our knowledge of $(PERL) on the host system here.
 316         ; let split_path  = split_script
 317               mangle_path = mangle_script
 318 #endif
 319
 320         -- cpp is derived from gcc on all platforms
 321         ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
 322
 323         -- For all systems, copy and remove are provided by the host
 324         -- system; architecture-specific stuff is done when building Config.hs
 325         ; let   cp_path = cGHC_CP
 326
 327         -- Other things being equal, as and ld are simply gcc
 328         ; let   as_path  = gcc_path
 329                 ld_path  = gcc_path
 330
 331 #ifdef ILX
 332        -- ilx2il and ilasm are specified in Config.hs
 333        ; let    ilx2il_path = cILX2IL
 334                 ilasm_path  = cILASM
 335 #endif
 336
 337         -- Initialise the global vars
 338         ; writeIORef v_Path_package_config pkgconfig_path
 339         ; writeIORef v_Path_usage          ghc_usage_msg_path
 340
 341         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 342                 -- Hans: this isn't right in general, but you can
 343                 -- elaborate it in the same way as the others
 344
 345         ; writeIORef v_Pgm_L               unlit_path
 346         ; writeIORef v_Pgm_P               cpp_path
 347         ; writeIORef v_Pgm_c               gcc_path
 348         ; writeIORef v_Pgm_m               mangle_path
 349         ; writeIORef v_Pgm_s               split_path
 350         ; writeIORef v_Pgm_a               as_path
 351 #ifdef ILX
 352         ; writeIORef v_Pgm_I               ilx2il_path
 353         ; writeIORef v_Pgm_i               ilasm_path
 354 #endif
 355         ; writeIORef v_Pgm_l               ld_path
 356         ; writeIORef v_Pgm_MkDLL           mkdll_path
 357         ; writeIORef v_Pgm_T               touch_path
 358         ; writeIORef v_Pgm_CP              cp_path
 359
 360         ; return ()
 361         }
 362 \end{code}
 363
 364 setPgm is called when a command-line option like
 365         -pgmLld
 366 is used to override a particular program with a new one
 367
 368 \begin{code}
 369 setPgm :: String -> IO ()
 370 -- The string is the flag, minus the '-pgm' prefix
 371 -- So the first character says which program to override
 372
 373 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 374 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 375 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 376 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 377 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 378 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 379 #ifdef ILX
 380 setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
 381 setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
 382 #endif
 383 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 384 \end{code}
 385
 386
 387 \begin{code}
 388 -- Find TopDir
 389 --      for "installed" this is the root of GHC's support files
 390 --      for "in-place" it is the root of the build tree
 391 --
 392 -- Plan of action:
 393 -- 1. Set proto_top_dir
 394 --      a) look for (the last) -B flag, and use it
 395 --      b) if there are no -B flags, get the directory
 396 --         where GHC is running (only on Windows)
 397 --
 398 -- 2. If package.conf exists in proto_top_dir, we are running
 399 --      installed; and TopDir = proto_top_dir
 400 --
 401 -- 3. Otherwise we are running in-place, so
 402 --      proto_top_dir will be /...stuff.../ghc/compiler
 403 --      Set TopDir to /...stuff..., which is the root of the build tree
 404 --
 405 -- This is very gruesome indeed
 406
 407 findTopDir :: [String]
 408           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 409                  String)        -- TopDir (in Unix format '/' separated)
 410
 411 findTopDir minusbs
 412   = do { top_dir <- get_proto
 413         -- Discover whether we're running in a build tree or in an installation,
 414         -- by looking for the package configuration file.
 415        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 416
 417        ; return (am_installed, top_dir)
 418        }
 419   where
 420     -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
 421     get_proto | not (null minusbs)
 422               = return (unDosifyPath (drop 2 (last minusbs)))   -- 2 for "-B"
 423               | otherwise
 424               = do { maybe_exec_dir <- getExecDir -- Get directory of executable
 425                    ; case maybe_exec_dir of       -- (only works on Windows;
 426                                                   --  returns Nothing on Unix)
 427                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 428                         Just dir -> return dir
 429                    }
 430 \end{code}
 431
 432
 433 %************************************************************************
 434 %*                                                                      *
 435 \subsection{Command-line options}
 436 n%*                                                                     *
 437 %************************************************************************
 438
 439 When invoking external tools as part of the compilation pipeline, we
 440 pass these a sequence of options on the command-line. Rather than
 441 just using a list of Strings, we use a type that allows us to distinguish
 442 between filepaths and 'other stuff'. [The reason being, of course, that
 443 this type gives us a handle on transforming filenames, and filenames only,
 444 to whatever format they're expected to be on a particular platform.]
 445
 446 \begin{code}
 447 data Option
 448  = FileOption -- an entry that _contains_ filename(s) / filepaths.
 449               String  -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
 450               String  -- the filepath/filename portion
 451  | Option     String
 452
 453 showOptions :: [Option] -> String
 454 showOptions ls = unwords (map (quote.showOpt) ls)
 455  where
 456    showOpt (FileOption pre f) = pre ++ 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}