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      ( DynFlags(..) )
  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 -- rawSystem comes from libghccompat.a in stage1
 110 import Compat.RawSystem ( rawSystem )
 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 :: DynFlags -> [Option] -> IO ()
 538 runUnlit dflags args = do
 539   p <- readIORef v_Pgm_L
 540   runSomething dflags "Literate pre-processor" p args
 541
 542 runCpp :: DynFlags -> [Option] -> IO ()
 543 runCpp dflags args =   do
 544   (p,baseArgs) <- readIORef v_Pgm_P
 545   runSomething dflags "C pre-processor" p (baseArgs ++ args)
 546
 547 runPp :: DynFlags -> [Option] -> IO ()
 548 runPp dflags args =   do
 549   p <- readIORef v_Pgm_F
 550   runSomething dflags "Haskell pre-processor" p args
 551
 552 runCc :: DynFlags -> [Option] -> IO ()
 553 runCc dflags args =   do
 554   (p,args0) <- readIORef v_Pgm_c
 555   runSomething dflags "C Compiler" p (args0++args)
 556
 557 runMangle :: DynFlags -> [Option] -> IO ()
 558 runMangle dflags args = do
 559   (p,args0) <- readIORef v_Pgm_m
 560   runSomething dflags "Mangler" p (args0++args)
 561
 562 runSplit :: DynFlags -> [Option] -> IO ()
 563 runSplit dflags args = do
 564   (p,args0) <- readIORef v_Pgm_s
 565   runSomething dflags "Splitter" p (args0++args)
 566
 567 runAs :: DynFlags -> [Option] -> IO ()
 568 runAs dflags args = do
 569   (p,args0) <- readIORef v_Pgm_a
 570   runSomething dflags "Assembler" p (args0++args)
 571
 572 runLink :: DynFlags -> [Option] -> IO ()
 573 runLink dflags args = do
 574   (p,args0) <- readIORef v_Pgm_l
 575   runSomething dflags "Linker" p (args0++args)
 576
 577 #ifdef ILX
 578 runIlx2il :: DynFlags -> [Option] -> IO ()
 579 runIlx2il dflags args = do
 580   p <- readIORef v_Pgm_I
 581   runSomething dflags "Ilx2Il" p args
 582
 583 runIlasm :: DynFlags -> [Option] -> IO ()
 584 runIlasm dflags args = do
 585   p <- readIORef v_Pgm_i
 586   runSomething dflags "Ilasm" p args
 587 #endif
 588
 589 runMkDLL :: DynFlags -> [Option] -> IO ()
 590 runMkDLL dflags args = do
 591   (p,args0) <- readIORef v_Pgm_MkDLL
 592   runSomething dflags "Make DLL" p (args0++args)
 593
 594 touch :: DynFlags -> String -> String -> IO ()
 595 touch dflags purpose arg =  do
 596   p <- readIORef v_Pgm_T
 597   runSomething dflags purpose p [FileOption "" arg]
 598
 599 copy :: DynFlags -> String -> String -> String -> IO ()
 600 copy dflags purpose from to = do
 601   when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 602
 603   h <- openFile to WriteMode
 604   ls <- readFile from -- inefficient, but it'll do for now.
 605                       -- ToDo: speed up via slurping.
 606   hPutStr h ls
 607   hClose h
 608 \end{code}
 609
 610 \begin{code}
 611 getSysMan :: IO String  -- How to invoke the system manager
 612                         -- (parallel system only)
 613 getSysMan = readIORef v_Pgm_sysman
 614 \end{code}
 615
 616 \begin{code}
 617 getUsageMsgPaths :: IO (FilePath,FilePath)
 618           -- the filenames of the usage messages (ghc, ghci)
 619 getUsageMsgPaths = readIORef v_Path_usages
 620 \end{code}
 621
 622
 623 %************************************************************************
 624 %*                                                                      *
 625 \subsection{Managing temporary files
 626 %*                                                                      *
 627 %************************************************************************
 628
 629 \begin{code}
 630 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 631 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 632         -- v_TmpDir has no closing '/'
 633 \end{code}
 634
 635 \begin{code}
 636 setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
 637     where
 638 #if !defined(mingw32_HOST_OS)
 639      canonicalise p = normalisePath p
 640 #else
 641         -- Canonicalisation of temp path under win32 is a bit more
 642         -- involved: (a) strip trailing slash,
 643         --           (b) normalise slashes
 644         --           (c) just in case, if there is a prefix /cygdrive/x/, change to x:
 645         --
 646      canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
 647
 648         -- if we're operating under cygwin, and TMP/TEMP is of
 649         -- the form "/cygdrive/drive/path", translate this to
 650         -- "drive:/path" (as GHC isn't a cygwin app and doesn't
 651         -- understand /cygdrive paths.)
 652      xltCygdrive path
 653       | "/cygdrive/" `isPrefixOf` path =
 654           case drop (length "/cygdrive/") path of
 655             drive:xs@('/':_) -> drive:':':xs
 656             _ -> path
 657       | otherwise = path
 658
 659         -- strip the trailing backslash (awful, but we only do this once).
 660      removeTrailingSlash path =
 661        case last path of
 662          '/'  -> init path
 663          '\\' -> init path
 664          _    -> path
 665 #endif
 666
 667 cleanTempFiles :: DynFlags -> IO ()
 668 cleanTempFiles dflags
 669    = do fs <- readIORef v_FilesToClean
 670         removeTmpFiles dflags fs
 671         writeIORef v_FilesToClean []
 672
 673 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 674 cleanTempFilesExcept dflags dont_delete
 675    = do files <- readIORef v_FilesToClean
 676         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 677         removeTmpFiles dflags to_delete
 678         writeIORef v_FilesToClean to_keep
 679
 680
 681 -- find a temporary name that doesn't already exist.
 682 newTempName :: Suffix -> IO FilePath
 683 newTempName extn
 684   = do x <- getProcessID
 685        tmp_dir <- readIORef v_TmpDir
 686        findTempName tmp_dir x
 687   where
 688     findTempName tmp_dir x
 689       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 690            b  <- doesFileExist filename
 691            if b then findTempName tmp_dir (x+1)
 692                 else do add v_FilesToClean filename -- clean it up later
 693                         return filename
 694
 695 addFilesToClean :: [FilePath] -> IO ()
 696 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 697 addFilesToClean files = mapM_ (add v_FilesToClean) files
 698
 699 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
 700 removeTmpFiles dflags fs
 701   = warnNon $
 702     traceCmd dflags "Deleting temp files"
 703              ("Deleting: " ++ unwords deletees)
 704              (mapM_ rm deletees)
 705   where
 706     verb = verbosity dflags
 707
 708      -- Flat out refuse to delete files that are likely to be source input
 709      -- files (is there a worse bug than having a compiler delete your source
 710      -- files?)
 711      --
 712      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 713      -- the condition.
 714     warnNon act
 715      | null non_deletees = act
 716      | otherwise         = do
 717         hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
 718         act
 719
 720     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 721
 722     rm f = removeFile f `IO.catch`
 723                 (\_ignored ->
 724                     when (verb >= 2) $
 725                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 726                 )
 727
 728 \end{code}
 729
 730
 731 %************************************************************************
 732 %*                                                                      *
 733 \subsection{Running a program}
 734 %*                                                                      *
 735 %************************************************************************
 736
 737 \begin{code}
 738 GLOBAL_VAR(v_Dry_run, False, Bool)
 739
 740 setDryRun :: IO ()
 741 setDryRun = writeIORef v_Dry_run True
 742
 743 -----------------------------------------------------------------------------
 744 -- Running an external program
 745
 746 runSomething :: DynFlags
 747              -> String          -- For -v message
 748              -> String          -- Command name (possibly a full path)
 749                                 --      assumed already dos-ified
 750              -> [Option]        -- Arguments
 751                                 --      runSomething will dos-ify them
 752              -> IO ()
 753
 754 runSomething dflags phase_name pgm args = do
 755   let real_args = filter notNull (map showOpt args)
 756   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
 757   exit_code <- rawSystem pgm real_args
 758   case exit_code of
 759      ExitSuccess ->
 760         return ()
 761      -- rawSystem returns (ExitFailure 127) if the exec failed for any
 762      -- reason (eg. the program doesn't exist).  This is the only clue
 763      -- we have, but we need to report something to the user because in
 764      -- the case of a missing program there will otherwise be no output
 765      -- at all.
 766      ExitFailure 127 ->
 767         throwDyn (InstallationError ("could not execute: " ++ pgm))
 768      ExitFailure _other ->
 769         throwDyn (PhaseFailed phase_name exit_code)
 770
 771 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 772 -- a) trace the command (at two levels of verbosity)
 773 -- b) don't do it at all if dry-run is set
 774 traceCmd dflags phase_name cmd_line action
 775  = do   { let verb = verbosity dflags
 776         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 777         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 778         ; hFlush stderr
 779
 780            -- Test for -n flag
 781         ; n <- readIORef v_Dry_run
 782         ; unless n $ do {
 783
 784            -- And run it!
 785         ; action `IO.catch` handle_exn verb
 786         }}
 787   where
 788     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 789                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
 790                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 791 \end{code}
 792
 793
 794 %************************************************************************
 795 %*                                                                      *
 796 \subsection{Path names}
 797 %*                                                                      *
 798 %************************************************************************
 799
 800 We maintain path names in Unix form ('/'-separated) right until
 801 the last moment.  On Windows we dos-ify them just before passing them
 802 to the Windows command.
 803
 804 The alternative, of using '/' consistently on Unix and '\' on Windows,
 805 proved quite awkward.  There were a lot more calls to platformPath,
 806 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 807 interpreted a command line 'foo\baz' as 'foobaz'.
 808
 809 \begin{code}
 810 -----------------------------------------------------------------------------
 811 -- Convert filepath into platform / MSDOS form.
 812
 813 normalisePath :: String -> String
 814 -- Just changes '\' to '/'
 815
 816 pgmPath :: String               -- Directory string in Unix format
 817         -> String               -- Program name with no directory separators
 818                                 --      (e.g. copy /y)
 819         -> String               -- Program invocation string in native format
 820
 821
 822
 823 #if defined(mingw32_HOST_OS)
 824 --------------------- Windows version ------------------
 825 normalisePath xs = subst '\\' '/' xs
 826 platformPath p   = subst '/' '\\' p
 827 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 828
 829 subst a b ls = map (\ x -> if x == a then b else x) ls
 830 #else
 831 --------------------- Non-Windows version --------------
 832 normalisePath xs   = xs
 833 pgmPath dir pgm    = dir ++ '/' : pgm
 834 platformPath stuff = stuff
 835 --------------------------------------------------------
 836 #endif
 837
 838 \end{code}
 839
 840
 841 -----------------------------------------------------------------------------
 842    Path name construction
 843
 844 \begin{code}
 845 slash            :: String -> String -> String
 846 slash s1 s2 = s1 ++ ('/' : s2)
 847 \end{code}
 848
 849
 850 %************************************************************************
 851 %*                                                                      *
 852 \subsection{Support code}
 853 %*                                                                      *
 854 %************************************************************************
 855
 856 \begin{code}
 857 -----------------------------------------------------------------------------
 858 -- Define       getBaseDir     :: IO (Maybe String)
 859
 860 #if defined(mingw32_HOST_OS)
 861 getBaseDir :: IO (Maybe String)
 862 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 863 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 864 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 865                 buf <- mallocArray len
 866                 ret <- getModuleFileName nullPtr buf len
 867                 if ret == 0 then free buf >> return Nothing
 868                             else do s <- peekCString buf
 869                                     free buf
 870                                     return (Just (rootDir s))
 871   where
 872     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 873
 874 foreign import stdcall unsafe "GetModuleFileNameA"
 875   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 876 #else
 877 getBaseDir :: IO (Maybe String) = do return Nothing
 878 #endif
 879
 880 #ifdef mingw32_HOST_OS
 881 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 882 #elif __GLASGOW_HASKELL__ > 504
 883 getProcessID :: IO Int
 884 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 885 #else
 886 getProcessID :: IO Int
 887 getProcessID = Posix.getProcessID
 888 #endif
 889
 890 \end{code}