ghc/compiler/main/SysTools.lhs

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