ghc/compiler/main/SysTools.lhs

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