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