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