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