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 List             ( intersperse, isPrefixOf )
  53 import Exception        ( throw, throwDyn, catchAllIO )
  54 import IO               ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr )
  55 import IO               ( openFile, IOMode(..), hClose )        -- For temp "system"
  56 import Directory        ( doesFileExist, removeFile )
  57 import IOExts           ( IORef, readIORef, writeIORef )
  58 import Monad            ( when, unless )
  59 import qualified System
  60 import System           ( ExitCode(..) )
  61
  62 #include "../includes/config.h"
  63
  64 #if !defined(mingw32_TARGET_OS)
  65 import qualified Posix
  66 #else
  67 import Addr              ( nullAddr )
  68 #endif
  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 %*                                                                      *
 117 \subsection{Global variables to contain system programs}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 All these pathnames are maintained in Unix format.
 122 (See remarks under pathnames below)
 123
 124 \begin{code}
 125 GLOBAL_VAR(v_Pgm_L,     error "pgm_L",   String)        -- unlit
 126 GLOBAL_VAR(v_Pgm_P,     error "pgm_P",   String)        -- cpp
 127 GLOBAL_VAR(v_Pgm_c,     error "pgm_c",   String)        -- gcc
 128 GLOBAL_VAR(v_Pgm_m,     error "pgm_m",   String)        -- asm code mangler
 129 GLOBAL_VAR(v_Pgm_s,     error "pgm_s",   String)        -- asm code splitter
 130 GLOBAL_VAR(v_Pgm_a,     error "pgm_a",   String)        -- as
 131 GLOBAL_VAR(v_Pgm_l,     error "pgm_l",   String)        -- ld
 132 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)        -- mkdll
 133
 134 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 135 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 136
 137 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 138 GLOBAL_VAR(v_Path_usage,          error "ghc_usage.txt",       String)
 139
 140 -- Parallel system only
 141 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 142 \end{code}
 143
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \subsection{Initialisation}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 \begin{code}
 152 initSysTools :: [String]        -- Command-line arguments starting "-B"
 153
 154              -> IO String       -- Set all the mutable variables above, holding
 155                                 --      (a) the system programs
 156                                 --      (b) the package-config file
 157                                 --      (c) the GHC usage message
 158                                 -- Return TopDir
 159
 160
 161 initSysTools minusB_args
 162   = do  { (am_installed, top_dir) <- getTopDir minusB_args
 163                 -- top_dir
 164                 --      for "installed" this is the root of GHC's support files
 165                 --      for "in-place" it is the root of the build tree
 166
 167         ; let installed_bin pgm   =  top_dir `slash` "bin" `slash` pgm
 168               installed     file  =  top_dir `slash` file
 169               inplace dir   pgm   =  top_dir `slash` dir `slash` pgm
 170
 171         ; let pkgconfig_path
 172                 | am_installed = installed "package.conf"
 173                 | otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"
 174
 175               ghc_usage_msg_path
 176                 | am_installed = installed "ghc-usage.txt"
 177                 | otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
 178
 179                 -- For all systems, unlit, split, mangle are GHC utilities
 180                 -- architecture-specific stuff is done when building Config.hs
 181               unlit_path
 182                 | am_installed = installed_bin cGHC_UNLIT
 183                 | otherwise    = inplace cGHC_UNLIT_DIR cGHC_UNLIT
 184
 185                 -- split and mangle are Perl scripts
 186               split_script
 187                 | am_installed = installed_bin cGHC_SPLIT
 188                 | otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
 189
 190               mangle_script
 191                 | am_installed = installed_bin cGHC_MANGLER
 192                 | otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER
 193
 194         -- Check that the package config exists
 195         ; config_exists <- doesFileExist pkgconfig_path
 196         ; when (not config_exists) $
 197              throwDyn (InstallationError
 198                          ("Can't find package.conf in " ++ pkgconfig_path))
 199
 200 #if defined(mingw32_TARGET_OS)
 201         --              WINDOWS-SPECIFIC STUFF
 202         -- On Windows, gcc and friends are distributed with GHC,
 203         --      so when "installed" we look in TopDir/bin
 204         -- When "in-place" we look wherever the build-time configure
 205         --      script found them
 206         ; let cpp_path  | am_installed = installed cRAWCPP
 207                         | otherwise    = cRAWCPP
 208               gcc_path  | am_installed = installed cGCC
 209                         | otherwise    = cGCC
 210               perl_path | am_installed = installed cGHC_PERL
 211                         | otherwise    = cGHC_PERL
 212
 213         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 214         ; let touch_path  | am_installed = installed cGHC_TOUCHY
 215                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 216
 217         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 218         -- a call to Perl to get the invocation of split and mangle
 219         ; let split_path  = perl_path ++ " " ++ split_script
 220               mangle_path = perl_path ++ " " ++ mangle_script
 221
 222         ; let mkdll_path = cMKDLL
 223 #else
 224         --              UNIX-SPECIFIC STUFF
 225         -- On Unix, the "standard" tools are assumed to be
 226         -- in the same place whether we are running "in-place" or "installed"
 227         -- That place is wherever the build-time configure script found them.
 228         ; let   cpp_path   = cRAWCPP
 229                 gcc_path   = cGCC
 230                 touch_path = cGHC_TOUCHY
 231                 mkdll_path = panic "Cant build DLLs on a non-Win32 system"
 232
 233         -- On Unix, scripts are invoked using the '#!' method.  Binary
 234         -- installations of GHC on Unix place the correct line on the front
 235         -- of the script at installation time, so we don't want to wire-in
 236         -- our knowledge of $(PERL) on the host system here.
 237         ; let split_path  = split_script
 238               mangle_path = mangle_script
 239
 240 #endif
 241
 242         -- For all systems, copy and remove are provided by the host
 243         -- system; architecture-specific stuff is done when building Config.hs
 244         ; let   cp_path = cGHC_CP
 245
 246         -- Other things being equal, as and ld are simply gcc
 247         ; let   as_path  = gcc_path
 248                 ld_path  = gcc_path
 249
 250
 251         -- Initialise the global vars
 252         ; writeIORef v_Path_package_config pkgconfig_path
 253         ; writeIORef v_Path_usage          ghc_usage_msg_path
 254
 255         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 256                 -- Hans: this isn't right in general, but you can
 257                 -- elaborate it in the same way as the others
 258
 259         ; writeIORef v_Pgm_L               unlit_path
 260         ; writeIORef v_Pgm_P               cpp_path
 261         ; writeIORef v_Pgm_c               gcc_path
 262         ; writeIORef v_Pgm_m               mangle_path
 263         ; writeIORef v_Pgm_s               split_path
 264         ; writeIORef v_Pgm_a               as_path
 265         ; writeIORef v_Pgm_l               ld_path
 266         ; writeIORef v_Pgm_MkDLL           mkdll_path
 267         ; writeIORef v_Pgm_T               touch_path
 268         ; writeIORef v_Pgm_CP              cp_path
 269
 270         ; return top_dir
 271         }
 272 \end{code}
 273
 274 setPgm is called when a command-line option like
 275         -pgmLld
 276 is used to override a particular program with a new onw
 277
 278 \begin{code}
 279 setPgm :: String -> IO ()
 280 -- The string is the flag, minus the '-pgm' prefix
 281 -- So the first character says which program to override
 282
 283 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 284 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 285 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 286 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 287 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 288 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 289 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 290 \end{code}
 291
 292
 293 \begin{code}
 294 -- Find TopDir
 295 --      for "installed" this is the root of GHC's support files
 296 --      for "in-place" it is the root of the build tree
 297 --
 298 -- Plan of action:
 299 -- 1. Set proto_top_dir
 300 --      a) look for (the last) -B flag, and use it
 301 --      b) if there are no -B flags, get the directory
 302 --         where GHC is running
 303 --
 304 -- 2. If package.conf exists in proto_top_dir, we are running
 305 --      installed; and TopDir = proto_top_dir
 306 --
 307 -- 3. Otherwise we are running in-place, so
 308 --      proto_top_dir will be /...stuff.../ghc/compiler
 309 --      Set TopDir to /...stuff..., which is the root of the build tree
 310 --
 311 -- This is very gruesome indeed
 312
 313 getTopDir :: [String]
 314           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 315                  String)        -- TopDir
 316
 317 getTopDir minusbs
 318   = do { top_dir1 <- get_proto
 319        ; let top_dir2 = unDosifyPath top_dir1   -- Convert to standard internal form
 320
 321         -- Discover whether we're running in a build tree or in an installation,
 322         -- by looking for the package configuration file.
 323        ; am_installed <- doesFileExist (top_dir2 `slash` "package.conf")
 324
 325        ; if am_installed then
 326             return (True, top_dir2)
 327          else
 328             return (False, remove_suffix top_dir2)
 329        }
 330   where
 331     get_proto | not (null minusbs)
 332               = return (drop 2 (last minusbs))  -- 2 for "-B"
 333               | otherwise
 334               = do { maybe_exec_dir <- getExecDir -- Get directory of executable
 335                    ; case maybe_exec_dir of       -- (only works on Windows;
 336                                                   --  returns Nothing on Unix)
 337                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 338                         Just dir -> return dir
 339                    }
 340
 341     remove_suffix dir   -- "/...stuff.../ghc/compiler" --> "/...stuff..."
 342         = ASSERT2( not (null p1) &&
 343                    not (null p2) &&
 344                    dir == top_dir ++ "/ghc/compiler",
 345                    text dir )
 346           top_dir
 347         where
 348          p1      = dropWhile (not . isSlash) (reverse dir)
 349          p2      = dropWhile (not . isSlash) (tail p1)  -- head is '/'
 350          top_dir = reverse (tail p2)                    -- head is '/'
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection{Running an external program}
 357 n%*                                                                     *
 358 %************************************************************************
 359
 360
 361 \begin{code}
 362 runUnlit :: [String] -> IO ()
 363 runUnlit args = do p <- readIORef v_Pgm_L
 364                    runSomething "Literate pre-processor" p args
 365
 366 runCpp :: [String] -> IO ()
 367 runCpp args =   do p <- readIORef v_Pgm_P
 368                    runSomething "C pre-processor" p args
 369
 370 runCc :: [String] -> IO ()
 371 runCc args =   do p <- readIORef v_Pgm_c
 372                   runSomething "C Compiler" p args
 373
 374 runMangle :: [String] -> IO ()
 375 runMangle args = do p <- readIORef v_Pgm_m
 376                     runSomething "Mangler" p args
 377
 378 runSplit :: [String] -> IO ()
 379 runSplit args = do p <- readIORef v_Pgm_s
 380                    runSomething "Splitter" p args
 381
 382 runAs :: [String] -> IO ()
 383 runAs args = do p <- readIORef v_Pgm_a
 384                 runSomething "Assembler" p args
 385
 386 runLink :: [String] -> IO ()
 387 runLink args = do p <- readIORef v_Pgm_l
 388                   runSomething "Linker" p args
 389
 390 runMkDLL :: [String] -> IO ()
 391 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 392                    runSomething "Make DLL" p args
 393
 394 touch :: String -> String -> IO ()
 395 touch purpose arg =  do p <- readIORef v_Pgm_T
 396                         runSomething purpose p [arg]
 397
 398 copy :: String -> String -> String -> IO ()
 399 copy purpose from to = do p <- readIORef v_Pgm_CP
 400                           runSomething purpose p [from,to]
 401 \end{code}
 402
 403 \begin{code}
 404 getSysMan :: IO String  -- How to invoke the system manager
 405                         -- (parallel system only)
 406 getSysMan = readIORef v_Pgm_sysman
 407 \end{code}
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection{GHC Usage message}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 Show the usage message and exit
 416
 417 \begin{code}
 418 showGhcUsage = do { usage_path <- readIORef v_Path_usage
 419                   ; usage      <- readFile usage_path
 420                   ; dump usage
 421                   ; System.exitWith System.ExitSuccess }
 422   where
 423      dump ""          = return ()
 424      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 425      dump (c:s)       = hPutChar stderr c >> dump s
 426
 427 packageConfigPath = readIORef v_Path_package_config
 428 \end{code}
 429
 430
 431 %************************************************************************
 432 %*                                                                      *
 433 \subsection{Managing temporary files
 434 %*                                                                      *
 435 %************************************************************************
 436
 437 One reason this code is here is because SysTools.system needs to make
 438 a temporary file.
 439
 440 \begin{code}
 441 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 442 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 443         -- v_TmpDir has no closing '/'
 444 \end{code}
 445
 446 \begin{code}
 447 setTmpDir dir = writeIORef v_TmpDir dir
 448
 449 cleanTempFiles :: Int -> IO ()
 450 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
 451                          removeTmpFiles verb fs
 452
 453 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 454 cleanTempFilesExcept verb dont_delete
 455   = do fs <- readIORef v_FilesToClean
 456        let leftovers = filter (`notElem` dont_delete) fs
 457        removeTmpFiles verb leftovers
 458        writeIORef v_FilesToClean dont_delete
 459
 460
 461 -- find a temporary name that doesn't already exist.
 462 newTempName :: Suffix -> IO FilePath
 463 newTempName extn
 464   = do x <- getProcessID
 465        tmp_dir <- readIORef v_TmpDir
 466        findTempName tmp_dir x
 467   where
 468     findTempName tmp_dir x
 469       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 470            b  <- doesFileExist filename
 471            if b then findTempName tmp_dir (x+1)
 472                 else do add v_FilesToClean filename -- clean it up later
 473                         return filename
 474
 475 addFilesToClean :: [FilePath] -> IO ()
 476 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 477 addFilesToClean files = mapM_ (add v_FilesToClean) files
 478
 479 removeTmpFiles :: Int -> [FilePath] -> IO ()
 480 removeTmpFiles verb fs
 481   = traceCmd "Deleting temp files"
 482              ("Deleting: " ++ concat (intersperse " " fs))
 483              (mapM_ rm fs)
 484   where
 485     rm f = removeFile f `catchAllIO`
 486                 (\exn -> hPutStrLn stderr ("Warning: deleting non-existent " ++ f) >>
 487                          return ())
 488
 489 \end{code}
 490
 491
 492 %************************************************************************
 493 %*                                                                      *
 494 \subsection{Running a program}
 495 %*                                                                      *
 496 %************************************************************************
 497
 498 \begin{code}
 499 GLOBAL_VAR(v_Dry_run, False, Bool)
 500
 501 setDryRun :: IO ()
 502 setDryRun = writeIORef v_Dry_run True
 503
 504 -----------------------------------------------------------------------------
 505 -- Running an external program
 506
 507 runSomething :: String          -- For -v message
 508              -> String          -- Command name (possibly a full path)
 509                                 --      assumed already dos-ified
 510              -> [String]        -- Arguments
 511                                 --      runSomthing will dos-ify them
 512              -> IO ()
 513
 514 runSomething phase_name pgm args
 515  = traceCmd phase_name cmd_line $
 516    do   { exit_code <- system cmd_line
 517         ; if exit_code /= ExitSuccess
 518           then throwDyn (PhaseFailed phase_name exit_code)
 519           else return ()
 520         }
 521   where
 522 -- Don't convert paths to DOS format when using the kludged
 523 -- version of 'system' on mingw32.  See comments with 'system' below.
 524 #if __GLASGOW_HASKELL__ > 501
 525     cmd_line = unwords (dosifyPaths (pgm : args))
 526 #else
 527     cmd_line = unwords (pgm : args)
 528 #endif
 529
 530 traceCmd :: String -> String -> IO () -> IO ()
 531 -- a) trace the command (at two levels of verbosity)
 532 -- b) don't do it at all if dry-run is set
 533 traceCmd phase_name cmd_line action
 534  = do   { verb <- dynFlag verbosity
 535         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 536         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 537         ; hFlush stderr
 538
 539            -- Test for -n flag
 540         ; n <- readIORef v_Dry_run
 541         ; unless n $ do {
 542
 543            -- And run it!
 544         ; action `catchAllIO` handle_exn verb
 545         }}
 546   where
 547     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 548                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
 549                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 550 \end{code}
 551
 552
 553 %************************************************************************
 554 %*                                                                      *
 555 \subsection{Path names}
 556 %*                                                                      *
 557 %************************************************************************
 558
 559 We maintain path names in Unix form ('/'-separated) right until
 560 the last moment.  On Windows we dos-ify them just before passing them
 561 to the Windows command.
 562
 563 The alternative, of using '/' consistently on Unix and '\' on Windows,
 564 proved quite awkward.  There were a lot more calls to dosifyPath,
 565 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 566 interpreted a command line 'foo\baz' as 'foobaz'.
 567
 568 \begin{code}
 569 -----------------------------------------------------------------------------
 570 -- Convert filepath into MSDOS form.
 571
 572 dosifyPath  :: String -> String
 573 dosifyPaths :: [String] -> [String]
 574 -- dosifyPath does two things
 575 -- a) change '/' to '\'
 576 -- b) remove initial '/cygdrive/'
 577
 578 unDosifyPath :: String -> String
 579 -- Just change '\' to '/'
 580
 581 #if defined(mingw32_TARGET_OS)
 582
 583 --------------------- Windows version ------------------
 584 unDosifyPath xs = xs
 585
 586 dosifyPaths xs = map dosifyPath xs
 587
 588 dosifyPath stuff
 589   = subst '/' '\\' real_stuff
 590  where
 591    -- fully convince myself that /cygdrive/ prefixes cannot
 592    -- really appear here.
 593   cygdrive_prefix = "/cygdrive/"
 594
 595   real_stuff
 596     | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 597     | otherwise = stuff
 598
 599 #else
 600
 601 --------------------- Unix version ---------------------
 602 dosifyPaths  xs = xs
 603 dosifyPaths  xs = xs
 604 unDosifyPath xs = subst '\\' '/' xs
 605 --------------------------------------------------------
 606 #endif
 607
 608 subst a b ls = map (\ x -> if x == a then b else x) ls
 609 \end{code}
 610
 611
 612 -----------------------------------------------------------------------------
 613    Path name construction
 614
 615 \begin{code}
 616 slash            :: String -> String -> String
 617 absPath, relPath :: [String] -> String
 618
 619 isSlash '/'   = True
 620 isSlash other = False
 621
 622 relPath [] = ""
 623 relPath xs = foldr1 slash xs
 624
 625 absPath xs = "" `slash` relPath xs
 626
 627 slash s1 s2 = s1 ++ ('/' : s2)
 628 \end{code}
 629
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsection{Support code}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 \begin{code}
 638 -----------------------------------------------------------------------------
 639 -- Define       myGetProcessId :: IO Int
 640 --              getExecDir     :: IO (Maybe String)
 641
 642 #ifdef mingw32_TARGET_OS
 643 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 644
 645 getExecDir :: IO (Maybe String)
 646 getExecDir = return Nothing
 647 {-
 648 foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> CString -> IO Int32
 649 getExecDir = do len <- getCurrentDirectory 0 nullAddr
 650                 buf <- mallocArray (fromIntegral len)
 651                 ret <- getCurrentDirectory len buf
 652                 if ret == 0 then return Nothing
 653                             else do s <- peekCString buf
 654                                     destructArray (fromIntegral len) buf
 655                                     return (Just s)
 656 -}
 657 #else
 658 getProcessID :: IO Int
 659 getProcessID = Posix.getProcessID
 660 getExecDir :: IO (Maybe String) = do return Nothing
 661 #endif
 662 \end{code}
 663
 664 %************************************************************************
 665 %*                                                                      *
 666 \subsection{System}
 667 %*                                                                      *
 668 %************************************************************************
 669
 670 In GHC prior to 5.01 (or so), on Windows, the implementation
 671 of "system" in the library System.system does not work for very
 672 long command lines.  But GHC may need to make a system call with
 673 a very long command line, notably when it links itself during
 674 bootstrapping.
 675
 676 Solution: when compiling SysTools for Windows, using GHC prior
 677 to 5.01, write the command to a file and use "sh" (not cmd.exe)
 678 to execute it.  Such GHCs require "sh" on the path, but once
 679 bootstrapped this problem goes away.
 680
 681 ToDo: remove when compiling with GHC < 5 is not relevant any more
 682
 683 \begin{code}
 684 system cmd
 685
 686 #if !defined(mingw32_TARGET_OS) || __GLASGOW_HASKELL__ > 501
 687     -- The usual case
 688  = System.system cmd
 689
 690 #else   -- The Hackoid case
 691  = do pid     <- getProcessID
 692       tmp_dir <- readIORef v_TmpDir
 693       let tmp = tmp_dir++"/sh"++show pid
 694       h <- openFile tmp WriteMode
 695       hPutStrLn h cmd
 696       hClose h
 697       exit_code <- System.system ("sh - " ++ tmp) `catchAllIO`
 698                                  (\exn -> removeFile tmp >> throw exn)
 699       removeFile tmp
 700       return exit_code
 701 #endif
 702 \end{code}