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