ghc/compiler/main/SysTools.lhs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2001
   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         setPgmL,                -- String -> IO ()
  15         setPgmP,
  16         setPgmF,
  17         setPgmc,
  18         setPgmm,
  19         setPgms,
  20         setPgma,
  21         setPgml,
  22 #ifdef ILX
  23         setPgmI,
  24         setPgmi,
  25 #endif
  26                                 -- Command-line override
  27         setDryRun,
  28
  29         getTopDir,              -- IO String    -- The value of $libdir
  30         getPackageConfigPath,   -- IO String    -- Where package.conf is
  31
  32         -- Interface to system tools
  33         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  34         runPp,                   -- [Option] -> IO ()
  35         runMangle, runSplit,     -- [Option] -> IO ()
  36         runAs, runLink,          -- [Option] -> IO ()
  37         runMkDLL,
  38 #ifdef ILX
  39         runIlx2il, runIlasm,     -- [String] -> IO ()
  40 #endif
  41
  42
  43         touch,                  -- String -> String -> IO ()
  44         copy,                   -- String -> String -> String -> IO ()
  45         normalisePath,          -- FilePath -> FilePath
  46
  47         -- Temporary-file management
  48         setTmpDir,
  49         newTempName,
  50         cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
  51         addFilesToClean,
  52
  53         -- System interface
  54         getProcessID,           -- IO Int
  55         system,                 -- String -> IO ExitCode
  56
  57         -- Misc
  58         showGhcUsage,           -- IO ()        Shows usage message and exits
  59         getSysMan,              -- IO String    Parallel system only
  60
  61         Option(..)
  62
  63  ) where
  64
  65 #include "HsVersions.h"
  66
  67 import DriverUtil
  68 import DriverPhases     ( haskellish_user_src_file )
  69 import Config
  70 import Outputable
  71 import Panic            ( progName, GhcException(..) )
  72 import Util             ( global, notNull )
  73 import CmdLineOpts      ( dynFlag, verbosity )
  74
  75 import EXCEPTION        ( throwDyn )
  76 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  77 import DATA_INT
  78
  79 import Monad            ( when, unless )
  80 import System           ( ExitCode(..), exitWith, getEnv, system )
  81 import IO               ( try, catch,
  82                           openFile, hPutChar, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
  83                           stderr )
  84 import Directory        ( doesFileExist, removeFile )
  85 import List             ( intersperse, partition )
  86
  87 #include "../includes/config.h"
  88
  89 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
  90 -- lines on mingw32, so we disallow it now.
  91 #if __GLASGOW_HASKELL__ < 500
  92 #error GHC >= 5.00 is required for bootstrapping GHC
  93 #endif
  94
  95 #ifndef mingw32_HOST_OS
  96 #if __GLASGOW_HASKELL__ > 504
  97 import qualified System.Posix.Internals
  98 #else
  99 import qualified Posix
 100 #endif
 101 #else /* Must be Win32 */
 102 import List             ( isPrefixOf )
 103 import Util             ( dropList )
 104 import Foreign
 105 import CString          ( CString, peekCString )
 106 #endif
 107
 108 #if __GLASGOW_HASKELL__ < 601
 109 import Foreign          ( withMany, withArray0, nullPtr, Ptr )
 110 import CForeign         ( CString, withCString, throwErrnoIfMinus1 )
 111 #else
 112 import System.Cmd       ( rawSystem )
 113 #endif
 114 \end{code}
 115
 116
 117                 The configuration story
 118                 ~~~~~~~~~~~~~~~~~~~~~~~
 119
 120 GHC needs various support files (library packages, RTS etc), plus
 121 various auxiliary programs (cp, gcc, etc).  It finds these in one
 122 of two places:
 123
 124 * When running as an *installed program*, GHC finds most of this support
 125   stuff in the installed library tree.  The path to this tree is passed
 126   to GHC via the -B flag, and given to initSysTools .
 127
 128 * When running *in-place* in a build tree, GHC finds most of this support
 129   stuff in the build tree.  The path to the build tree is, again passed
 130   to GHC via -B.
 131
 132 GHC tells which of the two is the case by seeing whether package.conf
 133 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
 134
 135
 136 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 137 are, and initialises mutable variables to make it easy to call them.
 138 To to this, it makes use of definitions in Config.hs, which is a Haskell
 139 file containing variables whose value is figured out by the build system.
 140
 141 Config.hs contains two sorts of things
 142
 143   cGCC,         The *names* of the programs
 144   cCPP            e.g.  cGCC = gcc
 145   cUNLIT                cCPP = gcc -E
 146   etc           They do *not* include paths
 147
 148
 149   cUNLIT_DIR_REL   The *path* to the directory containing unlit, split etc
 150   cSPLIT_DIR_REL   *relative* to the root of the build tree,
 151                    for use when running *in-place* in a build tree (only)
 152
 153
 154
 155 ---------------------------------------------
 156 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 157
 158 Another hair-brained scheme for simplifying the current tool location
 159 nightmare in GHC: Simon originally suggested using another
 160 configuration file along the lines of GCC's specs file - which is fine
 161 except that it means adding code to read yet another configuration
 162 file.  What I didn't notice is that the current package.conf is
 163 general enough to do this:
 164
 165 Package
 166     {name = "tools",    import_dirs = [],  source_dirs = [],
 167      library_dirs = [], hs_libraries = [], extra_libraries = [],
 168      include_dirs = [], c_includes = [],   package_deps = [],
 169      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
 170      extra_cc_opts = [], extra_ld_opts = []}
 171
 172 Which would have the advantage that we get to collect together in one
 173 place the path-specific package stuff with the path-specific tool
 174 stuff.
 175                 End of NOTES
 176 ---------------------------------------------
 177
 178
 179 %************************************************************************
 180 %*                                                                      *
 181 \subsection{Global variables to contain system programs}
 182 %*                                                                      *
 183 %************************************************************************
 184
 185 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
 186 (See remarks under pathnames below)
 187
 188 \begin{code}
 189 GLOBAL_VAR(v_Pgm_L,     error "pgm_L",   String)        -- unlit
 190 GLOBAL_VAR(v_Pgm_P,     error "pgm_P",   (String,[Option]))     -- cpp
 191 GLOBAL_VAR(v_Pgm_F,     error "pgm_F",   String)        -- pp
 192 GLOBAL_VAR(v_Pgm_c,     error "pgm_c",   String)        -- gcc
 193 GLOBAL_VAR(v_Pgm_m,     error "pgm_m",   String)        -- asm code mangler
 194 GLOBAL_VAR(v_Pgm_s,     error "pgm_s",   String)        -- asm code splitter
 195 GLOBAL_VAR(v_Pgm_a,     error "pgm_a",   String)        -- as
 196 #ifdef ILX
 197 GLOBAL_VAR(v_Pgm_I,     error "pgm_I",   String)        -- ilx2il
 198 GLOBAL_VAR(v_Pgm_i,     error "pgm_i",   String)        -- ilasm
 199 #endif
 200 GLOBAL_VAR(v_Pgm_l,     error "pgm_l",   String)        -- ld
 201 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)        -- mkdll
 202
 203 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 204 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 205
 206 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 207 GLOBAL_VAR(v_Path_usage,          error "ghc_usage.txt",       String)
 208
 209 GLOBAL_VAR(v_TopDir,    error "TopDir", String)         -- -B<dir>
 210
 211 -- Parallel system only
 212 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 213
 214 -- ways to get at some of these variables from outside this module
 215 getPackageConfigPath = readIORef v_Path_package_config
 216 getTopDir            = readIORef v_TopDir
 217 \end{code}
 218
 219
 220 %************************************************************************
 221 %*                                                                      *
 222 \subsection{Initialisation}
 223 %*                                                                      *
 224 %************************************************************************
 225
 226 \begin{code}
 227 initSysTools :: [String]        -- Command-line arguments starting "-B"
 228
 229              -> IO ()           -- Set all the mutable variables above, holding
 230                                 --      (a) the system programs
 231                                 --      (b) the package-config file
 232                                 --      (c) the GHC usage message
 233
 234
 235 initSysTools minusB_args
 236   = do  { (am_installed, top_dir) <- findTopDir minusB_args
 237         ; writeIORef v_TopDir top_dir
 238                 -- top_dir
 239                 --      for "installed" this is the root of GHC's support files
 240                 --      for "in-place" it is the root of the build tree
 241                 -- NB: top_dir is assumed to be in standard Unix format '/' separated
 242
 243         ; let installed, installed_bin :: FilePath -> FilePath
 244               installed_bin pgm   =  pgmPath top_dir pgm
 245               installed     file  =  pgmPath top_dir file
 246               inplace dir   pgm   =  pgmPath (top_dir `slash`
 247                                                 cPROJECT_DIR `slash` dir) pgm
 248
 249         ; let pkgconfig_path
 250                 | am_installed = installed "package.conf"
 251                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
 252
 253               ghc_usage_msg_path
 254                 | am_installed = installed "ghc-usage.txt"
 255                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
 256
 257                 -- For all systems, unlit, split, mangle are GHC utilities
 258                 -- architecture-specific stuff is done when building Config.hs
 259               unlit_path
 260                 | am_installed = installed_bin cGHC_UNLIT_PGM
 261                 | otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
 262
 263                 -- split and mangle are Perl scripts
 264               split_script
 265                 | am_installed = installed_bin cGHC_SPLIT_PGM
 266                 | otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
 267
 268               mangle_script
 269                 | am_installed = installed_bin cGHC_MANGLER_PGM
 270                 | otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
 271
 272 #ifndef mingw32_HOST_OS
 273         -- check whether TMPDIR is set in the environment
 274         ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
 275                      setTmpDir dir
 276                      return ()
 277                  )
 278 #else
 279           -- On Win32, consult GetTempPath() for a temp dir.
 280           --  => it first tries TMP, TEMP, then finally the
 281           --   Windows directory(!). The directory is in short-path
 282           --   form.
 283         ; IO.try (do
 284                 let len = (2048::Int)
 285                 buf  <- mallocArray len
 286                 ret  <- getTempPath len buf
 287                 tdir <-
 288                   if ret == 0 then do
 289                       -- failed, consult TMPDIR.
 290                      free buf
 291                      getEnv "TMPDIR"
 292                    else do
 293                      s <- peekCString buf
 294                      free buf
 295                      return s
 296                 setTmpDir tdir)
 297 #endif
 298
 299         -- Check that the package config exists
 300         ; config_exists <- doesFileExist pkgconfig_path
 301         ; when (not config_exists) $
 302              throwDyn (InstallationError
 303                          ("Can't find package.conf as " ++ pkgconfig_path))
 304
 305 #if defined(mingw32_HOST_OS)
 306         --              WINDOWS-SPECIFIC STUFF
 307         -- On Windows, gcc and friends are distributed with GHC,
 308         --      so when "installed" we look in TopDir/bin
 309         -- When "in-place" we look wherever the build-time configure
 310         --      script found them
 311         -- When "install" we tell gcc where its specs file + exes are (-B)
 312         --      and also some places to pick up include files.  We need
 313         --      to be careful to put all necessary exes in the -B place
 314         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 315         --      then tries to run unadorned "as", "ld", etc, and will
 316         --      pick up whatever happens to be lying around in the path,
 317         --      possibly including those from a cygwin install on the target,
 318         --      which is exactly what we're trying to avoid.
 319         ; let gcc_path  | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
 320                         | otherwise    = cGCC
 321                 -- The trailing "/" is absolutely essential; gcc seems
 322                 -- to construct file names simply by concatenating to this
 323                 -- -B path with no extra slash
 324                 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
 325                 -- later on; although gcc_path is in NATIVE format, gcc can cope
 326                 --      (see comments with declarations of global variables)
 327                 --
 328                 -- The quotes round the -B argument are in case TopDir has spaces in it
 329
 330               perl_path | am_installed = installed_bin cGHC_PERL
 331                         | otherwise    = cGHC_PERL
 332
 333         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 334         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY_PGM
 335                           | otherwise    = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
 336
 337         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 338         -- a call to Perl to get the invocation of split and mangle
 339         ; let split_path  = perl_path ++ " \"" ++ split_script ++ "\""
 340               mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
 341
 342         ; let mkdll_path
 343                 | am_installed = pgmPath (installed "gcc-lib/") cMKDLL ++
 344                                  " --dlltool-name " ++ pgmPath (installed "gcc-lib/") "dlltool" ++
 345                                  " --driver-name " ++ gcc_path
 346                 | otherwise    = cMKDLL
 347 #else
 348         --              UNIX-SPECIFIC STUFF
 349         -- On Unix, the "standard" tools are assumed to be
 350         -- in the same place whether we are running "in-place" or "installed"
 351         -- That place is wherever the build-time configure script found them.
 352         ; let   gcc_path   = cGCC
 353                 touch_path = "touch"
 354                 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
 355
 356         -- On Unix, scripts are invoked using the '#!' method.  Binary
 357         -- installations of GHC on Unix place the correct line on the front
 358         -- of the script at installation time, so we don't want to wire-in
 359         -- our knowledge of $(PERL) on the host system here.
 360         ; let split_path  = split_script
 361               mangle_path = mangle_script
 362 #endif
 363
 364         -- cpp is derived from gcc on all platforms
 365         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
 366         -- Config.hs one day.
 367         ; let cpp_path  = (gcc_path, (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 368
 369         -- For all systems, copy and remove are provided by the host
 370         -- system; architecture-specific stuff is done when building Config.hs
 371         ; let   cp_path = cGHC_CP
 372
 373         -- Other things being equal, as and ld are simply gcc
 374         ; let   as_path  = gcc_path
 375                 ld_path  = gcc_path
 376
 377 #ifdef ILX
 378        -- ilx2il and ilasm are specified in Config.hs
 379        ; let    ilx2il_path = cILX2IL
 380                 ilasm_path  = cILASM
 381 #endif
 382
 383         -- Initialise the global vars
 384         ; writeIORef v_Path_package_config pkgconfig_path
 385         ; writeIORef v_Path_usage          ghc_usage_msg_path
 386
 387         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 388                 -- Hans: this isn't right in general, but you can
 389                 -- elaborate it in the same way as the others
 390
 391         ; writeIORef v_Pgm_L               unlit_path
 392         ; writeIORef v_Pgm_P               cpp_path
 393         ; writeIORef v_Pgm_F               ""
 394         ; writeIORef v_Pgm_c               gcc_path
 395         ; writeIORef v_Pgm_m               mangle_path
 396         ; writeIORef v_Pgm_s               split_path
 397         ; writeIORef v_Pgm_a               as_path
 398 #ifdef ILX
 399         ; writeIORef v_Pgm_I               ilx2il_path
 400         ; writeIORef v_Pgm_i               ilasm_path
 401 #endif
 402         ; writeIORef v_Pgm_l               ld_path
 403         ; writeIORef v_Pgm_MkDLL           mkdll_path
 404         ; writeIORef v_Pgm_T               touch_path
 405         ; writeIORef v_Pgm_CP              cp_path
 406
 407         ; return ()
 408         }
 409
 410 #if defined(mingw32_HOST_OS)
 411 foreign import stdcall "GetTempPathA" unsafe getTempPath :: Int -> CString -> IO Int32
 412 #endif
 413 \end{code}
 414
 415 The various setPgm functions are called when a command-line option
 416 like
 417
 418         -pgmLld
 419
 420 is used to override a particular program with a new one
 421
 422 \begin{code}
 423 setPgmL = writeIORef v_Pgm_L
 424 -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
 425 -- Config.hs should really use Option.
 426 setPgmP arg = let (pgm:args) = words arg in writeIORef v_Pgm_P (pgm,map Option args)
 427 setPgmF = writeIORef v_Pgm_F
 428 setPgmc = writeIORef v_Pgm_c
 429 setPgmm = writeIORef v_Pgm_m
 430 setPgms = writeIORef v_Pgm_s
 431 setPgma = writeIORef v_Pgm_a
 432 setPgml = writeIORef v_Pgm_l
 433 #ifdef ILX
 434 setPgmI = writeIORef v_Pgm_I
 435 setPgmi = writeIORef v_Pgm_i
 436 #endif
 437 \end{code}
 438
 439
 440 \begin{code}
 441 -- Find TopDir
 442 --      for "installed" this is the root of GHC's support files
 443 --      for "in-place" it is the root of the build tree
 444 --
 445 -- Plan of action:
 446 -- 1. Set proto_top_dir
 447 --      a) look for (the last) -B flag, and use it
 448 --      b) if there are no -B flags, get the directory
 449 --         where GHC is running (only on Windows)
 450 --
 451 -- 2. If package.conf exists in proto_top_dir, we are running
 452 --      installed; and TopDir = proto_top_dir
 453 --
 454 -- 3. Otherwise we are running in-place, so
 455 --      proto_top_dir will be /...stuff.../ghc/compiler
 456 --      Set TopDir to /...stuff..., which is the root of the build tree
 457 --
 458 -- This is very gruesome indeed
 459
 460 findTopDir :: [String]
 461           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 462                  String)        -- TopDir (in Unix format '/' separated)
 463
 464 findTopDir minusbs
 465   = do { top_dir <- get_proto
 466         -- Discover whether we're running in a build tree or in an installation,
 467         -- by looking for the package configuration file.
 468        ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
 469
 470        ; return (am_installed, top_dir)
 471        }
 472   where
 473     -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
 474     get_proto | notNull minusbs
 475               = return (normalisePath (drop 2 (last minusbs)))  -- 2 for "-B"
 476               | otherwise
 477               = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
 478                    ; case maybe_exec_dir of       -- (only works on Windows;
 479                                                   --  returns Nothing on Unix)
 480                         Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 481                         Just dir -> return dir
 482                    }
 483 \end{code}
 484
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection{Command-line options}
 489 n%*                                                                     *
 490 %************************************************************************
 491
 492 When invoking external tools as part of the compilation pipeline, we
 493 pass these a sequence of options on the command-line. Rather than
 494 just using a list of Strings, we use a type that allows us to distinguish
 495 between filepaths and 'other stuff'. [The reason being, of course, that
 496 this type gives us a handle on transforming filenames, and filenames only,
 497 to whatever format they're expected to be on a particular platform.]
 498
 499 \begin{code}
 500 data Option
 501  = FileOption -- an entry that _contains_ filename(s) / filepaths.
 502               String  -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
 503               String  -- the filepath/filename portion
 504  | Option     String
 505
 506 showOpt (FileOption pre f) = pre ++ platformPath f
 507 showOpt (Option "") = ""
 508 showOpt (Option s)  = s
 509
 510 \end{code}
 511
 512
 513 %************************************************************************
 514 %*                                                                      *
 515 \subsection{Running an external program}
 516 %*                                                                      *
 517 %************************************************************************
 518
 519
 520 \begin{code}
 521 runUnlit :: [Option] -> IO ()
 522 runUnlit args = do p <- readIORef v_Pgm_L
 523                    runSomething "Literate pre-processor" p args
 524
 525 runCpp :: [Option] -> IO ()
 526 runCpp args =   do (p,baseArgs) <- readIORef v_Pgm_P
 527                    runSomething "C pre-processor" p (baseArgs ++ args)
 528
 529 runPp :: [Option] -> IO ()
 530 runPp args =   do p <- readIORef v_Pgm_F
 531                   runSomething "Haskell pre-processor" p args
 532
 533 runCc :: [Option] -> IO ()
 534 runCc args =   do p <- readIORef v_Pgm_c
 535                   runSomething "C Compiler" p args
 536
 537 runMangle :: [Option] -> IO ()
 538 runMangle args = do p <- readIORef v_Pgm_m
 539                     runSomething "Mangler" p args
 540
 541 runSplit :: [Option] -> IO ()
 542 runSplit args = do p <- readIORef v_Pgm_s
 543                    runSomething "Splitter" p args
 544
 545 runAs :: [Option] -> IO ()
 546 runAs args = do p <- readIORef v_Pgm_a
 547                 runSomething "Assembler" p args
 548
 549 runLink :: [Option] -> IO ()
 550 runLink args = do p <- readIORef v_Pgm_l
 551                   runSomething "Linker" p args
 552
 553 #ifdef ILX
 554 runIlx2il :: [Option] -> IO ()
 555 runIlx2il args = do p <- readIORef v_Pgm_I
 556                     runSomething "Ilx2Il" p args
 557
 558 runIlasm :: [Option] -> IO ()
 559 runIlasm args = do p <- readIORef v_Pgm_i
 560                    runSomething "Ilasm" p args
 561 #endif
 562
 563 runMkDLL :: [Option] -> IO ()
 564 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 565                    runSomething "Make DLL" p args
 566
 567 touch :: String -> String -> IO ()
 568 touch purpose arg =  do p <- readIORef v_Pgm_T
 569                         runSomething purpose p [FileOption "" arg]
 570
 571 copy :: String -> String -> String -> IO ()
 572 copy purpose from to = do
 573   verb <- dynFlag verbosity
 574   when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
 575
 576   h <- openFile to WriteMode
 577   ls <- readFile from -- inefficient, but it'll do for now.
 578                       -- ToDo: speed up via slurping.
 579   hPutStr h ls
 580   hClose h
 581 \end{code}
 582
 583 \begin{code}
 584 getSysMan :: IO String  -- How to invoke the system manager
 585                         -- (parallel system only)
 586 getSysMan = readIORef v_Pgm_sysman
 587 \end{code}
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsection{GHC Usage message}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 Show the usage message and exit
 596
 597 \begin{code}
 598 showGhcUsage = do { usage_path <- readIORef v_Path_usage
 599                   ; usage      <- readFile usage_path
 600                   ; dump usage
 601                   ; exitWith ExitSuccess }
 602   where
 603      dump ""          = return ()
 604      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 605      dump (c:s)       = hPutChar stderr c >> dump s
 606 \end{code}
 607
 608
 609 %************************************************************************
 610 %*                                                                      *
 611 \subsection{Managing temporary files
 612 %*                                                                      *
 613 %************************************************************************
 614
 615 \begin{code}
 616 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 617 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 618         -- v_TmpDir has no closing '/'
 619 \end{code}
 620
 621 \begin{code}
 622 setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
 623     where
 624 #if !defined(mingw32_HOST_OS)
 625      canonicalise p = normalisePath p
 626 #else
 627         -- Canonicalisation of temp path under win32 is a bit more
 628         -- involved: (a) strip trailing slash,
 629         --           (b) normalise slashes
 630         --           (c) just in case, if there is a prefix /cygdrive/x/, change to x:
 631         --
 632      canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
 633
 634         -- if we're operating under cygwin, and TMP/TEMP is of
 635         -- the form "/cygdrive/drive/path", translate this to
 636         -- "drive:/path" (as GHC isn't a cygwin app and doesn't
 637         -- understand /cygdrive paths.)
 638      xltCygdrive path
 639       | "/cygdrive/" `isPrefixOf` path =
 640           case drop (length "/cygdrive/") path of
 641             drive:xs@('/':_) -> drive:':':xs
 642             _ -> path
 643       | otherwise = path
 644
 645         -- strip the trailing backslash (awful, but we only do this once).
 646      removeTrailingSlash path =
 647        case last path of
 648          '/'  -> init path
 649          '\\' -> init path
 650          _    -> path
 651 #endif
 652
 653 cleanTempFiles :: Int -> IO ()
 654 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
 655                          removeTmpFiles verb fs
 656
 657 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 658 cleanTempFilesExcept verb dont_delete
 659   = do fs <- readIORef v_FilesToClean
 660        let leftovers = filter (`notElem` dont_delete) fs
 661        removeTmpFiles verb leftovers
 662        writeIORef v_FilesToClean dont_delete
 663
 664
 665 -- find a temporary name that doesn't already exist.
 666 newTempName :: Suffix -> IO FilePath
 667 newTempName extn
 668   = do x <- getProcessID
 669        tmp_dir <- readIORef v_TmpDir
 670        findTempName tmp_dir x
 671   where
 672     findTempName tmp_dir x
 673       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 674            b  <- doesFileExist filename
 675            if b then findTempName tmp_dir (x+1)
 676                 else do add v_FilesToClean filename -- clean it up later
 677                         return filename
 678
 679 addFilesToClean :: [FilePath] -> IO ()
 680 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 681 addFilesToClean files = mapM_ (add v_FilesToClean) files
 682
 683 removeTmpFiles :: Int -> [FilePath] -> IO ()
 684 removeTmpFiles verb fs
 685   = warnNon $
 686     traceCmd "Deleting temp files"
 687              ("Deleting: " ++ unwords deletees)
 688              (mapM_ rm deletees)
 689   where
 690      -- Flat out refuse to delete files that are likely to be source input
 691      -- files (is there a worse bug than having a compiler delete your source
 692      -- files?)
 693      --
 694      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 695      -- the condition.
 696     warnNon act
 697      | null non_deletees = act
 698      | otherwise         = do
 699         hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
 700         act
 701
 702     (non_deletees, deletees) = partition haskellish_user_src_file fs
 703
 704     rm f = removeFile f `IO.catch`
 705                 (\_ignored ->
 706                     when (verb >= 2) $
 707                       hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
 708                 )
 709
 710 \end{code}
 711
 712
 713 %************************************************************************
 714 %*                                                                      *
 715 \subsection{Running a program}
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 \begin{code}
 720 GLOBAL_VAR(v_Dry_run, False, Bool)
 721
 722 setDryRun :: IO ()
 723 setDryRun = writeIORef v_Dry_run True
 724
 725 -----------------------------------------------------------------------------
 726 -- Running an external program
 727
 728 runSomething :: String          -- For -v message
 729              -> String          -- Command name (possibly a full path)
 730                                 --      assumed already dos-ified
 731              -> [Option]        -- Arguments
 732                                 --      runSomething will dos-ify them
 733              -> IO ()
 734
 735 runSomething phase_name pgm args = do
 736   let real_args = filter notNull (map showOpt args)
 737   traceCmd phase_name (concat (intersperse " " (pgm:real_args))) $ do
 738   exit_code <- rawSystem pgm real_args
 739   if (exit_code /= ExitSuccess)
 740         then throwDyn (PhaseFailed phase_name exit_code)
 741         else return ()
 742
 743 traceCmd :: String -> String -> IO () -> IO ()
 744 -- a) trace the command (at two levels of verbosity)
 745 -- b) don't do it at all if dry-run is set
 746 traceCmd phase_name cmd_line action
 747  = do   { verb <- dynFlag verbosity
 748         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 749         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 750         ; hFlush stderr
 751
 752            -- Test for -n flag
 753         ; n <- readIORef v_Dry_run
 754         ; unless n $ do {
 755
 756            -- And run it!
 757         ; action `IO.catch` handle_exn verb
 758         }}
 759   where
 760     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 761                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
 762                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 763
 764 -- -----------------------------------------------------------------------------
 765 -- rawSystem: run an external command
 766
 767 #if __GLASGOW_HASKELL__ < 601
 768
 769 -- This code is copied from System.Cmd on GHC 6.1.
 770
 771 rawSystem :: FilePath -> [String] -> IO ExitCode
 772
 773 #ifndef mingw32_TARGET_OS
 774
 775 rawSystem cmd args =
 776   withCString cmd $ \pcmd ->
 777     withMany withCString (cmd:args) $ \cstrs ->
 778       withArray0 nullPtr cstrs $ \arr -> do
 779         status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr)
 780         case status of
 781             0  -> return ExitSuccess
 782             n  -> return (ExitFailure n)
 783
 784 foreign import ccall "rawSystem" unsafe
 785   c_rawSystem :: CString -> Ptr CString -> IO Int
 786
 787 #else
 788
 789 -- On Windows, the command line is passed to the operating system as
 790 -- a single string.  Command-line parsing is done by the executable
 791 -- itself.
 792 rawSystem cmd args = do
 793   let cmdline = {-translate-} cmd ++ concat (map ((' ':) . translate) args)
 794         -- Urk, don't quote/escape the command name on Windows, because the
 795         -- compiler is exceedingly naughty and sometimes uses 'perl "..."'
 796         -- as the command name.
 797   withCString cmdline $ \pcmdline -> do
 798     status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
 799     case status of
 800        0  -> return ExitSuccess
 801        n  -> return (ExitFailure n)
 802
 803 translate :: String -> String
 804 translate str = '"' : foldr escape "\"" str
 805   where escape '"'  str = '\\' : '"'  : str
 806         escape '\\' str = '\\' : '\\' : str
 807         escape c    str = c : str
 808
 809 foreign import ccall "rawSystem" unsafe
 810   c_rawSystem :: CString -> IO Int
 811
 812 #endif
 813 #endif
 814 \end{code}
 815
 816
 817 %************************************************************************
 818 %*                                                                      *
 819 \subsection{Path names}
 820 %*                                                                      *
 821 %************************************************************************
 822
 823 We maintain path names in Unix form ('/'-separated) right until
 824 the last moment.  On Windows we dos-ify them just before passing them
 825 to the Windows command.
 826
 827 The alternative, of using '/' consistently on Unix and '\' on Windows,
 828 proved quite awkward.  There were a lot more calls to platformPath,
 829 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 830 interpreted a command line 'foo\baz' as 'foobaz'.
 831
 832 \begin{code}
 833 -----------------------------------------------------------------------------
 834 -- Convert filepath into platform / MSDOS form.
 835
 836 -- platformPath does two things
 837 -- a) change '/' to '\'
 838 -- b) remove initial '/cygdrive/'
 839
 840 normalisePath :: String -> String
 841 -- Just change '\' to '/'
 842
 843 pgmPath :: String               -- Directory string in Unix format
 844         -> String               -- Program name with no directory separators
 845                                 --      (e.g. copy /y)
 846         -> String               -- Program invocation string in native format
 847
 848
 849
 850 #if defined(mingw32_HOST_OS)
 851 --------------------- Windows version ------------------
 852 normalisePath xs = subst '\\' '/' xs
 853 platformPath p   = subst '/' '\\' p
 854 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 855
 856 subst a b ls = map (\ x -> if x == a then b else x) ls
 857 #else
 858 --------------------- Non-Windows version --------------
 859 normalisePath xs   = xs
 860 pgmPath dir pgm    = dir ++ '/' : pgm
 861 platformPath stuff = stuff
 862 --------------------------------------------------------
 863 #endif
 864
 865 \end{code}
 866
 867
 868 -----------------------------------------------------------------------------
 869    Path name construction
 870
 871 \begin{code}
 872 slash            :: String -> String -> String
 873 absPath, relPath :: [String] -> String
 874
 875 relPath [] = ""
 876 relPath xs = foldr1 slash xs
 877
 878 absPath xs = "" `slash` relPath xs
 879
 880 slash s1 s2 = s1 ++ ('/' : s2)
 881 \end{code}
 882
 883
 884 %************************************************************************
 885 %*                                                                      *
 886 \subsection{Support code}
 887 %*                                                                      *
 888 %************************************************************************
 889
 890 \begin{code}
 891 -----------------------------------------------------------------------------
 892 -- Define       getBaseDir     :: IO (Maybe String)
 893
 894 #if defined(mingw32_HOST_OS)
 895 getBaseDir :: IO (Maybe String)
 896 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 897 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 898 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 899                 buf <- mallocArray len
 900                 ret <- getModuleFileName nullPtr buf len
 901                 if ret == 0 then free buf >> return Nothing
 902                             else do s <- peekCString buf
 903                                     free buf
 904                                     return (Just (rootDir s))
 905   where
 906     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 907
 908 foreign import stdcall "GetModuleFileNameA" unsafe
 909   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 910 #else
 911 getBaseDir :: IO (Maybe String) = do return Nothing
 912 #endif
 913
 914 #ifdef mingw32_HOST_OS
 915 foreign import ccall "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
 916 #elif __GLASGOW_HASKELL__ > 504
 917 getProcessID :: IO Int
 918 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 919 #else
 920 getProcessID :: IO Int
 921 getProcessID = Posix.getProcessID
 922 #endif
 923
 924 \end{code}