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