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