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