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