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 #else
 258           -- On Win32, consult GetTempPath() for a temp dir.
 259           --  => it first tries TMP, TEMP, then finally the
 260           --   Windows directory(!). The directory is in short-path
 261           --   form and *does* have a trailing backslash.
 262         ; IO.try (do
 263                 let len = (2048::Int)
 264                 buf  <- mallocArray len
 265                 ret  <- getTempPath len buf
 266                 tdir <-
 267                   if ret == 0 then do
 268                       -- failed, consult TEMP.
 269                      destructArray len buf
 270                      getEnv "TMP"
 271                    else do
 272                      s <- peekCString buf
 273                      destructArray len buf
 274                      return s
 275                 let
 276                   -- strip the trailing backslash (awful, but
 277                   -- we only do this once).
 278                   tmpdir =
 279                     case last tdir of
 280                       '/'  -> init tdir
 281                       '\\' -> init tdir
 282                       _   -> tdir
 283                 setTmpDir tmpdir
 284                 return ())
 285 #endif
 286
 287         -- Check that the package config exists
 288         ; config_exists <- doesFileExist pkgconfig_path
 289         ; when (not config_exists) $
 290              throwDyn (InstallationError
 291                          ("Can't find package.conf as " ++ pkgconfig_path))
 292
 293 #if defined(mingw32_TARGET_OS)
 294         --              WINDOWS-SPECIFIC STUFF
 295         -- On Windows, gcc and friends are distributed with GHC,
 296         --      so when "installed" we look in TopDir/bin
 297         -- When "in-place" we look wherever the build-time configure
 298         --      script found them
 299         -- When "install" we tell gcc where its specs file + exes are (-B)
 300         --      and also some places to pick up include files.  We need
 301         --      to be careful to put all necessary exes in the -B place
 302         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 303         --      then tries to run unadorned "as", "ld", etc, and will
 304         --      pick up whatever happens to be lying around in the path,
 305         --      possibly including those from a cygwin install on the target,
 306         --      which is exactly what we're trying to avoid.
 307         ; let gcc_path  | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
 308                         | otherwise    = cGCC
 309                 -- The trailing "/" is absolutely essential; gcc seems
 310                 -- to construct file names simply by concatenating to this
 311                 -- -B path with no extra slash
 312                 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
 313                 -- later on; although gcc_path is in NATIVE format, gcc can cope
 314                 --      (see comments with declarations of global variables)
 315                 --
 316                 -- The quotes round the -B argument are in case TopDir has spaces in it
 317
 318               perl_path | am_installed = installed_bin cGHC_PERL
 319                         | otherwise    = cGHC_PERL
 320
 321         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 322         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
 323                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 324
 325         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 326         -- a call to Perl to get the invocation of split and mangle
 327         ; let split_path  = perl_path ++ " \"" ++ split_script ++ "\""
 328               mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
 329
 330         ; let mkdll_path = cMKDLL
 331 #else
 332         --              UNIX-SPECIFIC STUFF
 333         -- On Unix, the "standard" tools are assumed to be
 334         -- in the same place whether we are running "in-place" or "installed"
 335         -- That place is wherever the build-time configure script found them.
 336         ; let   gcc_path   = cGCC
 337                 touch_path = cGHC_TOUCHY
 338                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 339
 340         -- On Unix, scripts are invoked using the '#!' method.  Binary
 341         -- installations of GHC on Unix place the correct line on the front
 342         -- of the script at installation time, so we don't want to wire-in
 343         -- our knowledge of $(PERL) on the host system here.
 344         ; let split_path  = split_script
 345               mangle_path = mangle_script
 346 #endif
 347
 348         -- cpp is derived from gcc on all platforms
 349         ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
 350
 351         -- For all systems, copy and remove are provided by the host
 352         -- system; architecture-specific stuff is done when building Config.hs
 353         ; let   cp_path = cGHC_CP
 354
 355         -- Other things being equal, as and ld are simply gcc
 356         ; let   as_path  = gcc_path
 357                 ld_path  = gcc_path
 358
 359 #ifdef ILX
 360        -- ilx2il and ilasm are specified in Config.hs
 361        ; let    ilx2il_path = cILX2IL
 362                 ilasm_path  = cILASM
 363 #endif
 364
 365         -- Initialise the global vars
 366         ; writeIORef v_Path_package_config pkgconfig_path
 367         ; writeIORef v_Path_usage          ghc_usage_msg_path
 368
 369         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 370                 -- Hans: this isn't right in general, but you can
 371                 -- elaborate it in the same way as the others
 372
 373         ; writeIORef v_Pgm_L               unlit_path
 374         ; writeIORef v_Pgm_P               cpp_path
 375         ; writeIORef v_Pgm_c               gcc_path
 376         ; writeIORef v_Pgm_m               mangle_path
 377         ; writeIORef v_Pgm_s               split_path
 378         ; writeIORef v_Pgm_a               as_path
 379 #ifdef ILX
 380         ; writeIORef v_Pgm_I               ilx2il_path
 381         ; writeIORef v_Pgm_i               ilasm_path
 382 #endif
 383         ; writeIORef v_Pgm_l               ld_path
 384         ; writeIORef v_Pgm_MkDLL           mkdll_path
 385         ; writeIORef v_Pgm_T               touch_path
 386         ; writeIORef v_Pgm_CP              cp_path
 387
 388         ; return ()
 389         }
 390
 391 #if defined(mingw32_TARGET_OS)
 392 foreign import stdcall "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
 393 #endif
 394 \end{code}
 395
 396 setPgm is called when a command-line option like
 397         -pgmLld
 398 is used to override a particular program with a new one
 399
 400 \begin{code}
 401 setPgm :: String -> IO ()
 402 -- The string is the flag, minus the '-pgm' prefix
 403 -- So the first character says which program to override
 404
 405 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 406 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 407 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 408 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 409 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 410 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 411 #ifdef ILX
 412 setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
 413 setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
 414 #endif
 415 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 416 \end{code}
 417
 418
 419 \begin{code}
 420 -- Find TopDir
 421 --      for "installed" this is the root of GHC's support files
 422 --      for "in-place" it is the root of the build tree
 423 --
 424 -- Plan of action:
 425 -- 1. Set proto_top_dir
 426 --      a) look for (the last) -B flag, and use it
 427 --      b) if there are no -B flags, get the directory
 428 --         where GHC is running (only on Windows)
 429 --
 430 -- 2. If package.conf exists in proto_top_dir, we are running
 431 --      installed; and TopDir = proto_top_dir
 432 --
 433 -- 3. Otherwise we are running in-place, so
 434 --      proto_top_dir will be /...stuff.../ghc/compiler
 435 --      Set TopDir to /...stuff..., which is the root of the build tree
 436 --
 437 -- This is very gruesome indeed
 438
 439 findTopDir :: [String]
 440           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 441                  String)        -- TopDir (in Unix format '/' separated)
 442
 443 findTopDir minusbs
 444   = do { top_dir <- get_proto
 445         -- Discover whether we're running in a build tree or in an installation,
 446         -- by looking for the package configuration file.
 447        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 448
 449        ; return (am_installed, top_dir)
 450        }
 451   where
 452     -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
 453     get_proto | not (null minusbs)
 454               = return (unDosifyPath (drop 2 (last minusbs)))   -- 2 for "-B"
 455               | otherwise
 456               = do { maybe_exec_dir <- getExecDir -- Get directory of executable
 457                    ; case maybe_exec_dir of       -- (only works on Windows;
 458                                                   --  returns Nothing on Unix)
 459                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 460                         Just dir -> return dir
 461                    }
 462 \end{code}
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsection{Command-line options}
 468 n%*                                                                     *
 469 %************************************************************************
 470
 471 When invoking external tools as part of the compilation pipeline, we
 472 pass these a sequence of options on the command-line. Rather than
 473 just using a list of Strings, we use a type that allows us to distinguish
 474 between filepaths and 'other stuff'. [The reason being, of course, that
 475 this type gives us a handle on transforming filenames, and filenames only,
 476 to whatever format they're expected to be on a particular platform.]
 477
 478 \begin{code}
 479 data Option
 480  = FileOption -- an entry that _contains_ filename(s) / filepaths.
 481               String  -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
 482               String  -- the filepath/filename portion
 483  | Option     String
 484
 485 showOptions :: [Option] -> String
 486 showOptions ls = unwords (map (quote.showOpt) ls)
 487  where
 488    showOpt (FileOption pre f) = pre ++ dosifyPath f
 489    showOpt (Option s)     = s
 490
 491 #if defined(mingw32_TARGET_OS)
 492    quote "" = ""
 493    quote s  = "\"" ++ s ++ "\""
 494 #else
 495    quote = id
 496 #endif
 497
 498 \end{code}
 499
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsection{Running an external program}
 504 n%*                                                                     *
 505 %************************************************************************
 506
 507
 508 \begin{code}
 509 runUnlit :: [Option] -> IO ()
 510 runUnlit args = do p <- readIORef v_Pgm_L
 511                    runSomething "Literate pre-processor" p args
 512
 513 runCpp :: [Option] -> IO ()
 514 runCpp args =   do p <- readIORef v_Pgm_P
 515                    runSomething "C pre-processor" p args
 516
 517 runCc :: [Option] -> IO ()
 518 runCc args =   do p <- readIORef v_Pgm_c
 519                   runSomething "C Compiler" p args
 520
 521 runMangle :: [Option] -> IO ()
 522 runMangle args = do p <- readIORef v_Pgm_m
 523                     runSomething "Mangler" p args
 524
 525 runSplit :: [Option] -> IO ()
 526 runSplit args = do p <- readIORef v_Pgm_s
 527                    runSomething "Splitter" p args
 528
 529 runAs :: [Option] -> IO ()
 530 runAs args = do p <- readIORef v_Pgm_a
 531                 runSomething "Assembler" p args
 532
 533 runLink :: [Option] -> IO ()
 534 runLink args = do p <- readIORef v_Pgm_l
 535                   runSomething "Linker" p args
 536
 537 #ifdef ILX
 538 runIlx2il :: [Option] -> IO ()
 539 runIlx2il args = do p <- readIORef v_Pgm_I
 540                     runSomething "Ilx2Il" p args
 541
 542 runIlasm :: [Option] -> IO ()
 543 runIlasm args = do p <- readIORef v_Pgm_i
 544                    runSomething "Ilasm" p args
 545 #endif
 546
 547 runMkDLL :: [Option] -> IO ()
 548 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 549                    runSomething "Make DLL" p args
 550
 551 touch :: String -> String -> IO ()
 552 touch purpose arg =  do p <- readIORef v_Pgm_T
 553                         runSomething purpose p [FileOption "" arg]
 554
 555 copy :: String -> String -> String -> IO ()
 556 copy purpose from to = do
 557   verb <- dynFlag verbosity
 558   when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 559
 560   h <- openFile to WriteMode
 561   ls <- readFile from -- inefficient, but it'll do for now.
 562                       -- ToDo: speed up via slurping.
 563   hPutStr h ls
 564   hClose h
 565 \end{code}
 566
 567 \begin{code}
 568 getSysMan :: IO String  -- How to invoke the system manager
 569                         -- (parallel system only)
 570 getSysMan = readIORef v_Pgm_sysman
 571 \end{code}
 572
 573 %************************************************************************
 574 %*                                                                      *
 575 \subsection{GHC Usage message}
 576 %*                                                                      *
 577 %************************************************************************
 578
 579 Show the usage message and exit
 580
 581 \begin{code}
 582 showGhcUsage = do { usage_path <- readIORef v_Path_usage
 583                   ; usage      <- readFile usage_path
 584                   ; dump usage
 585                   ; exitWith ExitSuccess }
 586   where
 587      dump ""          = return ()
 588      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 589      dump (c:s)       = hPutChar stderr c >> dump s
 590 \end{code}
 591
 592
 593 %************************************************************************
 594 %*                                                                      *
 595 \subsection{Managing temporary files
 596 %*                                                                      *
 597 %************************************************************************
 598
 599 \begin{code}
 600 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 601 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 602         -- v_TmpDir has no closing '/'
 603 \end{code}
 604
 605 \begin{code}
 606 setTmpDir dir = writeIORef v_TmpDir dir
 607
 608 cleanTempFiles :: Int -> IO ()
 609 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
 610                          removeTmpFiles verb fs
 611
 612 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 613 cleanTempFilesExcept verb dont_delete
 614   = do fs <- readIORef v_FilesToClean
 615        let leftovers = filter (`notElem` dont_delete) fs
 616        removeTmpFiles verb leftovers
 617        writeIORef v_FilesToClean dont_delete
 618
 619
 620 -- find a temporary name that doesn't already exist.
 621 newTempName :: Suffix -> IO FilePath
 622 newTempName extn
 623   = do x <- getProcessID
 624        tmp_dir <- readIORef v_TmpDir
 625        findTempName tmp_dir x
 626   where
 627     findTempName tmp_dir x
 628       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 629            b  <- doesFileExist filename
 630            if b then findTempName tmp_dir (x+1)
 631                 else do add v_FilesToClean filename -- clean it up later
 632                         return filename
 633
 634 addFilesToClean :: [FilePath] -> IO ()
 635 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 636 addFilesToClean files = mapM_ (add v_FilesToClean) files
 637
 638 removeTmpFiles :: Int -> [FilePath] -> IO ()
 639 removeTmpFiles verb fs
 640   = traceCmd "Deleting temp files"
 641              ("Deleting: " ++ unwords fs)
 642              (mapM_ rm fs)
 643   where
 644     rm f = removeFile f `catchAllIO`
 645                 (\_ignored ->
 646                     when (verb >= 2) $
 647                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 648                 )
 649
 650 \end{code}
 651
 652
 653 %************************************************************************
 654 %*                                                                      *
 655 \subsection{Running a program}
 656 %*                                                                      *
 657 %************************************************************************
 658
 659 \begin{code}
 660 GLOBAL_VAR(v_Dry_run, False, Bool)
 661
 662 setDryRun :: IO ()
 663 setDryRun = writeIORef v_Dry_run True
 664
 665 -----------------------------------------------------------------------------
 666 -- Running an external program
 667
 668 runSomething :: String          -- For -v message
 669              -> String          -- Command name (possibly a full path)
 670                                 --      assumed already dos-ified
 671              -> [Option]        -- Arguments
 672                                 --      runSomething will dos-ify them
 673              -> IO ()
 674
 675 runSomething phase_name pgm args
 676  = traceCmd phase_name cmd_line $
 677    do   {
 678 #ifndef mingw32_TARGET_OS
 679           exit_code <- system cmd_line
 680 #else
 681           exit_code <- rawSystem cmd_line
 682 #endif
 683         ; if exit_code /= ExitSuccess
 684           then throwDyn (PhaseFailed phase_name exit_code)
 685           else return ()
 686         }
 687   where
 688     cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
 689         -- The pgm is already in native format (appropriate dir separators)
 690 #if defined(mingw32_TARGET_OS)
 691     quote "" = ""
 692     quote s  = "\"" ++ s ++ "\""
 693 #else
 694     quote = id
 695 #endif
 696
 697 traceCmd :: String -> String -> IO () -> IO ()
 698 -- a) trace the command (at two levels of verbosity)
 699 -- b) don't do it at all if dry-run is set
 700 traceCmd phase_name cmd_line action
 701  = do   { verb <- dynFlag verbosity
 702         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 703         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 704         ; hFlush stderr
 705
 706            -- Test for -n flag
 707         ; n <- readIORef v_Dry_run
 708         ; unless n $ do {
 709
 710            -- And run it!
 711         ; action `catchAllIO` handle_exn verb
 712         }}
 713   where
 714     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 715                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
 716                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 717 \end{code}
 718
 719
 720 %************************************************************************
 721 %*                                                                      *
 722 \subsection{Path names}
 723 %*                                                                      *
 724 %************************************************************************
 725
 726 We maintain path names in Unix form ('/'-separated) right until
 727 the last moment.  On Windows we dos-ify them just before passing them
 728 to the Windows command.
 729
 730 The alternative, of using '/' consistently on Unix and '\' on Windows,
 731 proved quite awkward.  There were a lot more calls to dosifyPath,
 732 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 733 interpreted a command line 'foo\baz' as 'foobaz'.
 734
 735 \begin{code}
 736 -----------------------------------------------------------------------------
 737 -- Convert filepath into MSDOS form.
 738
 739 dosifyPaths :: [String] -> [String]
 740 -- dosifyPaths does two things
 741 -- a) change '/' to '\'
 742 -- b) remove initial '/cygdrive/'
 743
 744 unDosifyPath :: String -> String
 745 -- Just change '\' to '/'
 746
 747 pgmPath :: String               -- Directory string in Unix format
 748         -> String               -- Program name with no directory separators
 749                                 --      (e.g. copy /y)
 750         -> String               -- Program invocation string in native format
 751
 752
 753
 754 #if defined(mingw32_TARGET_OS)
 755
 756 --------------------- Windows version ------------------
 757 dosifyPaths xs = map dosifyPath xs
 758
 759 unDosifyPath xs = subst '\\' '/' xs
 760
 761 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
 762
 763 dosifyPath stuff
 764   = subst '/' '\\' real_stuff
 765  where
 766    -- fully convince myself that /cygdrive/ prefixes cannot
 767    -- really appear here.
 768   cygdrive_prefix = "/cygdrive/"
 769
 770   real_stuff
 771     | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 772     | otherwise = stuff
 773
 774 #else
 775
 776 --------------------- Unix version ---------------------
 777 dosifyPaths  ps  = ps
 778 unDosifyPath xs  = xs
 779 pgmPath dir pgm  = dir ++ '/' : pgm
 780 dosifyPath stuff = stuff
 781 --------------------------------------------------------
 782 #endif
 783
 784 subst a b ls = map (\ x -> if x == a then b else x) ls
 785 \end{code}
 786
 787
 788 -----------------------------------------------------------------------------
 789    Path name construction
 790
 791 \begin{code}
 792 slash            :: String -> String -> String
 793 absPath, relPath :: [String] -> String
 794
 795 relPath [] = ""
 796 relPath xs = foldr1 slash xs
 797
 798 absPath xs = "" `slash` relPath xs
 799
 800 slash s1 s2 = s1 ++ ('/' : s2)
 801 \end{code}
 802
 803
 804 %************************************************************************
 805 %*                                                                      *
 806 \subsection{Support code}
 807 %*                                                                      *
 808 %************************************************************************
 809
 810 \begin{code}
 811 -----------------------------------------------------------------------------
 812 -- Define       getExecDir     :: IO (Maybe String)
 813
 814 #if defined(mingw32_TARGET_OS)
 815 getExecDir :: IO (Maybe String)
 816 getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 817                 buf <- mallocArray len
 818                 ret <- getModuleFileName nullAddr buf len
 819                 if ret == 0 then destructArray len buf >> return Nothing
 820                             else do s <- peekCString buf
 821                                     destructArray len buf
 822                                     return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
 823
 824
 825 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int -> IO Int32
 826 #else
 827 getExecDir :: IO (Maybe String) = do return Nothing
 828 #endif
 829
 830 #ifdef mingw32_TARGET_OS
 831 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 832 #else
 833 getProcessID :: IO Int
 834 getProcessID = Posix.getProcessID
 835 #endif
 836
 837 rawSystem :: String -> IO ExitCode
 838 #if __GLASGOW_HASKELL__ > 408
 839 rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
 840 rawSystem cmd =
 841   withCString cmd $ \s -> do
 842     status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
 843     case status of
 844         0  -> return ExitSuccess
 845         n  -> return (ExitFailure n)
 846
 847 foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int
 848 #else
 849 rawSystem = System.system
 850 #endif
 851
 852
 853 \end{code}