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               perl_path | am_installed = installed_bin cGHC_PERL
 247                         | otherwise    = cGHC_PERL
 248
 249         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 250         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
 251                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 252
 253         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 254         -- a call to Perl to get the invocation of split and mangle
 255         ; let split_path  = perl_path ++ " " ++ split_script
 256               mangle_path = perl_path ++ " " ++ mangle_script
 257
 258         ; let mkdll_path = cMKDLL
 259 #else
 260         --              UNIX-SPECIFIC STUFF
 261         -- On Unix, the "standard" tools are assumed to be
 262         -- in the same place whether we are running "in-place" or "installed"
 263         -- That place is wherever the build-time configure script found them.
 264         ; let   gcc_path   = cGCC
 265                 touch_path = cGHC_TOUCHY
 266                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 267
 268         -- On Unix, scripts are invoked using the '#!' method.  Binary
 269         -- installations of GHC on Unix place the correct line on the front
 270         -- of the script at installation time, so we don't want to wire-in
 271         -- our knowledge of $(PERL) on the host system here.
 272         ; let split_path  = split_script
 273               mangle_path = mangle_script
 274 #endif
 275
 276         -- cpp is derived from gcc on all platforms
 277         ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
 278
 279         -- For all systems, copy and remove are provided by the host
 280         -- system; architecture-specific stuff is done when building Config.hs
 281         ; let   cp_path = cGHC_CP
 282
 283         -- Other things being equal, as and ld are simply gcc
 284         ; let   as_path  = gcc_path
 285                 ld_path  = gcc_path
 286
 287
 288         -- Initialise the global vars
 289         ; writeIORef v_Path_package_config pkgconfig_path
 290         ; writeIORef v_Path_usage          ghc_usage_msg_path
 291
 292         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 293                 -- Hans: this isn't right in general, but you can
 294                 -- elaborate it in the same way as the others
 295
 296         ; writeIORef v_Pgm_L               unlit_path
 297         ; writeIORef v_Pgm_P               cpp_path
 298         ; writeIORef v_Pgm_c               gcc_path
 299         ; writeIORef v_Pgm_m               mangle_path
 300         ; writeIORef v_Pgm_s               split_path
 301         ; writeIORef v_Pgm_a               as_path
 302         ; writeIORef v_Pgm_l               ld_path
 303         ; writeIORef v_Pgm_MkDLL           mkdll_path
 304         ; writeIORef v_Pgm_T               touch_path
 305         ; writeIORef v_Pgm_CP              cp_path
 306
 307         ; return top_dir
 308         }
 309 \end{code}
 310
 311 setPgm is called when a command-line option like
 312         -pgmLld
 313 is used to override a particular program with a new onw
 314
 315 \begin{code}
 316 setPgm :: String -> IO ()
 317 -- The string is the flag, minus the '-pgm' prefix
 318 -- So the first character says which program to override
 319
 320 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 321 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 322 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 323 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 324 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 325 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 326 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 327 \end{code}
 328
 329
 330 \begin{code}
 331 -- Find TopDir
 332 --      for "installed" this is the root of GHC's support files
 333 --      for "in-place" it is the root of the build tree
 334 --
 335 -- Plan of action:
 336 -- 1. Set proto_top_dir
 337 --      a) look for (the last) -B flag, and use it
 338 --      b) if there are no -B flags, get the directory
 339 --         where GHC is running (only on Windows)
 340 --
 341 -- 2. If package.conf exists in proto_top_dir, we are running
 342 --      installed; and TopDir = proto_top_dir
 343 --
 344 -- 3. Otherwise we are running in-place, so
 345 --      proto_top_dir will be /...stuff.../ghc/compiler
 346 --      Set TopDir to /...stuff..., which is the root of the build tree
 347 --
 348 -- This is very gruesome indeed
 349
 350 getTopDir :: [String]
 351           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 352                  String)        -- TopDir (in Unix format '/' separated)
 353
 354 getTopDir minusbs
 355   = do { top_dir <- get_proto
 356         -- Discover whether we're running in a build tree or in an installation,
 357         -- by looking for the package configuration file.
 358        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 359
 360        ; return (am_installed, top_dir)
 361        }
 362   where
 363     -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
 364     get_proto | not (null minusbs)
 365               = return (unDosifyPath (drop 2 (last minusbs)))   -- 2 for "-B"
 366               | otherwise
 367               = do { maybe_exec_dir <- getExecDir -- Get directory of executable
 368                    ; case maybe_exec_dir of       -- (only works on Windows;
 369                                                   --  returns Nothing on Unix)
 370                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 371                         Just dir -> return dir
 372                    }
 373 \end{code}
 374
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsection{Running an external program}
 379 n%*                                                                     *
 380 %************************************************************************
 381
 382
 383 \begin{code}
 384 runUnlit :: [String] -> IO ()
 385 runUnlit args = do p <- readIORef v_Pgm_L
 386                    runSomething "Literate pre-processor" p args
 387
 388 runCpp :: [String] -> IO ()
 389 runCpp args =   do p <- readIORef v_Pgm_P
 390                    runSomething "C pre-processor" p args
 391
 392 runCc :: [String] -> IO ()
 393 runCc args =   do p <- readIORef v_Pgm_c
 394                   runSomething "C Compiler" p args
 395
 396 runMangle :: [String] -> IO ()
 397 runMangle args = do p <- readIORef v_Pgm_m
 398                     runSomething "Mangler" p args
 399
 400 runSplit :: [String] -> IO ()
 401 runSplit args = do p <- readIORef v_Pgm_s
 402                    runSomething "Splitter" p args
 403
 404 runAs :: [String] -> IO ()
 405 runAs args = do p <- readIORef v_Pgm_a
 406                 runSomething "Assembler" p args
 407
 408 runLink :: [String] -> IO ()
 409 runLink args = do p <- readIORef v_Pgm_l
 410                   runSomething "Linker" p args
 411
 412 runMkDLL :: [String] -> IO ()
 413 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 414                    runSomething "Make DLL" p args
 415
 416 touch :: String -> String -> IO ()
 417 touch purpose arg =  do p <- readIORef v_Pgm_T
 418                         runSomething purpose p [arg]
 419
 420 copy :: String -> String -> String -> IO ()
 421 copy purpose from to = do
 422   verb <- dynFlag verbosity
 423   when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 424
 425   h <- openFile to WriteMode
 426   ls <- readFile from -- inefficient, but it'll do for now.
 427                       -- ToDo: speed up via slurping.
 428   hPutStr h ls
 429   hClose h
 430 \end{code}
 431
 432 \begin{code}
 433 getSysMan :: IO String  -- How to invoke the system manager
 434                         -- (parallel system only)
 435 getSysMan = readIORef v_Pgm_sysman
 436 \end{code}
 437
 438 %************************************************************************
 439 %*                                                                      *
 440 \subsection{GHC Usage message}
 441 %*                                                                      *
 442 %************************************************************************
 443
 444 Show the usage message and exit
 445
 446 \begin{code}
 447 showGhcUsage = do { usage_path <- readIORef v_Path_usage
 448                   ; usage      <- readFile usage_path
 449                   ; dump usage
 450                   ; exitWith ExitSuccess }
 451   where
 452      dump ""          = return ()
 453      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 454      dump (c:s)       = hPutChar stderr c >> dump s
 455
 456 packageConfigPath = readIORef v_Path_package_config
 457 \end{code}
 458
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsection{Managing temporary files
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 \begin{code}
 467 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 468 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 469         -- v_TmpDir has no closing '/'
 470 \end{code}
 471
 472 \begin{code}
 473 setTmpDir dir = writeIORef v_TmpDir dir
 474
 475 cleanTempFiles :: Int -> IO ()
 476 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
 477                          removeTmpFiles verb fs
 478
 479 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 480 cleanTempFilesExcept verb dont_delete
 481   = do fs <- readIORef v_FilesToClean
 482        let leftovers = filter (`notElem` dont_delete) fs
 483        removeTmpFiles verb leftovers
 484        writeIORef v_FilesToClean dont_delete
 485
 486
 487 -- find a temporary name that doesn't already exist.
 488 newTempName :: Suffix -> IO FilePath
 489 newTempName extn
 490   = do x <- getProcessID
 491        tmp_dir <- readIORef v_TmpDir
 492        findTempName tmp_dir x
 493   where
 494     findTempName tmp_dir x
 495       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 496            b  <- doesFileExist filename
 497            if b then findTempName tmp_dir (x+1)
 498                 else do add v_FilesToClean filename -- clean it up later
 499                         return filename
 500
 501 addFilesToClean :: [FilePath] -> IO ()
 502 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 503 addFilesToClean files = mapM_ (add v_FilesToClean) files
 504
 505 removeTmpFiles :: Int -> [FilePath] -> IO ()
 506 removeTmpFiles verb fs
 507   = traceCmd "Deleting temp files"
 508              ("Deleting: " ++ unwords fs)
 509              (mapM_ rm fs)
 510   where
 511     rm f = removeFile f `catchAllIO`
 512                 (\_ignored ->
 513                     when (verb >= 2) $
 514                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 515                 )
 516
 517 \end{code}
 518
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsection{Running a program}
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 \begin{code}
 527 GLOBAL_VAR(v_Dry_run, False, Bool)
 528
 529 setDryRun :: IO ()
 530 setDryRun = writeIORef v_Dry_run True
 531
 532 -----------------------------------------------------------------------------
 533 -- Running an external program
 534
 535 runSomething :: String          -- For -v message
 536              -> String          -- Command name (possibly a full path)
 537                                 --      assumed already dos-ified
 538              -> [String]        -- Arguments
 539                                 --      runSomething will dos-ify them
 540              -> IO ()
 541
 542 runSomething phase_name pgm args
 543  = traceCmd phase_name cmd_line $
 544    do   { exit_code <- system cmd_line
 545         ; if exit_code /= ExitSuccess
 546           then throwDyn (PhaseFailed phase_name exit_code)
 547           else return ()
 548         }
 549   where
 550     cmd_line = unwords (pgm : dosifyPaths (map quote args))
 551         -- The pgm is already in native format (appropriate dir separators)
 552     quote "" = ""
 553     quote s  = "\"" ++ s ++ "\""
 554
 555 traceCmd :: String -> String -> IO () -> IO ()
 556 -- a) trace the command (at two levels of verbosity)
 557 -- b) don't do it at all if dry-run is set
 558 traceCmd phase_name cmd_line action
 559  = do   { verb <- dynFlag verbosity
 560         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 561         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 562         ; hFlush stderr
 563
 564            -- Test for -n flag
 565         ; n <- readIORef v_Dry_run
 566         ; unless n $ do {
 567
 568            -- And run it!
 569         ; action `catchAllIO` handle_exn verb
 570         }}
 571   where
 572     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 573                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
 574                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 575 \end{code}
 576
 577
 578 %************************************************************************
 579 %*                                                                      *
 580 \subsection{Path names}
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 We maintain path names in Unix form ('/'-separated) right until
 585 the last moment.  On Windows we dos-ify them just before passing them
 586 to the Windows command.
 587
 588 The alternative, of using '/' consistently on Unix and '\' on Windows,
 589 proved quite awkward.  There were a lot more calls to dosifyPath,
 590 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 591 interpreted a command line 'foo\baz' as 'foobaz'.
 592
 593 \begin{code}
 594 -----------------------------------------------------------------------------
 595 -- Convert filepath into MSDOS form.
 596
 597 dosifyPaths :: [String] -> [String]
 598 -- dosifyPaths does two things
 599 -- a) change '/' to '\'
 600 -- b) remove initial '/cygdrive/'
 601
 602 unDosifyPath :: String -> String
 603 -- Just change '\' to '/'
 604
 605 pgmPath :: String               -- Directory string in Unix format
 606         -> String               -- Program name with no directory separators
 607                                 --      (e.g. copy /y)
 608         -> String               -- Program invocation string in native format
 609
 610
 611
 612 #if defined(mingw32_TARGET_OS)
 613
 614 --------------------- Windows version ------------------
 615 dosifyPaths xs = map dosifyPath xs
 616
 617 unDosifyPath xs = subst '\\' '/' xs
 618
 619 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
 620
 621 dosifyPath stuff
 622   = subst '/' '\\' real_stuff
 623  where
 624    -- fully convince myself that /cygdrive/ prefixes cannot
 625    -- really appear here.
 626   cygdrive_prefix = "/cygdrive/"
 627
 628   real_stuff
 629     | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 630     | otherwise = stuff
 631
 632 #else
 633
 634 --------------------- Unix version ---------------------
 635 dosifyPaths  ps = ps
 636 unDosifyPath xs = xs
 637 pgmPath dir pgm = dir ++ '/' : pgm
 638 --------------------------------------------------------
 639 #endif
 640
 641 subst a b ls = map (\ x -> if x == a then b else x) ls
 642 \end{code}
 643
 644
 645 -----------------------------------------------------------------------------
 646    Path name construction
 647
 648 \begin{code}
 649 slash            :: String -> String -> String
 650 absPath, relPath :: [String] -> String
 651
 652 isSlash '/'   = True
 653 isSlash other = False
 654
 655 relPath [] = ""
 656 relPath xs = foldr1 slash xs
 657
 658 absPath xs = "" `slash` relPath xs
 659
 660 slash s1 s2 = s1 ++ ('/' : s2)
 661 \end{code}
 662
 663
 664 %************************************************************************
 665 %*                                                                      *
 666 \subsection{Support code}
 667 %*                                                                      *
 668 %************************************************************************
 669
 670 \begin{code}
 671 -----------------------------------------------------------------------------
 672 -- Define       getExecDir     :: IO (Maybe String)
 673
 674 #if defined(mingw32_TARGET_OS)
 675 getExecDir :: IO (Maybe String)
 676 getExecDir = do h <- getModuleHandle Nothing
 677                 n <- getModuleFileName h
 678                 return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath n)))))
 679 #else
 680 getExecDir :: IO (Maybe String) = do return Nothing
 681 #endif
 682
 683 #ifdef mingw32_TARGET_OS
 684 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 685 #else
 686 getProcessID :: IO Int
 687 getProcessID = Posix.getProcessID
 688 #endif
 689 \end{code}