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