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