ghc/compiler/main/SysTools.lhs

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