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, toArgs )
  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/config.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__ < 601
 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)        -- gcc
 193 GLOBAL_VAR(v_Pgm_m,     error "pgm_m",   String)        -- asm code mangler
 194 GLOBAL_VAR(v_Pgm_s,     error "pgm_s",   String)        -- asm code splitter
 195 GLOBAL_VAR(v_Pgm_a,     error "pgm_a",   String)        -- 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)        -- ld
 201 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)        -- 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_path  | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
 324                         | otherwise    = cGCC
 325                 -- The trailing "/" is absolutely essential; gcc seems
 326                 -- to construct file names simply by concatenating to this
 327                 -- -B path with no extra slash
 328                 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
 329                 -- later on; although gcc_path is in NATIVE format, gcc can cope
 330                 --      (see comments with declarations of global variables)
 331                 --
 332                 -- The quotes round the -B argument are in case TopDir has spaces in it
 333
 334               perl_path | am_installed = installed_bin cGHC_PERL
 335                         | otherwise    = cGHC_PERL
 336
 337         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 338         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY_PGM
 339                           | otherwise    = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
 340
 341         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 342         -- a call to Perl to get the invocation of split and mangle
 343         ; let split_path  = perl_path ++ " \"" ++ split_script ++ "\""
 344               mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
 345
 346         ; let mkdll_path
 347                 | am_installed = pgmPath (installed "gcc-lib/") cMKDLL ++
 348                                  " --dlltool-name " ++ pgmPath (installed "gcc-lib/") "dlltool" ++
 349                                  " --driver-name " ++ gcc_path
 350                 | otherwise    = cMKDLL
 351 #else
 352         --              UNIX-SPECIFIC STUFF
 353         -- On Unix, the "standard" tools are assumed to be
 354         -- in the same place whether we are running "in-place" or "installed"
 355         -- That place is wherever the build-time configure script found them.
 356         ; let   gcc_path   = cGCC
 357                 touch_path = "touch"
 358                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 359
 360         -- On Unix, scripts are invoked using the '#!' method.  Binary
 361         -- installations of GHC on Unix place the correct line on the front
 362         -- of the script at installation time, so we don't want to wire-in
 363         -- our knowledge of $(PERL) on the host system here.
 364         ; let split_path  = split_script
 365               mangle_path = mangle_script
 366 #endif
 367
 368         -- cpp is derived from gcc on all platforms
 369         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
 370         -- Config.hs one day.
 371         ; let cpp_path  = (gcc_path, (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 372
 373         -- For all systems, copy and remove are provided by the host
 374         -- system; architecture-specific stuff is done when building Config.hs
 375         ; let   cp_path = cGHC_CP
 376
 377         -- Other things being equal, as and ld are simply gcc
 378         ; let   as_path  = gcc_path
 379                 ld_path  = gcc_path
 380
 381 #ifdef ILX
 382        -- ilx2il and ilasm are specified in Config.hs
 383        ; let    ilx2il_path = cILX2IL
 384                 ilasm_path  = cILASM
 385 #endif
 386
 387         -- Initialise the global vars
 388         ; writeIORef v_Path_package_config pkgconfig_path
 389         ; writeIORef v_Path_usages         (ghc_usage_msg_path,
 390                                             ghci_usage_msg_path)
 391
 392         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 393                 -- Hans: this isn't right in general, but you can
 394                 -- elaborate it in the same way as the others
 395
 396         ; writeIORef v_Pgm_L               unlit_path
 397         ; writeIORef v_Pgm_P               cpp_path
 398         ; writeIORef v_Pgm_F               ""
 399         ; writeIORef v_Pgm_c               gcc_path
 400         ; writeIORef v_Pgm_m               mangle_path
 401         ; writeIORef v_Pgm_s               split_path
 402         ; writeIORef v_Pgm_a               as_path
 403 #ifdef ILX
 404         ; writeIORef v_Pgm_I               ilx2il_path
 405         ; writeIORef v_Pgm_i               ilasm_path
 406 #endif
 407         ; writeIORef v_Pgm_l               ld_path
 408         ; writeIORef v_Pgm_MkDLL           mkdll_path
 409         ; writeIORef v_Pgm_T               touch_path
 410         ; writeIORef v_Pgm_CP              cp_path
 411
 412         ; return ()
 413         }
 414
 415 #if defined(mingw32_HOST_OS)
 416 foreign import stdcall "GetTempPathA" unsafe getTempPath :: Int -> CString -> IO Int32
 417 #endif
 418 \end{code}
 419
 420 The various setPgm functions are called when a command-line option
 421 like
 422
 423         -pgmLld
 424
 425 is used to override a particular program with a new one
 426
 427 \begin{code}
 428 setPgmL = writeIORef v_Pgm_L
 429 -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
 430 -- Config.hs should really use Option.
 431 setPgmP arg = let (pgm:args) = words arg in writeIORef v_Pgm_P (pgm,map Option args)
 432 setPgmF = writeIORef v_Pgm_F
 433 setPgmc = writeIORef v_Pgm_c
 434 setPgmm = writeIORef v_Pgm_m
 435 setPgms = writeIORef v_Pgm_s
 436 setPgma = writeIORef v_Pgm_a
 437 setPgml = writeIORef v_Pgm_l
 438 setPgmDLL = writeIORef v_Pgm_MkDLL
 439 #ifdef ILX
 440 setPgmI = writeIORef v_Pgm_I
 441 setPgmi = writeIORef v_Pgm_i
 442 #endif
 443 \end{code}
 444
 445
 446 \begin{code}
 447 -- Find TopDir
 448 --      for "installed" this is the root of GHC's support files
 449 --      for "in-place" it is the root of the build tree
 450 --
 451 -- Plan of action:
 452 -- 1. Set proto_top_dir
 453 --      a) look for (the last) -B flag, and use it
 454 --      b) if there are no -B flags, get the directory
 455 --         where GHC is running (only on Windows)
 456 --
 457 -- 2. If package.conf exists in proto_top_dir, we are running
 458 --      installed; and TopDir = proto_top_dir
 459 --
 460 -- 3. Otherwise we are running in-place, so
 461 --      proto_top_dir will be /...stuff.../ghc/compiler
 462 --      Set TopDir to /...stuff..., which is the root of the build tree
 463 --
 464 -- This is very gruesome indeed
 465
 466 findTopDir :: [String]
 467           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 468                  String)        -- TopDir (in Unix format '/' separated)
 469
 470 findTopDir minusbs
 471   = do { top_dir <- get_proto
 472         -- Discover whether we're running in a build tree or in an installation,
 473         -- by looking for the package configuration file.
 474        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 475
 476        ; return (am_installed, top_dir)
 477        }
 478   where
 479     -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
 480     get_proto | notNull minusbs
 481               = return (normalisePath (drop 2 (last minusbs)))  -- 2 for "-B"
 482               | otherwise
 483               = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
 484                    ; case maybe_exec_dir of       -- (only works on Windows;
 485                                                   --  returns Nothing on Unix)
 486                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 487                         Just dir -> return dir
 488                    }
 489 \end{code}
 490
 491
 492 %************************************************************************
 493 %*                                                                      *
 494 \subsection{Command-line options}
 495 n%*                                                                     *
 496 %************************************************************************
 497
 498 When invoking external tools as part of the compilation pipeline, we
 499 pass these a sequence of options on the command-line. Rather than
 500 just using a list of Strings, we use a type that allows us to distinguish
 501 between filepaths and 'other stuff'. [The reason being, of course, that
 502 this type gives us a handle on transforming filenames, and filenames only,
 503 to whatever format they're expected to be on a particular platform.]
 504
 505 \begin{code}
 506 data Option
 507  = FileOption -- an entry that _contains_ filename(s) / filepaths.
 508               String  -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
 509               String  -- the filepath/filename portion
 510  | Option     String
 511
 512 showOpt (FileOption pre f) = pre ++ platformPath f
 513 showOpt (Option "") = ""
 514 showOpt (Option s)  = s
 515
 516 \end{code}
 517
 518
 519 %************************************************************************
 520 %*                                                                      *
 521 \subsection{Running an external program}
 522 %*                                                                      *
 523 %************************************************************************
 524
 525
 526 \begin{code}
 527 runUnlit :: [Option] -> IO ()
 528 runUnlit args = do p <- readIORef v_Pgm_L
 529                    runSomething "Literate pre-processor" p args
 530
 531 runCpp :: [Option] -> IO ()
 532 runCpp args =   do (p,baseArgs) <- readIORef v_Pgm_P
 533                    runSomething "C pre-processor" p (baseArgs ++ args)
 534
 535 runPp :: [Option] -> IO ()
 536 runPp args =   do p <- readIORef v_Pgm_F
 537                   runSomething "Haskell pre-processor" p args
 538
 539 runCc :: [Option] -> IO ()
 540 runCc args =   do p <- readIORef v_Pgm_c
 541                   runSomething "C Compiler" p args
 542
 543 runMangle :: [Option] -> IO ()
 544 runMangle args = do p <- readIORef v_Pgm_m
 545                     runSomething "Mangler" p args
 546
 547 runSplit :: [Option] -> IO ()
 548 runSplit args = do p <- readIORef v_Pgm_s
 549                    runSomething "Splitter" p args
 550
 551 runAs :: [Option] -> IO ()
 552 runAs args = do p <- readIORef v_Pgm_a
 553                 runSomething "Assembler" p args
 554
 555 runLink :: [Option] -> IO ()
 556 runLink args = do p <- readIORef v_Pgm_l
 557                   runSomething "Linker" p args
 558
 559 #ifdef ILX
 560 runIlx2il :: [Option] -> IO ()
 561 runIlx2il args = do p <- readIORef v_Pgm_I
 562                     runSomething "Ilx2Il" p args
 563
 564 runIlasm :: [Option] -> IO ()
 565 runIlasm args = do p <- readIORef v_Pgm_i
 566                    runSomething "Ilasm" p args
 567 #endif
 568
 569 runMkDLL :: [Option] -> IO ()
 570 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 571                    runSomething "Make DLL" p args
 572
 573 touch :: String -> String -> IO ()
 574 touch purpose arg =  do p <- readIORef v_Pgm_T
 575                         runSomething purpose p [FileOption "" arg]
 576
 577 copy :: String -> String -> String -> IO ()
 578 copy purpose from to = do
 579   verb <- dynFlag verbosity
 580   when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 581
 582   h <- openFile to WriteMode
 583   ls <- readFile from -- inefficient, but it'll do for now.
 584                       -- ToDo: speed up via slurping.
 585   hPutStr h ls
 586   hClose h
 587 \end{code}
 588
 589 \begin{code}
 590 getSysMan :: IO String  -- How to invoke the system manager
 591                         -- (parallel system only)
 592 getSysMan = readIORef v_Pgm_sysman
 593 \end{code}
 594
 595 \begin{code}
 596 getUsageMsgPaths :: IO (FilePath,FilePath)
 597           -- the filenames of the usage messages (ghc, ghci)
 598 getUsageMsgPaths = readIORef v_Path_usages
 599 \end{code}
 600
 601
 602 %************************************************************************
 603 %*                                                                      *
 604 \subsection{Managing temporary files
 605 %*                                                                      *
 606 %************************************************************************
 607
 608 \begin{code}
 609 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 610 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 611         -- v_TmpDir has no closing '/'
 612 \end{code}
 613
 614 \begin{code}
 615 setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
 616     where
 617 #if !defined(mingw32_HOST_OS)
 618      canonicalise p = normalisePath p
 619 #else
 620         -- Canonicalisation of temp path under win32 is a bit more
 621         -- involved: (a) strip trailing slash,
 622         --           (b) normalise slashes
 623         --           (c) just in case, if there is a prefix /cygdrive/x/, change to x:
 624         --
 625      canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
 626
 627         -- if we're operating under cygwin, and TMP/TEMP is of
 628         -- the form "/cygdrive/drive/path", translate this to
 629         -- "drive:/path" (as GHC isn't a cygwin app and doesn't
 630         -- understand /cygdrive paths.)
 631      xltCygdrive path
 632       | "/cygdrive/" `isPrefixOf` path =
 633           case drop (length "/cygdrive/") path of
 634             drive:xs@('/':_) -> drive:':':xs
 635             _ -> path
 636       | otherwise = path
 637
 638         -- strip the trailing backslash (awful, but we only do this once).
 639      removeTrailingSlash path =
 640        case last path of
 641          '/'  -> init path
 642          '\\' -> init path
 643          _    -> path
 644 #endif
 645
 646 cleanTempFiles :: Int -> IO ()
 647 cleanTempFiles verb
 648    = do fs <- readIORef v_FilesToClean
 649         removeTmpFiles verb fs
 650         writeIORef v_FilesToClean []
 651
 652 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 653 cleanTempFilesExcept verb dont_delete
 654    = do files <- readIORef v_FilesToClean
 655         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 656         removeTmpFiles verb to_delete
 657         writeIORef v_FilesToClean to_keep
 658
 659
 660 -- find a temporary name that doesn't already exist.
 661 newTempName :: Suffix -> IO FilePath
 662 newTempName extn
 663   = do x <- getProcessID
 664        tmp_dir <- readIORef v_TmpDir
 665        findTempName tmp_dir x
 666   where
 667     findTempName tmp_dir x
 668       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 669            b  <- doesFileExist filename
 670            if b then findTempName tmp_dir (x+1)
 671                 else do add v_FilesToClean filename -- clean it up later
 672                         return filename
 673
 674 addFilesToClean :: [FilePath] -> IO ()
 675 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 676 addFilesToClean files = mapM_ (add v_FilesToClean) files
 677
 678 removeTmpFiles :: Int -> [FilePath] -> IO ()
 679 removeTmpFiles verb fs
 680   = warnNon $
 681     traceCmd "Deleting temp files"
 682              ("Deleting: " ++ unwords deletees)
 683              (mapM_ rm deletees)
 684   where
 685      -- Flat out refuse to delete files that are likely to be source input
 686      -- files (is there a worse bug than having a compiler delete your source
 687      -- files?)
 688      --
 689      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 690      -- the condition.
 691     warnNon act
 692      | null non_deletees = act
 693      | otherwise         = do
 694         hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
 695         act
 696
 697     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 698
 699     rm f = removeFile f `IO.catch`
 700                 (\_ignored ->
 701                     when (verb >= 2) $
 702                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 703                 )
 704
 705 \end{code}
 706
 707
 708 %************************************************************************
 709 %*                                                                      *
 710 \subsection{Running a program}
 711 %*                                                                      *
 712 %************************************************************************
 713
 714 \begin{code}
 715 GLOBAL_VAR(v_Dry_run, False, Bool)
 716
 717 setDryRun :: IO ()
 718 setDryRun = writeIORef v_Dry_run True
 719
 720 -----------------------------------------------------------------------------
 721 -- Running an external program
 722
 723 runSomething :: String          -- For -v message
 724              -> String          -- Command name (possibly a full path)
 725                                 --      assumed already dos-ified
 726              -> [Option]        -- Arguments
 727                                 --      runSomething will dos-ify them
 728              -> IO ()
 729
 730 runSomething phase_name pgm args = do
 731   let real_args = filter notNull (map showOpt args)
 732     -- Don't assume that 'pgm' contains the program path only,
 733     -- but split it up and shift any arguments over to the arg vector.
 734   let (real_pgm, argv) =
 735         case toArgs pgm of
 736           []     -> (pgm, real_args) -- let rawSystem be the bearer of bad news..
 737           (x:xs) -> (x, xs ++ real_args)
 738   traceCmd phase_name (unwords (pgm:real_args)) $ do
 739   exit_code <- rawSystem real_pgm argv
 740   if (exit_code /= ExitSuccess)
 741         then throwDyn (PhaseFailed phase_name exit_code)
 742         else return ()
 743
 744 traceCmd :: String -> String -> IO () -> IO ()
 745 -- a) trace the command (at two levels of verbosity)
 746 -- b) don't do it at all if dry-run is set
 747 traceCmd phase_name cmd_line action
 748  = do   { verb <- dynFlag verbosity
 749         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 750         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 751         ; hFlush stderr
 752
 753            -- Test for -n flag
 754         ; n <- readIORef v_Dry_run
 755         ; unless n $ do {
 756
 757            -- And run it!
 758         ; action `IO.catch` handle_exn verb
 759         }}
 760   where
 761     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 762                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
 763                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 764
 765 -- -----------------------------------------------------------------------------
 766 -- rawSystem: run an external command
 767
 768 #if __GLASGOW_HASKELL__ < 601
 769
 770 -- This code is copied from System.Cmd on GHC 6.1.
 771
 772 rawSystem :: FilePath -> [String] -> IO ExitCode
 773
 774 #ifndef mingw32_TARGET_OS
 775
 776 rawSystem cmd args =
 777   withCString cmd $ \pcmd ->
 778     withMany withCString (cmd:args) $ \cstrs ->
 779       withArray0 nullPtr cstrs $ \arr -> do
 780         status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr)
 781         case status of
 782             0  -> return ExitSuccess
 783             n  -> return (ExitFailure n)
 784
 785 foreign import ccall "rawSystem" unsafe
 786   c_rawSystem :: CString -> Ptr CString -> IO Int
 787
 788 #else
 789
 790 -- On Windows, the command line is passed to the operating system as
 791 -- a single string.  Command-line parsing is done by the executable
 792 -- itself.
 793 rawSystem cmd args = do
 794         -- NOTE: 'cmd' is assumed to contain the application to run _only_,
 795         -- as it'll be quoted surrounded in quotes here.
 796   let cmdline = translate cmd ++ concat (map ((' ':) . translate) args)
 797   withCString cmdline $ \pcmdline -> do
 798     status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
 799     case status of
 800        0  -> return ExitSuccess
 801        n  -> return (ExitFailure n)
 802
 803 translate :: String -> String
 804 translate str@('"':_) = str -- already escaped.
 805 translate str = '"' : foldr escape "\"" str
 806   where escape '"'  str = '\\' : '"'  : str
 807         escape '\\' str = '\\' : '\\' : str
 808         escape c    str = c : str
 809
 810 foreign import ccall "rawSystem" unsafe
 811   c_rawSystem :: CString -> IO Int
 812
 813 #endif
 814 #endif
 815 \end{code}
 816
 817
 818 %************************************************************************
 819 %*                                                                      *
 820 \subsection{Path names}
 821 %*                                                                      *
 822 %************************************************************************
 823
 824 We maintain path names in Unix form ('/'-separated) right until
 825 the last moment.  On Windows we dos-ify them just before passing them
 826 to the Windows command.
 827
 828 The alternative, of using '/' consistently on Unix and '\' on Windows,
 829 proved quite awkward.  There were a lot more calls to platformPath,
 830 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 831 interpreted a command line 'foo\baz' as 'foobaz'.
 832
 833 \begin{code}
 834 -----------------------------------------------------------------------------
 835 -- Convert filepath into platform / MSDOS form.
 836
 837 normalisePath :: String -> String
 838 -- Just changes '\' to '/'
 839
 840 pgmPath :: String               -- Directory string in Unix format
 841         -> String               -- Program name with no directory separators
 842                                 --      (e.g. copy /y)
 843         -> String               -- Program invocation string in native format
 844
 845
 846
 847 #if defined(mingw32_HOST_OS)
 848 --------------------- Windows version ------------------
 849 normalisePath xs = subst '\\' '/' xs
 850 platformPath p   = subst '/' '\\' p
 851 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 852
 853 subst a b ls = map (\ x -> if x == a then b else x) ls
 854 #else
 855 --------------------- Non-Windows version --------------
 856 normalisePath xs   = xs
 857 pgmPath dir pgm    = dir ++ '/' : pgm
 858 platformPath stuff = stuff
 859 --------------------------------------------------------
 860 #endif
 861
 862 \end{code}
 863
 864
 865 -----------------------------------------------------------------------------
 866    Path name construction
 867
 868 \begin{code}
 869 slash            :: String -> String -> String
 870 slash s1 s2 = s1 ++ ('/' : s2)
 871 \end{code}
 872
 873
 874 %************************************************************************
 875 %*                                                                      *
 876 \subsection{Support code}
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 \begin{code}
 881 -----------------------------------------------------------------------------
 882 -- Define       getBaseDir     :: IO (Maybe String)
 883
 884 #if defined(mingw32_HOST_OS)
 885 getBaseDir :: IO (Maybe String)
 886 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 887 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 888 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 889                 buf <- mallocArray len
 890                 ret <- getModuleFileName nullPtr buf len
 891                 if ret == 0 then free buf >> return Nothing
 892                             else do s <- peekCString buf
 893                                     free buf
 894                                     return (Just (rootDir s))
 895   where
 896     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 897
 898 foreign import stdcall "GetModuleFileNameA" unsafe
 899   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 900 #else
 901 getBaseDir :: IO (Maybe String) = do return Nothing
 902 #endif
 903
 904 #ifdef mingw32_HOST_OS
 905 foreign import ccall "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
 906 #elif __GLASGOW_HASKELL__ > 504
 907 getProcessID :: IO Int
 908 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 909 #else
 910 getProcessID :: IO Int
 911 getProcessID = Posix.getProcessID
 912 #endif
 913
 914 \end{code}