ghc/compiler/main/SysTools.lhs

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