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