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