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