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