ghc/compiler/main/SysTools.lhs

   1 -----------------------------------------------------------------------------
   2 -- Access to system tools: gcc, cp, rm etc
   3 --
   4 -- (c) The University of Glasgow 2000
   5 --
   6 -----------------------------------------------------------------------------
   7
   8 \begin{code}
   9 module SysTools (
  10         -- Initialisation
  11         initSysTools,
  12         setPgm,                 -- String -> IO ()
  13                                 -- Command-line override
  14         setDryRun,
  15
  16         packageConfigPath,      -- IO String
  17                                 -- Where package.conf is
  18
  19         -- Interface to system tools
  20         runUnlit, runCpp, runCc, -- [String] -> IO ()
  21         runMangle, runSplit,     -- [String] -> IO ()
  22         runAs, runLink,          -- [String] -> IO ()
  23         runMkDLL,
  24
  25         touch,                  -- String -> String -> IO ()
  26         copy,                   -- String -> String -> String -> IO ()
  27
  28         -- Temporary-file management
  29         setTmpDir,
  30         newTempName,
  31         cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
  32         addFilesToClean,
  33
  34         -- System interface
  35         getProcessID,           -- IO Int
  36         system,                 -- String -> IO Int     -- System.system
  37
  38         -- Misc
  39         showGhcUsage,           -- IO ()        Shows usage message and exits
  40         getSysMan,              -- IO String    Parallel system only
  41
  42         runSomething    -- ToDo: make private
  43  ) where
  44
  45 import DriverUtil
  46 import Config
  47 import Outputable       ( panic )
  48 import Panic            ( progName, GhcException(..) )
  49 import Util             ( global )
  50 import CmdLineOpts      ( dynFlag, verbosity )
  51
  52 import List             ( intersperse )
  53 import Exception        ( throwDyn, catchAllIO )
  54 import IO               ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr )
  55 import Directory        ( doesFileExist, removeFile )
  56 import IOExts           ( IORef, readIORef, writeIORef )
  57 import Monad            ( when, unless )
  58 import qualified System
  59 import System           ( ExitCode(..) )
  60 import qualified Posix
  61
  62 #include "../includes/config.h"
  63 #include "HsVersions.h"
  64
  65 {-# DEPRECATED runSomething "runSomething should be private to SysTools" #-}
  66
  67 \end{code}
  68
  69
  70                 The configuration story
  71                 ~~~~~~~~~~~~~~~~~~~~~~~
  72
  73 GHC needs various support files (library packages, RTS etc), plus
  74 various auxiliary programs (cp, gcc, etc).  It finds these in one
  75 of two places:
  76
  77 * When running as an *installed program*, GHC finds most of this support
  78   stuff in the installed library tree.  The path to this tree is passed
  79   to GHC via the -B flag, and given to initSysTools .
  80
  81 * When running *in-place* in a build tree, GHC finds most of this support
  82   stuff in the build tree.  The path to the build tree is, again passed
  83   to GHC via -B.
  84
  85 GHC tells which of the two is the case by seeing whether package.conf
  86 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
  87
  88
  89 SysTools.initSysProgs figures out exactly where all the auxiliary programs
  90 are, and initialises mutable variables to make it easy to call them.
  91 To to this, it makes use of definitions in Config.hs, which is a Haskell
  92 file containing variables whose value is figured out by the build system.
  93
  94 Config.hs contains two sorts of things
  95
  96   cGCC,         The *names* of the programs
  97   cCPP            e.g.  cGCC = gcc
  98   cUNLIT                cCPP = gcc -E
  99   etc           They do *not* include paths
 100
 101
 102   cUNLIT_DIR    The *path* to the directory containing unlit, split etc
 103   cSPLIT_DIR    *relative* to the root of the build tree,
 104                 for use when running *in-place* in a build tree (only)
 105
 106
 107
 108 %************************************************************************
 109 %*                                                                      *
 110 \subsection{Global variables to contain system programs}
 111 %*                                                                      *
 112 %************************************************************************
 113
 114 \begin{code}
 115 GLOBAL_VAR(v_Pgm_L,     error "pgm_L",   String)        -- unlit
 116 GLOBAL_VAR(v_Pgm_P,     error "pgm_P",   String)        -- cpp
 117 GLOBAL_VAR(v_Pgm_c,     error "pgm_c",   String)        -- gcc
 118 GLOBAL_VAR(v_Pgm_m,     error "pgm_m",   String)        -- asm code mangler
 119 GLOBAL_VAR(v_Pgm_s,     error "pgm_s",   String)        -- asm code splitter
 120 GLOBAL_VAR(v_Pgm_a,     error "pgm_a",   String)        -- as
 121 GLOBAL_VAR(v_Pgm_l,     error "pgm_l",   String)        -- ld
 122 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)        -- mkdll
 123
 124 GLOBAL_VAR(v_Pgm_PERL, error "pgm_PERL", String)        -- perl
 125 GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)        -- touch
 126 GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP",   String)        -- cp
 127
 128 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 129 GLOBAL_VAR(v_Path_usage,          error "ghc_usage.txt",       String)
 130
 131 -- Parallel system only
 132 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)    -- system manager
 133 \end{code}
 134
 135
 136 %************************************************************************
 137 %*                                                                      *
 138 \subsection{Initialisation}
 139 %*                                                                      *
 140 %************************************************************************
 141
 142 \begin{code}
 143 initSysTools :: String  -- TopDir
 144                         --      for "installed" this is the root of GHC's support files
 145                         --      for "in-place" it is the root of the build tree
 146
 147              -> IO ()   -- Set all the mutable variables above, holding
 148                         --      (a) the system programs
 149                         --      (b) the package-config file
 150                         --      (c) the GHC usage message
 151
 152 initSysTools top_dir
 153   = do  { let installed   pgm = top_dir `slash` "extra-bin" `slash` pgm
 154               inplace dir pgm = top_dir `slash` dir         `slash` pgm
 155
 156               installed_pkgconfig = installed "package.conf"
 157               inplace_pkgconfig   = inplace cGHC_DRIVER_DIR "package.conf.inplace"
 158
 159         -- Discover whether we're running in a build tree or in an installation,
 160         -- by looking for the package configuration file.
 161         ; am_installed <- doesFileExist installed_pkgconfig
 162
 163         -- Check that the in-place package config exists if
 164         -- the installed one does not (we need at least one!)
 165         ; if am_installed then return () else
 166           do config_exists <- doesFileExist inplace_pkgconfig
 167              if config_exists then return () else
 168                 throwDyn (InstallationError
 169                              ("Can't find package.conf in " ++
 170                               inplace_pkgconfig))
 171
 172         ; let pkgconfig_path | am_installed = installed_pkgconfig
 173                              | otherwise    = inplace_pkgconfig
 174
 175         -- The GHC usage help message is found similarly to the package configuration
 176         ; let ghc_usage_msg_path | am_installed = installed "ghc-usage.txt"
 177                                  | otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
 178
 179
 180 #if defined(mingw32_TARGET_OS)
 181         --              WINDOWS-SPECIFIC STUFF
 182         -- On Windows, gcc and friends are distributed with GHC,
 183         --      so when "installed" we look in TopDir/bin
 184         -- When "in-place" we look wherever the build-time configure
 185         --      script found them
 186         ; let cpp_path  | am_installed = installed cRAWCPP
 187                         | otherwise    = cRAWCPP
 188               gcc_path  | am_installed = installed cGCC
 189                         | otherwise    = cGCC
 190               perl_path | am_installed = installed cGHC_PERL
 191                         | otherwise    = cGHC_PERL
 192
 193         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 194         ; let touch_path  | am_installed = installed cGHC_TOUCHY
 195                           | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
 196
 197         ; let mkdll_path = cMKDLL
 198 #else
 199         --              UNIX-SPECIFIC STUFF
 200         -- On Unix, the "standard" tools are assumed to be
 201         -- in the same place whether we are running "in-place" or "installed"
 202         -- That place is wherever the build-time configure script found them.
 203         ; let   cpp_path   = cRAWCPP
 204                 gcc_path   = cGCC
 205                 touch_path = cGHC_TOUCHY
 206                 perl_path  = cGHC_PERL
 207                 mkdll_path = panic "Cant build DLLs on a non-Win32 system"
 208 #endif
 209
 210         -- For all systems, unlit, split, mangle are GHC utilities
 211         -- architecture-specific stuff is done when building Config.hs
 212         --
 213         -- However split and mangle are Perl scripts, and on Win32 at least
 214         -- we don't want to rely on #!/bin/perl, so we prepend a call to Perl
 215         ; let unlit_path  | am_installed = installed cGHC_UNLIT
 216                           | otherwise    = inplace cGHC_UNLIT_DIR cGHC_UNLIT
 217
 218               split_script  | am_installed = installed cGHC_SPLIT
 219                             | otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
 220               mangle_script | am_installed = installed cGHC_MANGLER
 221                             | otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER
 222
 223               split_path  = perl_path ++ " " ++ split_script
 224               mangle_path = perl_path ++ " " ++ mangle_script
 225
 226         -- For all systems, copy and remove are provided by the host
 227         -- system; architecture-specific stuff is done when building Config.hs
 228         ; let   cp_path = cGHC_CP
 229
 230         -- Other things being equal, as and ld are simply gcc
 231         ; let   as_path  = gcc_path
 232                 ld_path  = gcc_path
 233
 234
 235         -- Initialise the global vars
 236         ; writeIORef v_Path_package_config pkgconfig_path
 237         ; writeIORef v_Path_usage          ghc_usage_msg_path
 238
 239         ; writeIORef v_Pgm_sysman          (top_dir ++ "/ghc/rts/parallel/SysMan")
 240                 -- Hans: this isn't right in general, but you can
 241                 -- elaborate it in the same way as the others
 242
 243         ; writeIORef v_Pgm_L               unlit_path
 244         ; writeIORef v_Pgm_P               cpp_path
 245         ; writeIORef v_Pgm_c               gcc_path
 246         ; writeIORef v_Pgm_m               mangle_path
 247         ; writeIORef v_Pgm_s               split_path
 248         ; writeIORef v_Pgm_a               as_path
 249         ; writeIORef v_Pgm_l               ld_path
 250         ; writeIORef v_Pgm_MkDLL           mkdll_path
 251         ; writeIORef v_Pgm_T               touch_path
 252         ; writeIORef v_Pgm_CP              cp_path
 253         ; writeIORef v_Pgm_PERL            perl_path
 254
 255         }
 256 \end{code}
 257
 258 setPgm is called when a command-line option like
 259         -pgmLld
 260 is used to override a particular program with a new onw
 261
 262 \begin{code}
 263 setPgm :: String -> IO ()
 264 -- The string is the flag, minus the '-pgm' prefix
 265 -- So the first character says which program to override
 266
 267 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
 268 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 269 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 270 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
 271 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
 272 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
 273 setPgm pgm         = unknownFlagErr ("-pgm" ++ pgm)
 274 \end{code}
 275
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsection{Running an external program}
 280 n%*                                                                     *
 281 %************************************************************************
 282
 283
 284 \begin{code}
 285 runUnlit :: [String] -> IO ()
 286 runUnlit args = do p <- readIORef v_Pgm_L
 287                    runSomething "Literate pre-processor" p args
 288
 289 runCpp :: [String] -> IO ()
 290 runCpp args =   do p <- readIORef v_Pgm_P
 291                    runSomething "C pre-processor" p args
 292
 293 runCc :: [String] -> IO ()
 294 runCc args =   do p <- readIORef v_Pgm_c
 295                   runSomething "C Compiler" p args
 296
 297 runMangle :: [String] -> IO ()
 298 runMangle args = do p <- readIORef v_Pgm_m
 299                     runSomething "Mangler" p args
 300
 301 runSplit :: [String] -> IO ()
 302 runSplit args = do p <- readIORef v_Pgm_s
 303                    runSomething "Splitter" p args
 304
 305 runAs :: [String] -> IO ()
 306 runAs args = do p <- readIORef v_Pgm_a
 307                 runSomething "Assembler" p args
 308
 309 runLink :: [String] -> IO ()
 310 runLink args = do p <- readIORef v_Pgm_l
 311                   runSomething "Linker" p args
 312
 313 runMkDLL :: [String] -> IO ()
 314 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 315                    runSomething "Make DLL" p args
 316
 317 touch :: String -> String -> IO ()
 318 touch purpose arg =  do p <- readIORef v_Pgm_T
 319                         runSomething purpose p [arg]
 320
 321 copy :: String -> String -> String -> IO ()
 322 copy purpose from to = do p <- readIORef v_Pgm_CP
 323                           runSomething purpose p [from,to]
 324 \end{code}
 325
 326 \begin{code}
 327 getSysMan :: IO String  -- How to invoke the system manager
 328                         -- (parallel system only)
 329 getSysMan = readIORef v_Pgm_sysman
 330 \end{code}
 331
 332 %************************************************************************
 333 %*                                                                      *
 334 \subsection{GHC Usage message}
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 Show the usage message and exit
 339
 340 \begin{code}
 341 showGhcUsage = do { usage_path <- readIORef v_Path_usage
 342                   ; usage      <- readFile usage_path
 343                   ; dump usage
 344                   ; System.exitWith System.ExitSuccess }
 345   where
 346      dump ""          = return ()
 347      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 348      dump (c:s)       = hPutChar stderr c >> dump s
 349
 350 packageConfigPath = readIORef v_Path_package_config
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection{Managing temporary files
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 One reason this code is here is because SysTools.system needs to make
 361 a temporary file.
 362
 363 \begin{code}
 364 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 365 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 366         -- v_TmpDir has no closing '/'
 367 \end{code}
 368
 369 \begin{code}
 370 setTmpDir dir = writeIORef v_TmpDir dir
 371
 372 cleanTempFiles :: Int -> IO ()
 373 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
 374                          removeTmpFiles verb fs
 375
 376 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
 377 cleanTempFilesExcept verb dont_delete
 378   = do fs <- readIORef v_FilesToClean
 379        let leftovers = filter (`notElem` dont_delete) fs
 380        removeTmpFiles verb leftovers
 381        writeIORef v_FilesToClean dont_delete
 382
 383
 384 -- find a temporary name that doesn't already exist.
 385 newTempName :: Suffix -> IO FilePath
 386 newTempName extn
 387   = do x <- getProcessID
 388        tmp_dir <- readIORef v_TmpDir
 389        findTempName tmp_dir x
 390   where
 391     findTempName tmp_dir x
 392       = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
 393            b  <- doesFileExist filename
 394            if b then findTempName tmp_dir (x+1)
 395                 else do add v_FilesToClean filename -- clean it up later
 396                         return filename
 397
 398 addFilesToClean :: [FilePath] -> IO ()
 399 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 400 addFilesToClean files = mapM_ (add v_FilesToClean) files
 401
 402 removeTmpFiles :: Int -> [FilePath] -> IO ()
 403 removeTmpFiles verb fs
 404   = traceCmd "Deleting temp files"
 405              ("Deleting: " ++ concat (intersperse " " fs))
 406              (mapM_ rm fs)
 407   where
 408     rm f = removeFile f `catchAllIO`
 409                 (\exn -> hPutStrLn stderr ("Warning: deleting non-existent " ++ f) >>
 410                          return ())
 411
 412 \end{code}
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417 \subsection{Running a program}
 418 %*                                                                      *
 419 %************************************************************************
 420
 421 \begin{code}
 422 GLOBAL_VAR(v_Dry_run, False, Bool)
 423
 424 setDryRun :: IO ()
 425 setDryRun = writeIORef v_Dry_run True
 426
 427 -----------------------------------------------------------------------------
 428 -- Running an external program
 429
 430 runSomething :: String          -- For -v message
 431              -> String          -- Command name (possibly a full path)
 432                                 --      assumed already dos-ified
 433              -> [String]        -- Arguments
 434                                 --      runSomthing will dos-ify them
 435              -> IO ()
 436
 437 runSomething phase_name pgm args
 438  = traceCmd phase_name cmd_line $
 439    do   { exit_code <- system cmd_line
 440         ; if exit_code /= ExitSuccess
 441           then throwDyn (PhaseFailed phase_name exit_code)
 442           else return ()
 443         }
 444   where
 445     cmd_line = unwords (pgm : dosifyPaths args)
 446
 447 traceCmd :: String -> String -> IO () -> IO ()
 448 -- a) trace the command (at two levels of verbosity)
 449 -- b) don't do it at all if dry-run is set
 450 traceCmd phase_name cmd_line action
 451  = do   { verb <- dynFlag verbosity
 452         ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 453         ; when (verb >= 3) $ hPutStrLn stderr cmd_line
 454         ; hFlush stderr
 455
 456            -- Test for -n flag
 457         ; n <- readIORef v_Dry_run
 458         ; unless n $ do {
 459
 460            -- And run it!
 461         ; action `catchAllIO` handle_exn verb
 462         }}
 463   where
 464     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
 465                              ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
 466                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 467 \end{code}
 468
 469
 470 %************************************************************************
 471 %*                                                                      *
 472 \subsection{Support code}
 473 %*                                                                      *
 474 %************************************************************************
 475
 476
 477 \begin{code}
 478 -----------------------------------------------------------------------------
 479 -- Convert filepath into MSDOS form.
 480
 481 dosifyPaths :: [String] -> [String]
 482 -- dosifyPath does two things
 483 -- a) change '/' to '\'
 484 -- b) remove initial '/cygdrive/'
 485
 486 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 487 dosifyPaths xs = map dosifyPath xs
 488
 489 dosifyPath  :: String -> String
 490 dosifyPath stuff
 491   = subst '/' '\\' real_stuff
 492  where
 493    -- fully convince myself that /cygdrive/ prefixes cannot
 494    -- really appear here.
 495   cygdrive_prefix = "/cygdrive/"
 496
 497   real_stuff
 498     | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
 499     | otherwise = stuff
 500
 501   subst a b ls = map (\ x -> if x == a then b else x) ls
 502 #else
 503 dosifyPaths xs = xs
 504 #endif
 505
 506 -----------------------------------------------------------------------------
 507 -- Path name construction
 508 --      At the moment, we always use '/' and rely on dosifyPath
 509 --      to switch to DOS pathnames when necessary
 510
 511 slash            :: String -> String -> String
 512 absPath, relPath :: [String] -> String
 513
 514 slash s1 s2 = s1 ++ ('/' : s2)
 515
 516
 517 relPath [] = ""
 518 relPath xs = foldr1 slash xs
 519
 520 absPath xs = "" `slash` relPath xs
 521
 522 -----------------------------------------------------------------------------
 523 -- Convert filepath into MSDOS form.
 524 --
 525 -- Define       myGetProcessId :: IO Int
 526
 527 #ifdef mingw32_TARGET_OS
 528 foreign import "_getpid" getProcessID :: IO Int
 529 #else
 530 getProcessID :: IO Int
 531 getProcessID = Posix.getProcessID
 532 #endif
 533 \end{code}
 534
 535
 536 %************************************************************************
 537 %*                                                                      *
 538 \subsection{System}
 539 %*                                                                      *
 540 %************************************************************************
 541
 542 -- This procedure executes system calls.  In pre-GHC-5.00 and earlier,
 543 -- the System.system implementation didn't work, so this acts as a fix-up
 544 -- by passing the command line to 'sh'.
 545 \begin{code}
 546 system :: String -> IO ExitCode
 547 system cmd
 548  = do
 549 #if !defined(mingw32_TARGET_OS)
 550     -- in the case where we do want to use an MSDOS command shell, we assume
 551     -- that files and paths have been converted to a form that's
 552     -- understandable to the command we're invoking.
 553    System.system cmd
 554 #else
 555    tmp <- newTempName "sh"
 556    h   <- openFile tmp WriteMode
 557    hPutStrLn h cmd
 558    hClose h
 559    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 560                        (\exn -> removeFile tmp >> ioError exn)
 561    removeFile tmp
 562    return exit_code
 563 #endif
 564 \end{code}