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