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