ghc/compiler/main/SysTools.lhs

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