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