ghc/compiler/main/SysTools.lhs

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