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