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