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