ghc/compiler/main/SysTools.lhs

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