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