ghc/compiler/main/SysTools.lhs

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