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