ghc/compiler/main/SysTools.lhs

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