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