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