ghc/compiler/main/SysTools.lhs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2001-2003
   4 --
   5 -- Access to system tools: gcc, cp, rm etc
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 \begin{code}
  10 module SysTools (
  11         -- Initialisation
  12         initSysTools,
  13
  14         getTopDir,              -- IO String    -- The value of $topdir
  15         getPackageConfigPath,   -- IO String    -- Where package.conf is
  16         getUsageMsgPaths,       -- IO (String,String)
  17
  18         -- Interface to system tools
  19         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  20         runPp,                   -- [Option] -> IO ()
  21         runMangle, runSplit,     -- [Option] -> IO ()
  22         runAs, runLink,          -- [Option] -> IO ()
  23         runMkDLL,
  24
  25         touch,                  -- String -> String -> IO ()
  26         copy,                   -- String -> String -> String -> IO ()
  27         normalisePath,          -- FilePath -> FilePath
  28
  29         -- Temporary-file management
  30         setTmpDir,
  31         newTempName,
  32         cleanTempFiles, cleanTempFilesExcept,
  33         addFilesToClean,
  34
  35         -- System interface
  36         system,                 -- String -> IO ExitCode
  37
  38         -- Misc
  39         getSysMan,              -- IO String    Parallel system only
  40
  41         Option(..)
  42
  43  ) where
  44
  45 #include "HsVersions.h"
  46
  47 import DriverPhases     ( isHaskellUserSrcFilename )
  48 import Config
  49 import Outputable
  50 import Panic            ( GhcException(..) )
  51 import Util             ( Suffix, global, notNull, consIORef,
  52                           normalisePath, pgmPath, platformPath )
  53 import DynFlags         ( DynFlags(..), DynFlag(..), dopt, Option(..),
  54                           setTmpDir, defaultDynFlags )
  55
  56 import EXCEPTION        ( throwDyn )
  57 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  58 import DATA_INT
  59
  60 import Monad            ( when, unless )
  61 import System           ( ExitCode(..), getEnv, system )
  62 import IO               ( try, catch,
  63                           openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
  64                           stderr )
  65 import Directory        ( doesFileExist, removeFile )
  66 import List             ( partition )
  67
  68 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
  69 -- lines on mingw32, so we disallow it now.
  70 #if __GLASGOW_HASKELL__ < 500
  71 #error GHC >= 5.00 is required for bootstrapping GHC
  72 #endif
  73
  74 #ifndef mingw32_HOST_OS
  75 #if __GLASGOW_HASKELL__ > 504
  76 import qualified System.Posix.Internals
  77 #else
  78 import qualified Posix
  79 #endif
  80 #else /* Must be Win32 */
  81 import List             ( isPrefixOf )
  82 import Util             ( dropList )
  83 import Foreign
  84 import CString          ( CString, peekCString )
  85 #endif
  86
  87 #if __GLASGOW_HASKELL__ < 603
  88 -- rawSystem comes from libghccompat.a in stage1
  89 import Compat.RawSystem ( rawSystem )
  90 #else
  91 import System.Cmd       ( rawSystem )
  92 #endif
  93 \end{code}
  94
  95
  96                 The configuration story
  97                 ~~~~~~~~~~~~~~~~~~~~~~~
  98
  99 GHC needs various support files (library packages, RTS etc), plus
 100 various auxiliary programs (cp, gcc, etc).  It finds these in one
 101 of two places:
 102
 103 * When running as an *installed program*, GHC finds most of this support
 104   stuff in the installed library tree.  The path to this tree is passed
 105   to GHC via the -B flag, and given to initSysTools .
 106
 107 * When running *in-place* in a build tree, GHC finds most of this support
 108   stuff in the build tree.  The path to the build tree is, again passed
 109   to GHC via -B.
 110
 111 GHC tells which of the two is the case by seeing whether package.conf
 112 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
 113
 114
 115 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 116 are, and initialises mutable variables to make it easy to call them.
 117 To to this, it makes use of definitions in Config.hs, which is a Haskell
 118 file containing variables whose value is figured out by the build system.
 119
 120 Config.hs contains two sorts of things
 121
 122   cGCC,         The *names* of the programs
 123   cCPP            e.g.  cGCC = gcc
 124   cUNLIT                cCPP = gcc -E
 125   etc           They do *not* include paths
 126
 127
 128   cUNLIT_DIR_REL   The *path* to the directory containing unlit, split etc
 129   cSPLIT_DIR_REL   *relative* to the root of the build tree,
 130                    for use when running *in-place* in a build tree (only)
 131
 132
 133
 134 ---------------------------------------------
 135 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 136
 137 Another hair-brained scheme for simplifying the current tool location
 138 nightmare in GHC: Simon originally suggested using another
 139 configuration file along the lines of GCC's specs file - which is fine
 140 except that it means adding code to read yet another configuration
 141 file.  What I didn't notice is that the current package.conf is
 142 general enough to do this:
 143
 144 Package
 145     {name = "tools",    import_dirs = [],  source_dirs = [],
 146      library_dirs = [], hs_libraries = [], extra_libraries = [],
 147      include_dirs = [], c_includes = [],   package_deps = [],
 148      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
 149      extra_cc_opts = [], extra_ld_opts = []}
 150
 151 Which would have the advantage that we get to collect together in one
 152 place the path-specific package stuff with the path-specific tool
 153 stuff.
 154                 End of NOTES
 155 ---------------------------------------------
 156
 157
 158 %************************************************************************
 159 %*                                                                      *
 160 \subsection{Global variables to contain system programs}
 161 %*                                                                      *
 162 %************************************************************************
 163
 164 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
 165 (See remarks under pathnames below)
 166
 167 \begin{code}
 168 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 169 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 170
 171 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 172 GLOBAL_VAR(v_Path_usages,         error "ghc_usage.txt",       (String,String))
 173
 174 GLOBAL_VAR(v_TopDir,    error "TopDir", String)         -- -B<dir>
 175
 176 -- Parallel system only
 177 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 178
 179 -- ways to get at some of these variables from outside this module
 180 getPackageConfigPath = readIORef v_Path_package_config
 181 getTopDir            = readIORef v_TopDir
 182 \end{code}
 183
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsection{Initialisation}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 \begin{code}
 192 initSysTools :: [String]        -- Command-line arguments starting "-B"
 193
 194              -> DynFlags
 195              -> IO DynFlags     -- Set all the mutable variables above, holding
 196                                 --      (a) the system programs
 197                                 --      (b) the package-config file
 198                                 --      (c) the GHC usage message
 199
 200
 201 initSysTools minusB_args dflags
 202   = do  { (am_installed, top_dir) <- findTopDir minusB_args
 203         ; writeIORef v_TopDir top_dir
 204                 -- top_dir
 205                 --      for "installed" this is the root of GHC's support files
 206                 --      for "in-place" it is the root of the build tree
 207                 -- NB: top_dir is assumed to be in standard Unix format '/' separated
 208
 209         ; let installed, installed_bin :: FilePath -> FilePath
 210               installed_bin pgm   =  pgmPath top_dir pgm
 211               installed     file  =  pgmPath top_dir file
 212               inplace dir   pgm   =  pgmPath (top_dir `slash`
 213                                                 cPROJECT_DIR `slash` dir) pgm
 214
 215         ; let pkgconfig_path
 216                 | am_installed = installed "package.conf"
 217                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
 218
 219               ghc_usage_msg_path
 220                 | am_installed = installed "ghc-usage.txt"
 221                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
 222
 223               ghci_usage_msg_path
 224                 | am_installed = installed "ghci-usage.txt"
 225                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
 226
 227                 -- For all systems, unlit, split, mangle are GHC utilities
 228                 -- architecture-specific stuff is done when building Config.hs
 229               unlit_path
 230                 | am_installed = installed_bin cGHC_UNLIT_PGM
 231                 | otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
 232
 233                 -- split and mangle are Perl scripts
 234               split_script
 235                 | am_installed = installed_bin cGHC_SPLIT_PGM
 236                 | otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
 237
 238               mangle_script
 239                 | am_installed = installed_bin cGHC_MANGLER_PGM
 240                 | otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
 241
 242         ; let dflags0 = defaultDynFlags
 243 #ifndef mingw32_HOST_OS
 244         -- check whether TMPDIR is set in the environment
 245         ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
 246 #else
 247           -- On Win32, consult GetTempPath() for a temp dir.
 248           --  => it first tries TMP, TEMP, then finally the
 249           --   Windows directory(!). The directory is in short-path
 250           --   form.
 251         ; e_tmpdir <-
 252             IO.try (do
 253                 let len = (2048::Int)
 254                 buf  <- mallocArray len
 255                 ret  <- getTempPath len buf
 256                 if ret == 0 then do
 257                       -- failed, consult TMPDIR.
 258                      free buf
 259                      getEnv "TMPDIR"
 260                   else do
 261                      s <- peekCString buf
 262                      free buf
 263                      return s)
 264 #endif
 265         ; let dflags1 = case e_tmpdir of
 266                           Left _  -> dflags0
 267                           Right d -> setTmpDir d dflags0
 268
 269         -- Check that the package config exists
 270         ; config_exists <- doesFileExist pkgconfig_path
 271         ; when (not config_exists) $
 272              throwDyn (InstallationError
 273                          ("Can't find package.conf as " ++ pkgconfig_path))
 274
 275 #if defined(mingw32_HOST_OS)
 276         --              WINDOWS-SPECIFIC STUFF
 277         -- On Windows, gcc and friends are distributed with GHC,
 278         --      so when "installed" we look in TopDir/bin
 279         -- When "in-place" we look wherever the build-time configure
 280         --      script found them
 281         -- When "install" we tell gcc where its specs file + exes are (-B)
 282         --      and also some places to pick up include files.  We need
 283         --      to be careful to put all necessary exes in the -B place
 284         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 285         --      then tries to run unadorned "as", "ld", etc, and will
 286         --      pick up whatever happens to be lying around in the path,
 287         --      possibly including those from a cygwin install on the target,
 288         --      which is exactly what we're trying to avoid.
 289         ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
 290               (gcc_prog,gcc_args)
 291                 | am_installed = (installed_bin "gcc", [gcc_b_arg])
 292                 | otherwise    = (cGCC, [])
 293                 -- The trailing "/" is absolutely essential; gcc seems
 294                 -- to construct file names simply by concatenating to
 295                 -- this -B path with no extra slash We use "/" rather
 296                 -- than "\\" because otherwise "\\\" is mangled
 297                 -- later on; although gcc_args are in NATIVE format,
 298                 -- gcc can cope
 299                 --      (see comments with declarations of global variables)
 300                 --
 301                 -- The quotes round the -B argument are in case TopDir
 302                 -- has spaces in it
 303
 304               perl_path | am_installed = installed_bin cGHC_PERL
 305                         | otherwise    = cGHC_PERL
 306
 307         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 308         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY_PGM
 309                           | otherwise    = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
 310
 311         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 312         -- a call to Perl to get the invocation of split and mangle
 313         ; let (split_prog,  split_args)  = (perl_path, [Option split_script])
 314               (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
 315
 316         ; let (mkdll_prog, mkdll_args)
 317                 | am_installed =
 318                     (pgmPath (installed "gcc-lib/") cMKDLL,
 319                      [ Option "--dlltool-name",
 320                        Option (pgmPath (installed "gcc-lib/") "dlltool"),
 321                        Option "--driver-name",
 322                        Option gcc_prog, gcc_b_arg ])
 323                 | otherwise    = (cMKDLL, [])
 324 #else
 325         --              UNIX-SPECIFIC STUFF
 326         -- On Unix, the "standard" tools are assumed to be
 327         -- in the same place whether we are running "in-place" or "installed"
 328         -- That place is wherever the build-time configure script found them.
 329         ; let   gcc_prog   = cGCC
 330                 gcc_args   = []
 331                 touch_path = "touch"
 332                 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
 333                 mkdll_args = []
 334
 335         -- On Unix, scripts are invoked using the '#!' method.  Binary
 336         -- installations of GHC on Unix place the correct line on the front
 337         -- of the script at installation time, so we don't want to wire-in
 338         -- our knowledge of $(PERL) on the host system here.
 339         ; let (split_prog,  split_args)  = (split_script,  [])
 340               (mangle_prog, mangle_args) = (mangle_script, [])
 341 #endif
 342
 343         -- cpp is derived from gcc on all platforms
 344         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
 345         -- Config.hs one day.
 346         ; let cpp_path  = (gcc_prog, gcc_args ++
 347                            (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 348
 349         -- For all systems, copy and remove are provided by the host
 350         -- system; architecture-specific stuff is done when building Config.hs
 351         ; let   cp_path = cGHC_CP
 352
 353         -- Other things being equal, as and ld are simply gcc
 354         ; let   (as_prog,as_args)  = (gcc_prog,gcc_args)
 355                 (ld_prog,ld_args)  = (gcc_prog,gcc_args)
 356
 357         -- Initialise the global vars
 358         ; writeIORef v_Path_package_config pkgconfig_path
 359         ; writeIORef v_Path_usages         (ghc_usage_msg_path,
 360                                             ghci_usage_msg_path)
 361
 362         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 363                 -- Hans: this isn't right in general, but you can
 364                 -- elaborate it in the same way as the others
 365
 366         ; writeIORef v_Pgm_T               touch_path
 367         ; writeIORef v_Pgm_CP              cp_path
 368
 369         ; return dflags1{
 370                         pgm_L   = unlit_path,
 371                         pgm_P   = cpp_path,
 372                         pgm_F   = "",
 373                         pgm_c   = (gcc_prog,gcc_args),
 374                         pgm_m   = (mangle_prog,mangle_args),
 375                         pgm_s   = (split_prog,split_args),
 376                         pgm_a   = (as_prog,as_args),
 377                         pgm_l   = (ld_prog,ld_args),
 378                         pgm_dll = (mkdll_prog,mkdll_args) }
 379         }
 380
 381 #if defined(mingw32_HOST_OS)
 382 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
 383 #endif
 384 \end{code}
 385
 386 \begin{code}
 387 -- Find TopDir
 388 --      for "installed" this is the root of GHC's support files
 389 --      for "in-place" it is the root of the build tree
 390 --
 391 -- Plan of action:
 392 -- 1. Set proto_top_dir
 393 --      a) look for (the last) -B flag, and use it
 394 --      b) if there are no -B flags, get the directory
 395 --         where GHC is running (only on Windows)
 396 --
 397 -- 2. If package.conf exists in proto_top_dir, we are running
 398 --      installed; and TopDir = proto_top_dir
 399 --
 400 -- 3. Otherwise we are running in-place, so
 401 --      proto_top_dir will be /...stuff.../ghc/compiler
 402 --      Set TopDir to /...stuff..., which is the root of the build tree
 403 --
 404 -- This is very gruesome indeed
 405
 406 findTopDir :: [String]
 407           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 408                  String)        -- TopDir (in Unix format '/' separated)
 409
 410 findTopDir minusbs
 411   = do { top_dir <- get_proto
 412         -- Discover whether we're running in a build tree or in an installation,
 413         -- by looking for the package configuration file.
 414        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 415
 416        ; return (am_installed, top_dir)
 417        }
 418   where
 419     -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
 420     get_proto | notNull minusbs
 421               = return (normalisePath (drop 2 (last minusbs)))  -- 2 for "-B"
 422               | otherwise
 423               = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
 424                    ; case maybe_exec_dir of       -- (only works on Windows;
 425                                                   --  returns Nothing on Unix)
 426                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 427                         Just dir -> return dir
 428                    }
 429 \end{code}
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsection{Running an external program}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438
 439 \begin{code}
 440 runUnlit :: DynFlags -> [Option] -> IO ()
 441 runUnlit dflags args = do
 442   let p = pgm_L dflags
 443   runSomething dflags "Literate pre-processor" p args
 444
 445 runCpp :: DynFlags -> [Option] -> IO ()
 446 runCpp dflags args =   do
 447   let (p,args0) = pgm_P dflags
 448   runSomething dflags "C pre-processor" p (args0 ++ args)
 449
 450 runPp :: DynFlags -> [Option] -> IO ()
 451 runPp dflags args =   do
 452   let p = pgm_F dflags
 453   runSomething dflags "Haskell pre-processor" p args
 454
 455 runCc :: DynFlags -> [Option] -> IO ()
 456 runCc dflags args =   do
 457   let (p,args0) = pgm_c dflags
 458   runSomething dflags "C Compiler" p (args0++args)
 459
 460 runMangle :: DynFlags -> [Option] -> IO ()
 461 runMangle dflags args = do
 462   let (p,args0) = pgm_m dflags
 463   runSomething dflags "Mangler" p (args0++args)
 464
 465 runSplit :: DynFlags -> [Option] -> IO ()
 466 runSplit dflags args = do
 467   let (p,args0) = pgm_s dflags
 468   runSomething dflags "Splitter" p (args0++args)
 469
 470 runAs :: DynFlags -> [Option] -> IO ()
 471 runAs dflags args = do
 472   let (p,args0) = pgm_a dflags
 473   runSomething dflags "Assembler" p (args0++args)
 474
 475 runLink :: DynFlags -> [Option] -> IO ()
 476 runLink dflags args = do
 477   let (p,args0) = pgm_l dflags
 478   runSomething dflags "Linker" p (args0++args)
 479
 480 runMkDLL :: DynFlags -> [Option] -> IO ()
 481 runMkDLL dflags args = do
 482   let (p,args0) = pgm_dll dflags
 483   runSomething dflags "Make DLL" p (args0++args)
 484
 485 touch :: DynFlags -> String -> String -> IO ()
 486 touch dflags purpose arg =  do
 487   p <- readIORef v_Pgm_T
 488   runSomething dflags purpose p [FileOption "" arg]
 489
 490 copy :: DynFlags -> String -> String -> String -> IO ()
 491 copy dflags purpose from to = do
 492   when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 493
 494   h <- openFile to WriteMode
 495   ls <- readFile from -- inefficient, but it'll do for now.
 496                       -- ToDo: speed up via slurping.
 497   hPutStr h ls
 498   hClose h
 499
 500 \end{code}
 501
 502 \begin{code}
 503 getSysMan :: IO String  -- How to invoke the system manager
 504                         -- (parallel system only)
 505 getSysMan = readIORef v_Pgm_sysman
 506 \end{code}
 507
 508 \begin{code}
 509 getUsageMsgPaths :: IO (FilePath,FilePath)
 510           -- the filenames of the usage messages (ghc, ghci)
 511 getUsageMsgPaths = readIORef v_Path_usages
 512 \end{code}
 513
 514
 515 %************************************************************************
 516 %*                                                                      *
 517 \subsection{Managing temporary files
 518 %*                                                                      *
 519 %************************************************************************
 520
 521 \begin{code}
 522 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 523 \end{code}
 524
 525 \begin{code}
 526 cleanTempFiles :: DynFlags -> IO ()
 527 cleanTempFiles dflags
 528    = do fs <- readIORef v_FilesToClean
 529         removeTmpFiles dflags fs
 530         writeIORef v_FilesToClean []
 531
 532 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 533 cleanTempFilesExcept dflags dont_delete
 534    = do files <- readIORef v_FilesToClean
 535         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 536         removeTmpFiles dflags to_delete
 537         writeIORef v_FilesToClean to_keep
 538
 539
 540 -- find a temporary name that doesn't already exist.
 541 newTempName :: DynFlags -> Suffix -> IO FilePath
 542 newTempName DynFlags{tmpDir=tmp_dir} extn
 543   = do x <- getProcessID
 544        findTempName tmp_dir x
 545   where
 546     findTempName tmp_dir x
 547       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 548            b  <- doesFileExist filename
 549            if b then findTempName tmp_dir (x+1)
 550                 else do consIORef v_FilesToClean filename -- clean it up later
 551                         return filename
 552
 553 addFilesToClean :: [FilePath] -> IO ()
 554 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 555 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
 556
 557 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
 558 removeTmpFiles dflags fs
 559   = warnNon $
 560     traceCmd dflags "Deleting temp files"
 561              ("Deleting: " ++ unwords deletees)
 562              (mapM_ rm deletees)
 563   where
 564     verb = verbosity dflags
 565
 566      -- Flat out refuse to delete files that are likely to be source input
 567      -- files (is there a worse bug than having a compiler delete your source
 568      -- files?)
 569      --
 570      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 571      -- the condition.
 572     warnNon act
 573      | null non_deletees = act
 574      | otherwise         = do
 575         hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
 576         act
 577
 578     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 579
 580     rm f = removeFile f `IO.catch`
 581                 (\_ignored ->
 582                     when (verb >= 2) $
 583                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 584                 )
 585
 586
 587 -----------------------------------------------------------------------------
 588 -- Running an external program
 589
 590 runSomething :: DynFlags
 591              -> String          -- For -v message
 592              -> String          -- Command name (possibly a full path)
 593                                 --      assumed already dos-ified
 594              -> [Option]        -- Arguments
 595                                 --      runSomething will dos-ify them
 596              -> IO ()
 597
 598 runSomething dflags phase_name pgm args = do
 599   let real_args = filter notNull (map showOpt args)
 600   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
 601   exit_code <- rawSystem pgm real_args
 602   case exit_code of
 603      ExitSuccess ->
 604         return ()
 605      -- rawSystem returns (ExitFailure 127) if the exec failed for any
 606      -- reason (eg. the program doesn't exist).  This is the only clue
 607      -- we have, but we need to report something to the user because in
 608      -- the case of a missing program there will otherwise be no output
 609      -- at all.
 610      ExitFailure 127 ->
 611         throwDyn (InstallationError ("could not execute: " ++ pgm))
 612      ExitFailure _other ->
 613         throwDyn (PhaseFailed phase_name exit_code)
 614
 615 showOpt (FileOption pre f) = pre ++ platformPath f
 616 showOpt (Option "") = ""
 617 showOpt (Option s)  = s
 618
 619 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 620 -- a) trace the command (at two levels of verbosity)
 621 -- b) don't do it at all if dry-run is set
 622 traceCmd dflags phase_name cmd_line action
 623  = do   { let verb = verbosity dflags
 624         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 625         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 626         ; hFlush stderr
 627
 628            -- Test for -n flag
 629         ; unless (dopt Opt_DryRun dflags) $ do {
 630
 631            -- And run it!
 632         ; action `IO.catch` handle_exn verb
 633         }}
 634   where
 635     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 636                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
 637                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 638 \end{code}
 639
 640 -----------------------------------------------------------------------------
 641    Path name construction
 642
 643 \begin{code}
 644 slash            :: String -> String -> String
 645 slash s1 s2 = s1 ++ ('/' : s2)
 646 \end{code}
 647
 648
 649 %************************************************************************
 650 %*                                                                      *
 651 \subsection{Support code}
 652 %*                                                                      *
 653 %************************************************************************
 654
 655 \begin{code}
 656 -----------------------------------------------------------------------------
 657 -- Define       getBaseDir     :: IO (Maybe String)
 658
 659 getBaseDir :: IO (Maybe String)
 660 #if defined(mingw32_HOST_OS)
 661 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 662 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 663 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 664                 buf <- mallocArray len
 665                 ret <- getModuleFileName nullPtr buf len
 666                 if ret == 0 then free buf >> return Nothing
 667                             else do s <- peekCString buf
 668                                     free buf
 669                                     return (Just (rootDir s))
 670   where
 671     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 672
 673 foreign import stdcall unsafe "GetModuleFileNameA"
 674   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 675 #else
 676 getBaseDir = return Nothing
 677 #endif
 678
 679 #ifdef mingw32_HOST_OS
 680 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 681 #elif __GLASGOW_HASKELL__ > 504
 682 getProcessID :: IO Int
 683 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 684 #else
 685 getProcessID :: IO Int
 686 getProcessID = Posix.getProcessID
 687 #endif
 688
 689 \end{code}