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