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
  28         -- Temporary-file management
  29         setTmpDir,
  30         newTempName,
  31         cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
  32         addFilesToClean,
  33
  34         -- System interface
  35         getProcessID,           -- IO Int
  36         system,                 -- String -> IO Int
  37
  38         -- Misc
  39         showGhcUsage,           -- IO ()        Shows usage message and exits
  40         getSysMan,              -- IO String    Parallel system only
  41
  42         runSomething    -- ToDo: make private
  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
  59 #include "../includes/config.h"
  60
  61 #if !defined(mingw32_TARGET_OS)
  62 import qualified Posix
  63 #else
  64 import Win32Registry
  65 import List             ( isPrefixOf )
  66 #endif
  67
  68 import List             ( isSuffixOf )
  69
  70 #include "HsVersions.h"
  71
  72 {-# DEPRECATED runSomething "runSomething should be private to SysTools" #-}
  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         -- Check that the package config exists
 221         ; config_exists <- doesFileExist pkgconfig_path
 222         ; when (not config_exists) $
 223              throwDyn (InstallationError
 224                          ("Can't find package.conf as " ++ pkgconfig_path))
 225
 226 #if defined(mingw32_TARGET_OS)
 227         --              WINDOWS-SPECIFIC STUFF
 228         -- On Windows, gcc and friends are distributed with GHC,
 229         --      so when "installed" we look in TopDir/bin
 230         -- When "in-place" we look wherever the build-time configure
 231         --      script found them
 232         -- When "install" we tell gcc where its specs file + exes are (-B)
 233         --      and also some places to pick up include files.  We need
 234         --      to be careful to put all necessary exes in the -B place
 235         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 236         --      then tries to run unadorned "as", "ld", etc, and will
 237         --      pick up whatever happens to be lying around in the path,
 238         --      possibly including those from a cygwin install on the target,
 239         --      which is exactly what we're trying to avoid.
 240         ; let gcc_path  | am_installed = installed_bin ("gcc -B" ++ installed "gcc-lib/"
 241                                          ++ " -I" ++ installed "include/mingw")
 242                         | otherwise    = cGCC
 243               perl_path | am_installed = installed_bin cGHC_PERL
 244                         | otherwise    = cGHC_PERL
 245
 246         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 247         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
 248                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 249
 250         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 251         -- a call to Perl to get the invocation of split and mangle
 252         ; let split_path  = perl_path ++ " " ++ split_script
 253               mangle_path = perl_path ++ " " ++ mangle_script
 254
 255         ; let mkdll_path = cMKDLL
 256 #else
 257         --              UNIX-SPECIFIC STUFF
 258         -- On Unix, the "standard" tools are assumed to be
 259         -- in the same place whether we are running "in-place" or "installed"
 260         -- That place is wherever the build-time configure script found them.
 261         ; let   gcc_path   = cGCC
 262                 touch_path = cGHC_TOUCHY
 263                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 264
 265         -- On Unix, scripts are invoked using the '#!' method.  Binary
 266         -- installations of GHC on Unix place the correct line on the front
 267         -- of the script at installation time, so we don't want to wire-in
 268         -- our knowledge of $(PERL) on the host system here.
 269         ; let split_path  = split_script
 270               mangle_path = mangle_script
 271 #endif
 272
 273         -- cpp is derived from gcc on all platforms
 274         ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
 275
 276         -- For all systems, copy and remove are provided by the host
 277         -- system; architecture-specific stuff is done when building Config.hs
 278         ; let   cp_path = cGHC_CP
 279
 280         -- Other things being equal, as and ld are simply gcc
 281         ; let   as_path  = gcc_path
 282                 ld_path  = gcc_path
 283
 284
 285         -- Initialise the global vars
 286         ; writeIORef v_Path_package_config pkgconfig_path
 287         ; writeIORef v_Path_usage          ghc_usage_msg_path
 288
 289         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 290                 -- Hans: this isn't right in general, but you can
 291                 -- elaborate it in the same way as the others
 292
 293         ; writeIORef v_Pgm_L               unlit_path
 294         ; writeIORef v_Pgm_P               cpp_path
 295         ; writeIORef v_Pgm_c               gcc_path
 296         ; writeIORef v_Pgm_m               mangle_path
 297         ; writeIORef v_Pgm_s               split_path
 298         ; writeIORef v_Pgm_a               as_path
 299         ; writeIORef v_Pgm_l               ld_path
 300         ; writeIORef v_Pgm_MkDLL           mkdll_path
 301         ; writeIORef v_Pgm_T               touch_path
 302         ; writeIORef v_Pgm_CP              cp_path
 303
 304         ; return top_dir
 305         }
 306 \end{code}
 307
 308 setPgm is called when a command-line option like
 309         -pgmLld
 310 is used to override a particular program with a new onw
 311
 312 \begin{code}
 313 setPgm :: String -> IO ()
 314 -- The string is the flag, minus the '-pgm' prefix
 315 -- So the first character says which program to override
 316
 317 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 318 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 319 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 320 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 321 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 322 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 323 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 324 \end{code}
 325
 326
 327 \begin{code}
 328 -- Find TopDir
 329 --      for "installed" this is the root of GHC's support files
 330 --      for "in-place" it is the root of the build tree
 331 --
 332 -- Plan of action:
 333 -- 1. Set proto_top_dir
 334 --      a) look for (the last) -B flag, and use it
 335 --      b) if there are no -B flags, get the directory
 336 --         where GHC is running (only on Windows)
 337 --
 338 -- 2. If package.conf exists in proto_top_dir, we are running
 339 --      installed; and TopDir = proto_top_dir
 340 --
 341 -- 3. Otherwise we are running in-place, so
 342 --      proto_top_dir will be /...stuff.../ghc/compiler
 343 --      Set TopDir to /...stuff..., which is the root of the build tree
 344 --
 345 -- This is very gruesome indeed
 346
 347 getTopDir :: [String]
 348           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 349                  String)        -- TopDir (in Unix format '/' separated)
 350
 351 getTopDir minusbs
 352   = do { top_dir <- get_proto
 353         -- Discover whether we're running in a build tree or in an installation,
 354         -- by looking for the package configuration file.
 355        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 356
 357        ; return (am_installed, top_dir)
 358        }
 359   where
 360     -- get_proto returns a Unix-format path
 361     get_proto | not (null minusbs)
 362               = return (unDosifyPath (drop 2 (last minusbs)))   -- 2 for "-B"
 363               | otherwise
 364               = do { maybe_exec_dir <- getExecDir -- Get directory of executable
 365                    ; case maybe_exec_dir of       -- (only works on Windows;
 366                                                   --  returns Nothing on Unix)
 367                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 368                         Just dir -> return (remove_suffix (unDosifyPath dir))
 369                    }
 370
 371     -- In an installed tree, the ghc binary lives in $libexecdir, which
 372     -- is normally $libdir/bin.  So we strip off a /bin suffix here.
 373     -- In a build tree, the ghc binary lives in $fptools/ghc/compiler,
 374     -- so we strip off the /ghc/compiler suffix here too, leaving a
 375     -- standard TOPDIR.
 376     remove_suffix ghc_bin_dir   -- ghc_bin_dir is in standard Unix format
 377         | "/ghc/compiler" `isSuffixOf` ghc_bin_dir      = back_two
 378         | "/bin" `isSuffixOf` ghc_bin_dir               = back_one
 379         | otherwise                                     = ghc_bin_dir
 380         where
 381          p1      = dropWhile (not . isSlash) (reverse ghc_bin_dir)
 382          p2      = dropWhile (not . isSlash) (tail p1)  -- head is '/'
 383          back_two = reverse (tail p2)                   -- head is '/'
 384          back_one = reverse (tail p1)
 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 args)
 563         -- The pgm is already in native format (appropriate dir separators)
 564
 565 traceCmd :: String -> String -> IO () -> IO ()
 566 -- a) trace the command (at two levels of verbosity)
 567 -- b) don't do it at all if dry-run is set
 568 traceCmd phase_name cmd_line action
 569  = do   { verb <- dynFlag verbosity
 570         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 571         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 572         ; hFlush stderr
 573
 574            -- Test for -n flag
 575         ; n <- readIORef v_Dry_run
 576         ; unless n $ do {
 577
 578            -- And run it!
 579         ; action `catchAllIO` handle_exn verb
 580         }}
 581   where
 582     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 583                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
 584                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 585 \end{code}
 586
 587
 588 %************************************************************************
 589 %*                                                                      *
 590 \subsection{Path names}
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 We maintain path names in Unix form ('/'-separated) right until
 595 the last moment.  On Windows we dos-ify them just before passing them
 596 to the Windows command.
 597
 598 The alternative, of using '/' consistently on Unix and '\' on Windows,
 599 proved quite awkward.  There were a lot more calls to dosifyPath,
 600 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 601 interpreted a command line 'foo\baz' as 'foobaz'.
 602
 603 \begin{code}
 604 -----------------------------------------------------------------------------
 605 -- Convert filepath into MSDOS form.
 606
 607 dosifyPaths :: [String] -> [String]
 608 -- dosifyPaths does two things
 609 -- a) change '/' to '\'
 610 -- b) remove initial '/cygdrive/'
 611
 612 unDosifyPath :: String -> String
 613 -- Just change '\' to '/'
 614
 615 pgmPath :: String               -- Directory string in Unix format
 616         -> String               -- Program name with no directory separators
 617                                 --      (e.g. copy /y)
 618         -> String               -- Program invocation string in native format
 619
 620
 621
 622 #if defined(mingw32_TARGET_OS)
 623
 624 --------------------- Windows version ------------------
 625 unDosifyPath xs = xs
 626
 627 dosifyPaths xs = map dosifyPath xs
 628
 629 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
 630
 631 dosifyPath stuff
 632   = subst '/' '\\' real_stuff
 633  where
 634    -- fully convince myself that /cygdrive/ prefixes cannot
 635    -- really appear here.
 636   cygdrive_prefix = "/cygdrive/"
 637
 638   real_stuff
 639     | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 640     | otherwise = stuff
 641
 642 #else
 643
 644 --------------------- Unix version ---------------------
 645 dosifyPaths  ps = ps
 646 unDosifyPath xs = subst '\\' '/' xs
 647 pgmPath dir pgm = dir ++ '/' : pgm
 648 --------------------------------------------------------
 649 #endif
 650
 651 subst a b ls = map (\ x -> if x == a then b else x) ls
 652 \end{code}
 653
 654
 655 -----------------------------------------------------------------------------
 656    Path name construction
 657
 658 \begin{code}
 659 slash            :: String -> String -> String
 660 absPath, relPath :: [String] -> String
 661
 662 isSlash '/'   = True
 663 isSlash other = False
 664
 665 relPath [] = ""
 666 relPath xs = foldr1 slash xs
 667
 668 absPath xs = "" `slash` relPath xs
 669
 670 slash s1 s2 = s1 ++ ('/' : s2)
 671 \end{code}
 672
 673
 674 %************************************************************************
 675 %*                                                                      *
 676 \subsection{Support code}
 677 %*                                                                      *
 678 %************************************************************************
 679
 680 \begin{code}
 681 -----------------------------------------------------------------------------
 682 -- Define       getExecDir     :: IO (Maybe String)
 683
 684 #if defined(mingw32_TARGET_OS)
 685 getExecDir :: IO (Maybe String)
 686 getExecDir = do hKey <- regOpenKey hKEY_LOCAL_MACHINE "SOFTWARE\\University of Glasgow\\Glasgow Haskell Compiler\\ghc-5.01"
 687                 s <- regQueryValue hKey (Just "InstallDir")
 688                 if s == "" then return Nothing else return (Just s)
 689 #else
 690 getExecDir :: IO (Maybe String) = do return Nothing
 691 #endif
 692
 693 #ifdef mingw32_TARGET_OS
 694 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 695 #else
 696 getProcessID :: IO Int
 697 getProcessID = Posix.getProcessID
 698 #endif
 699 \end{code}