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 #ifdef ILX
  23         setPgmI,
  24         setPgmi,
  25 #endif
  26                                 -- Command-line override
  27         setDryRun,
  28
  29         getTopDir,              -- IO String    -- The value of $libdir
  30         getPackageConfigPath,   -- IO String    -- Where package.conf is
  31         getUsageMsgPaths,       -- IO (String,String)
  32
  33         -- Interface to system tools
  34         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  35         runPp,                   -- [Option] -> IO ()
  36         runMangle, runSplit,     -- [Option] -> IO ()
  37         runAs, runLink,          -- [Option] -> IO ()
  38         runMkDLL,
  39 #ifdef ILX
  40         runIlx2il, runIlasm,     -- [String] -> IO ()
  41 #endif
  42
  43
  44         touch,                  -- String -> String -> IO ()
  45         copy,                   -- String -> String -> String -> IO ()
  46         normalisePath,          -- FilePath -> FilePath
  47
  48         -- Temporary-file management
  49         setTmpDir,
  50         newTempName,
  51         cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
  52         addFilesToClean,
  53
  54         -- System interface
  55         getProcessID,           -- IO Int
  56         system,                 -- String -> IO ExitCode
  57
  58         -- Misc
  59         getSysMan,              -- IO String    Parallel system only
  60
  61         Option(..)
  62
  63  ) where
  64
  65 #include "HsVersions.h"
  66
  67 import DriverUtil
  68 import DriverPhases     ( isHaskellUserSrcFilename )
  69 import Config
  70 import Outputable
  71 import Panic            ( GhcException(..) )
  72 import Util             ( global, notNull )
  73 import CmdLineOpts      ( dynFlag, verbosity )
  74
  75 import EXCEPTION        ( throwDyn )
  76 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  77 import DATA_INT
  78
  79 import Monad            ( when, unless )
  80 import System           ( ExitCode(..), getEnv, system )
  81 import IO               ( try, catch,
  82                           openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
  83                           stderr )
  84 import Directory        ( doesFileExist, removeFile )
  85 import List             ( intersperse, 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 #ifdef ILX
 439 setPgmI = writeIORef v_Pgm_I
 440 setPgmi = writeIORef v_Pgm_i
 441 #endif
 442 \end{code}
 443
 444
 445 \begin{code}
 446 -- Find TopDir
 447 --      for "installed" this is the root of GHC's support files
 448 --      for "in-place" it is the root of the build tree
 449 --
 450 -- Plan of action:
 451 -- 1. Set proto_top_dir
 452 --      a) look for (the last) -B flag, and use it
 453 --      b) if there are no -B flags, get the directory
 454 --         where GHC is running (only on Windows)
 455 --
 456 -- 2. If package.conf exists in proto_top_dir, we are running
 457 --      installed; and TopDir = proto_top_dir
 458 --
 459 -- 3. Otherwise we are running in-place, so
 460 --      proto_top_dir will be /...stuff.../ghc/compiler
 461 --      Set TopDir to /...stuff..., which is the root of the build tree
 462 --
 463 -- This is very gruesome indeed
 464
 465 findTopDir :: [String]
 466           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 467                  String)        -- TopDir (in Unix format '/' separated)
 468
 469 findTopDir minusbs
 470   = do { top_dir <- get_proto
 471         -- Discover whether we're running in a build tree or in an installation,
 472         -- by looking for the package configuration file.
 473        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 474
 475        ; return (am_installed, top_dir)
 476        }
 477   where
 478     -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
 479     get_proto | notNull minusbs
 480               = return (normalisePath (drop 2 (last minusbs)))  -- 2 for "-B"
 481               | otherwise
 482               = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
 483                    ; case maybe_exec_dir of       -- (only works on Windows;
 484                                                   --  returns Nothing on Unix)
 485                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 486                         Just dir -> return dir
 487                    }
 488 \end{code}
 489
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsection{Command-line options}
 494 n%*                                                                     *
 495 %************************************************************************
 496
 497 When invoking external tools as part of the compilation pipeline, we
 498 pass these a sequence of options on the command-line. Rather than
 499 just using a list of Strings, we use a type that allows us to distinguish
 500 between filepaths and 'other stuff'. [The reason being, of course, that
 501 this type gives us a handle on transforming filenames, and filenames only,
 502 to whatever format they're expected to be on a particular platform.]
 503
 504 \begin{code}
 505 data Option
 506  = FileOption -- an entry that _contains_ filename(s) / filepaths.
 507               String  -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
 508               String  -- the filepath/filename portion
 509  | Option     String
 510
 511 showOpt (FileOption pre f) = pre ++ platformPath f
 512 showOpt (Option "") = ""
 513 showOpt (Option s)  = s
 514
 515 \end{code}
 516
 517
 518 %************************************************************************
 519 %*                                                                      *
 520 \subsection{Running an external program}
 521 %*                                                                      *
 522 %************************************************************************
 523
 524
 525 \begin{code}
 526 runUnlit :: [Option] -> IO ()
 527 runUnlit args = do p <- readIORef v_Pgm_L
 528                    runSomething "Literate pre-processor" p args
 529
 530 runCpp :: [Option] -> IO ()
 531 runCpp args =   do (p,baseArgs) <- readIORef v_Pgm_P
 532                    runSomething "C pre-processor" p (baseArgs ++ args)
 533
 534 runPp :: [Option] -> IO ()
 535 runPp args =   do p <- readIORef v_Pgm_F
 536                   runSomething "Haskell pre-processor" p args
 537
 538 runCc :: [Option] -> IO ()
 539 runCc args =   do p <- readIORef v_Pgm_c
 540                   runSomething "C Compiler" p args
 541
 542 runMangle :: [Option] -> IO ()
 543 runMangle args = do p <- readIORef v_Pgm_m
 544                     runSomething "Mangler" p args
 545
 546 runSplit :: [Option] -> IO ()
 547 runSplit args = do p <- readIORef v_Pgm_s
 548                    runSomething "Splitter" p args
 549
 550 runAs :: [Option] -> IO ()
 551 runAs args = do p <- readIORef v_Pgm_a
 552                 runSomething "Assembler" p args
 553
 554 runLink :: [Option] -> IO ()
 555 runLink args = do p <- readIORef v_Pgm_l
 556                   runSomething "Linker" p args
 557
 558 #ifdef ILX
 559 runIlx2il :: [Option] -> IO ()
 560 runIlx2il args = do p <- readIORef v_Pgm_I
 561                     runSomething "Ilx2Il" p args
 562
 563 runIlasm :: [Option] -> IO ()
 564 runIlasm args = do p <- readIORef v_Pgm_i
 565                    runSomething "Ilasm" p args
 566 #endif
 567
 568 runMkDLL :: [Option] -> IO ()
 569 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 570                    runSomething "Make DLL" p args
 571
 572 touch :: String -> String -> IO ()
 573 touch purpose arg =  do p <- readIORef v_Pgm_T
 574                         runSomething purpose p [FileOption "" arg]
 575
 576 copy :: String -> String -> String -> IO ()
 577 copy purpose from to = do
 578   verb <- dynFlag verbosity
 579   when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 580
 581   h <- openFile to WriteMode
 582   ls <- readFile from -- inefficient, but it'll do for now.
 583                       -- ToDo: speed up via slurping.
 584   hPutStr h ls
 585   hClose h
 586 \end{code}
 587
 588 \begin{code}
 589 getSysMan :: IO String  -- How to invoke the system manager
 590                         -- (parallel system only)
 591 getSysMan = readIORef v_Pgm_sysman
 592 \end{code}
 593
 594 \begin{code}
 595 getUsageMsgPaths :: IO (FilePath,FilePath)
 596           -- the filenames of the usage messages (ghc, ghci)
 597 getUsageMsgPaths = readIORef v_Path_usages
 598 \end{code}
 599
 600
 601 %************************************************************************
 602 %*                                                                      *
 603 \subsection{Managing temporary files
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 \begin{code}
 608 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 609 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 610         -- v_TmpDir has no closing '/'
 611 \end{code}
 612
 613 \begin{code}
 614 setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
 615     where
 616 #if !defined(mingw32_HOST_OS)
 617      canonicalise p = normalisePath p
 618 #else
 619         -- Canonicalisation of temp path under win32 is a bit more
 620         -- involved: (a) strip trailing slash,
 621         --           (b) normalise slashes
 622         --           (c) just in case, if there is a prefix /cygdrive/x/, change to x:
 623         --
 624      canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
 625
 626         -- if we're operating under cygwin, and TMP/TEMP is of
 627         -- the form "/cygdrive/drive/path", translate this to
 628         -- "drive:/path" (as GHC isn't a cygwin app and doesn't
 629         -- understand /cygdrive paths.)
 630      xltCygdrive path
 631       | "/cygdrive/" `isPrefixOf` path =
 632           case drop (length "/cygdrive/") path of
 633             drive:xs@('/':_) -> drive:':':xs
 634             _ -> path
 635       | otherwise = path
 636
 637         -- strip the trailing backslash (awful, but we only do this once).
 638      removeTrailingSlash path =
 639        case last path of
 640          '/'  -> init path
 641          '\\' -> init path
 642          _    -> path
 643 #endif
 644
 645 cleanTempFiles :: Int -> IO ()
 646 cleanTempFiles verb
 647    = do fs <- readIORef v_FilesToClean
 648         removeTmpFiles verb fs
 649         writeIORef v_FilesToClean []
 650
 651 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 652 cleanTempFilesExcept verb dont_delete
 653    = do files <- readIORef v_FilesToClean
 654         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 655         removeTmpFiles verb to_delete
 656         writeIORef v_FilesToClean to_keep
 657
 658
 659 -- find a temporary name that doesn't already exist.
 660 newTempName :: Suffix -> IO FilePath
 661 newTempName extn
 662   = do x <- getProcessID
 663        tmp_dir <- readIORef v_TmpDir
 664        findTempName tmp_dir x
 665   where
 666     findTempName tmp_dir x
 667       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 668            b  <- doesFileExist filename
 669            if b then findTempName tmp_dir (x+1)
 670                 else do add v_FilesToClean filename -- clean it up later
 671                         return filename
 672
 673 addFilesToClean :: [FilePath] -> IO ()
 674 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 675 addFilesToClean files = mapM_ (add v_FilesToClean) files
 676
 677 removeTmpFiles :: Int -> [FilePath] -> IO ()
 678 removeTmpFiles verb fs
 679   = warnNon $
 680     traceCmd "Deleting temp files"
 681              ("Deleting: " ++ unwords deletees)
 682              (mapM_ rm deletees)
 683   where
 684      -- Flat out refuse to delete files that are likely to be source input
 685      -- files (is there a worse bug than having a compiler delete your source
 686      -- files?)
 687      --
 688      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 689      -- the condition.
 690     warnNon act
 691      | null non_deletees = act
 692      | otherwise         = do
 693         hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
 694         act
 695
 696     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 697
 698     rm f = removeFile f `IO.catch`
 699                 (\_ignored ->
 700                     when (verb >= 2) $
 701                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 702                 )
 703
 704 \end{code}
 705
 706
 707 %************************************************************************
 708 %*                                                                      *
 709 \subsection{Running a program}
 710 %*                                                                      *
 711 %************************************************************************
 712
 713 \begin{code}
 714 GLOBAL_VAR(v_Dry_run, False, Bool)
 715
 716 setDryRun :: IO ()
 717 setDryRun = writeIORef v_Dry_run True
 718
 719 -----------------------------------------------------------------------------
 720 -- Running an external program
 721
 722 runSomething :: String          -- For -v message
 723              -> String          -- Command name (possibly a full path)
 724                                 --      assumed already dos-ified
 725              -> [Option]        -- Arguments
 726                                 --      runSomething will dos-ify them
 727              -> IO ()
 728
 729 runSomething phase_name pgm args = do
 730   let real_args = filter notNull (map showOpt args)
 731   traceCmd phase_name (concat (intersperse " " (pgm:real_args))) $ do
 732   exit_code <- rawSystem pgm real_args
 733   if (exit_code /= ExitSuccess)
 734         then throwDyn (PhaseFailed phase_name exit_code)
 735         else return ()
 736
 737 traceCmd :: String -> String -> IO () -> IO ()
 738 -- a) trace the command (at two levels of verbosity)
 739 -- b) don't do it at all if dry-run is set
 740 traceCmd phase_name cmd_line action
 741  = do   { verb <- dynFlag verbosity
 742         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 743         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 744         ; hFlush stderr
 745
 746            -- Test for -n flag
 747         ; n <- readIORef v_Dry_run
 748         ; unless n $ do {
 749
 750            -- And run it!
 751         ; action `IO.catch` handle_exn verb
 752         }}
 753   where
 754     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 755                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
 756                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 757
 758 -- -----------------------------------------------------------------------------
 759 -- rawSystem: run an external command
 760
 761 #if __GLASGOW_HASKELL__ < 601
 762
 763 -- This code is copied from System.Cmd on GHC 6.1.
 764
 765 rawSystem :: FilePath -> [String] -> IO ExitCode
 766
 767 #ifndef mingw32_TARGET_OS
 768
 769 rawSystem cmd args =
 770   withCString cmd $ \pcmd ->
 771     withMany withCString (cmd:args) $ \cstrs ->
 772       withArray0 nullPtr cstrs $ \arr -> do
 773         status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr)
 774         case status of
 775             0  -> return ExitSuccess
 776             n  -> return (ExitFailure n)
 777
 778 foreign import ccall "rawSystem" unsafe
 779   c_rawSystem :: CString -> Ptr CString -> IO Int
 780
 781 #else
 782
 783 -- On Windows, the command line is passed to the operating system as
 784 -- a single string.  Command-line parsing is done by the executable
 785 -- itself.
 786 rawSystem cmd args = do
 787   let cmdline = {-translate-} cmd ++ concat (map ((' ':) . translate) args)
 788         -- Urk, don't quote/escape the command name on Windows, because the
 789         -- compiler is exceedingly naughty and sometimes uses 'perl "..."'
 790         -- as the command name.
 791   withCString cmdline $ \pcmdline -> do
 792     status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
 793     case status of
 794        0  -> return ExitSuccess
 795        n  -> return (ExitFailure n)
 796
 797 translate :: String -> String
 798 translate str = '"' : foldr escape "\"" str
 799   where escape '"'  str = '\\' : '"'  : str
 800         escape '\\' str = '\\' : '\\' : str
 801         escape c    str = c : str
 802
 803 foreign import ccall "rawSystem" unsafe
 804   c_rawSystem :: CString -> IO Int
 805
 806 #endif
 807 #endif
 808 \end{code}
 809
 810
 811 %************************************************************************
 812 %*                                                                      *
 813 \subsection{Path names}
 814 %*                                                                      *
 815 %************************************************************************
 816
 817 We maintain path names in Unix form ('/'-separated) right until
 818 the last moment.  On Windows we dos-ify them just before passing them
 819 to the Windows command.
 820
 821 The alternative, of using '/' consistently on Unix and '\' on Windows,
 822 proved quite awkward.  There were a lot more calls to platformPath,
 823 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 824 interpreted a command line 'foo\baz' as 'foobaz'.
 825
 826 \begin{code}
 827 -----------------------------------------------------------------------------
 828 -- Convert filepath into platform / MSDOS form.
 829
 830 normalisePath :: String -> String
 831 -- Just changes '\' to '/'
 832
 833 pgmPath :: String               -- Directory string in Unix format
 834         -> String               -- Program name with no directory separators
 835                                 --      (e.g. copy /y)
 836         -> String               -- Program invocation string in native format
 837
 838
 839
 840 #if defined(mingw32_HOST_OS)
 841 --------------------- Windows version ------------------
 842 normalisePath xs = subst '\\' '/' xs
 843 platformPath p   = subst '/' '\\' p
 844 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 845
 846 subst a b ls = map (\ x -> if x == a then b else x) ls
 847 #else
 848 --------------------- Non-Windows version --------------
 849 normalisePath xs   = xs
 850 pgmPath dir pgm    = dir ++ '/' : pgm
 851 platformPath stuff = stuff
 852 --------------------------------------------------------
 853 #endif
 854
 855 \end{code}
 856
 857
 858 -----------------------------------------------------------------------------
 859    Path name construction
 860
 861 \begin{code}
 862 slash            :: String -> String -> String
 863 slash s1 s2 = s1 ++ ('/' : s2)
 864 \end{code}
 865
 866
 867 %************************************************************************
 868 %*                                                                      *
 869 \subsection{Support code}
 870 %*                                                                      *
 871 %************************************************************************
 872
 873 \begin{code}
 874 -----------------------------------------------------------------------------
 875 -- Define       getBaseDir     :: IO (Maybe String)
 876
 877 #if defined(mingw32_HOST_OS)
 878 getBaseDir :: IO (Maybe String)
 879 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 880 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 881 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 882                 buf <- mallocArray len
 883                 ret <- getModuleFileName nullPtr buf len
 884                 if ret == 0 then free buf >> return Nothing
 885                             else do s <- peekCString buf
 886                                     free buf
 887                                     return (Just (rootDir s))
 888   where
 889     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 890
 891 foreign import stdcall "GetModuleFileNameA" unsafe
 892   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 893 #else
 894 getBaseDir :: IO (Maybe String) = do return Nothing
 895 #endif
 896
 897 #ifdef mingw32_HOST_OS
 898 foreign import ccall "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
 899 #elif __GLASGOW_HASKELL__ > 504
 900 getProcessID :: IO Int
 901 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 902 #else
 903 getProcessID :: IO Int
 904 getProcessID = Posix.getProcessID
 905 #endif
 906
 907 \end{code}