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