ghc/compiler/main/Main.hs

   1 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- GHC Driver program
   5 --
   6 -- (c) The University of Glasgow 2005
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module Main (main) where
  11
  12 #include "HsVersions.h"
  13
  14 #ifdef GHCI
  15 import InteractiveUI    ( ghciWelcomeMsg, interactiveUI )
  16 #endif
  17
  18
  19 import MkIface          ( showIface )
  20 import CompManager      ( cmInit, cmLoadModules, cmDepAnal )
  21 import Config
  22 import SysTools
  23 import Packages         ( dumpPackages, initPackages, haskell98PackageId,
  24                           PackageIdH(..) )
  25 import DriverPipeline   ( runPipeline, staticLink, doMkDLL )
  26
  27 import DriverMkDepend   ( doMkDependHS )
  28 import DriverPhases     ( Phase(..), isStopLn, isSourceFilename, anyHsc )
  29
  30 import DynFlags
  31 import StaticFlags      ( parseStaticFlags, staticFlags, v_Ld_inputs )
  32 import CmdLineParser
  33 import BasicTypes       ( failed )
  34 import Util
  35 import Panic
  36
  37 -- Standard Haskell libraries
  38 import EXCEPTION        ( throwDyn, Exception(..),
  39                           AsyncException(StackOverflow) )
  40
  41 import IO
  42 import Directory        ( doesFileExist, doesDirectoryExist )
  43 import System           ( getArgs, exitWith, ExitCode(..) )
  44 import Monad
  45 import List
  46 import Maybe
  47
  48 -----------------------------------------------------------------------------
  49 -- ToDo:
  50
  51 -- time commands when run with -v
  52 -- user ways
  53 -- Win32 support: proper signal handling
  54 -- reading the package configuration file is too slow
  55 -- -K<size>
  56
  57 -----------------------------------------------------------------------------
  58 -- Main loop
  59
  60 main =
  61   ---------------------------------------
  62   -- exception handlers
  63
  64   -- top-level exception handler: any unrecognised exception is a compiler bug.
  65   handle (\exception -> do
  66            hFlush stdout
  67            case exception of
  68                 -- an IO exception probably isn't our fault, so don't panic
  69                 IOException _ ->  hPutStrLn stderr (show exception)
  70                 AsyncException StackOverflow ->
  71                         hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
  72                 _other ->  hPutStr stderr (show (Panic (show exception)))
  73            exitWith (ExitFailure 1)
  74          ) $ do
  75
  76   -- all error messages are propagated as exceptions
  77   handleDyn (\dyn -> do
  78                 hFlush stdout
  79                 case dyn of
  80                      PhaseFailed _ code -> exitWith code
  81                      Interrupted -> exitWith (ExitFailure 1)
  82                      _ -> do hPutStrLn stderr (show (dyn :: GhcException))
  83                              exitWith (ExitFailure 1)
  84             ) $ do
  85
  86    installSignalHandlers
  87
  88    ----------------------------------------
  89    -- command-line parsing
  90    argv0 <- getArgs
  91
  92    -- 1. we grab the -B option if there is one
  93    let (minusB_args, argv1) = partition (prefixMatch "-B") argv0
  94    dflags0 <- initSysTools minusB_args defaultDynFlags
  95
  96    -- 2. Parse the "mode" flags (--make, --interactive etc.)
  97    (cli_mode, argv2) <- parseModeFlags argv1
  98
  99    -- 3. Parse the static flags
 100    argv3 <- parseStaticFlags argv2
 101
 102    -- 4. Parse the dynamic flags
 103    dflags1 <- initDynFlags dflags0
 104
 105    -- set the default HscTarget.  The HscTarget can be further
 106    -- adjusted on a module by module basis, using only the -fvia-C and
 107    -- -fasm flags.  If the default HscTarget is not HscC or HscAsm,
 108    -- -fvia-C and -fasm have no effect.
 109    let lang = case cli_mode of
 110                  DoInteractive  -> HscInterpreted
 111                  DoEval _       -> HscInterpreted
 112                  _other         -> hscTarget dflags1
 113
 114    let mode = case cli_mode of
 115                 DoInteractive   -> Interactive
 116                 DoEval _        -> Interactive
 117                 DoMake          -> BatchCompile
 118                 DoMkDependHS    -> MkDepend
 119                 _               -> OneShot
 120
 121    let dflags2 = dflags1{ ghcMode = mode,
 122                           hscTarget  = lang,
 123                           -- leave out hscOutName for now
 124                           hscOutName = panic "Main.main:hscOutName not set",
 125                           verbosity = case cli_mode of
 126                                          DoEval _ -> 0
 127                                          _other   -> 1
 128                         }
 129
 130         -- The rest of the arguments are "dynamic"
 131         -- Leftover ones are presumably files
 132    (dflags3, fileish_args) <- parseDynamicFlags dflags2 argv3
 133
 134         -- make sure we clean up after ourselves
 135    later (unless (dopt Opt_KeepTmpFiles dflags3) $
 136             cleanTempFiles dflags3) $ do
 137         -- exceptions will be blocked while we clean the temporary files,
 138         -- so there shouldn't be any difficulty if we receive further
 139         -- signals.
 140
 141         -- Display banner
 142    showBanner cli_mode dflags3
 143
 144         -- Read the package config(s), and process the package-related
 145         -- command-line flags
 146    dflags <- initPackages dflags3
 147
 148    let
 149     {-
 150       We split out the object files (.o, .dll) and add them
 151       to v_Ld_inputs for use by the linker.
 152
 153       The following things should be considered compilation manager inputs:
 154
 155        - haskell source files (strings ending in .hs, .lhs or other
 156          haskellish extension),
 157
 158        - module names (not forgetting hierarchical module names),
 159
 160        - and finally we consider everything not containing a '.' to be
 161          a comp manager input, as shorthand for a .hs or .lhs filename.
 162
 163       Everything else is considered to be a linker object, and passed
 164       straight through to the linker.
 165     -}
 166     looks_like_an_input m =  isSourceFilename m
 167                           || looksLikeModuleName m
 168                           || '.' `notElem` m
 169
 170      -- To simplify the handling of filepaths, we normalise all filepaths right
 171      -- away - e.g., for win32 platforms, backslashes are converted
 172      -- into forward slashes.
 173     normal_fileish_paths = map normalisePath fileish_args
 174     (srcs, objs)         = partition looks_like_an_input normal_fileish_paths
 175
 176     -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
 177     --       the command-line.
 178    mapM_ (consIORef v_Ld_inputs) (reverse objs)
 179
 180         ---------------- Display configuration -----------
 181    when (verbosity dflags >= 4) $
 182         dumpPackages dflags
 183
 184    when (verbosity dflags >= 3) $ do
 185         hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
 186
 187         ---------------- Final sanity checking -----------
 188    checkOptions cli_mode dflags srcs objs
 189
 190         ---------------- Do the business -----------
 191    case cli_mode of
 192         ShowUsage       -> showGhcUsage cli_mode
 193         PrintLibdir     -> do d <- getTopDir; putStrLn d
 194         ShowVersion     -> showVersion
 195         ShowNumVersion  -> putStrLn cProjectVersion
 196         ShowInterface f -> showIface f
 197         DoMake          -> doMake dflags srcs
 198         DoMkDependHS    -> doMkDependHS dflags srcs
 199         StopBefore p    -> oneShot dflags p srcs
 200         DoInteractive   -> interactiveUI dflags srcs Nothing
 201         DoEval expr     -> interactiveUI dflags srcs (Just expr)
 202
 203    exitWith ExitSuccess
 204
 205 #ifndef GHCI
 206 interactiveUI _ _ _ =
 207   throwDyn (CmdLineError "not built for interactive use")
 208 #endif
 209
 210
 211 -- -----------------------------------------------------------------------------
 212 -- Option sanity checks
 213
 214 checkOptions :: CmdLineMode -> DynFlags -> [String] -> [String] -> IO ()
 215      -- Final sanity checking before kicking off a compilation (pipeline).
 216 checkOptions cli_mode dflags srcs objs = do
 217      -- Complain about any unknown flags
 218    let unknown_opts = [ f | f@('-':_) <- srcs ]
 219    when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
 220
 221         -- -prof and --interactive are not a good combination
 222    when (notNull (wayNames dflags)  && isInterpretiveMode cli_mode) $
 223       do throwDyn (UsageError
 224                    "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
 225         -- -ohi sanity check
 226    if (isJust (outputHi dflags) &&
 227       (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))
 228         then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
 229         else do
 230
 231         -- -o sanity checking
 232    if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
 233          && not (isLinkMode cli_mode))
 234         then throwDyn (UsageError "can't apply -o to multiple source files")
 235         else do
 236
 237         -- Check that there are some input files
 238         -- (except in the interactive case)
 239    if null srcs && null objs && not (isInterpretiveMode cli_mode)
 240         then throwDyn (UsageError "no input files")
 241         else do
 242
 243      -- Verify that output files point somewhere sensible.
 244    verifyOutputFiles dflags
 245
 246
 247 -- Compiler output options
 248
 249 -- called to verify that the output files & directories
 250 -- point somewhere valid.
 251 --
 252 -- The assumption is that the directory portion of these output
 253 -- options will have to exist by the time 'verifyOutputFiles'
 254 -- is invoked.
 255 --
 256 verifyOutputFiles :: DynFlags -> IO ()
 257 verifyOutputFiles dflags = do
 258   let odir = outputDir dflags
 259   when (isJust odir) $ do
 260      let dir = fromJust odir
 261      flg <- doesDirectoryExist dir
 262      when (not flg) (nonExistentDir "-odir" dir)
 263   let ofile = outputFile dflags
 264   when (isJust ofile) $ do
 265      let fn = fromJust ofile
 266      flg <- doesDirNameExist fn
 267      when (not flg) (nonExistentDir "-o" fn)
 268   let ohi = outputHi dflags
 269   when (isJust ohi) $ do
 270      let hi = fromJust ohi
 271      flg <- doesDirNameExist hi
 272      when (not flg) (nonExistentDir "-ohi" hi)
 273  where
 274    nonExistentDir flg dir =
 275      throwDyn (CmdLineError ("error: directory portion of " ++
 276                              show dir ++ " does not exist (used with " ++
 277                              show flg ++ " option.)"))
 278
 279 -----------------------------------------------------------------------------
 280 -- GHC modes of operation
 281
 282 data CmdLineMode
 283   = ShowUsage                   -- ghc -?
 284   | PrintLibdir                 -- ghc --print-libdir
 285   | ShowVersion                 -- ghc -V/--version
 286   | ShowNumVersion              -- ghc --numeric-version
 287   | ShowInterface String        -- ghc --show-iface
 288   | DoMkDependHS                -- ghc -M
 289   | StopBefore Phase            -- ghc -E | -C | -S
 290                                 -- StopBefore StopLn is the default
 291   | DoMake                      -- ghc --make
 292   | DoInteractive               -- ghc --interactive
 293   | DoEval String               -- ghc -e
 294   deriving (Show)
 295
 296 isInteractiveMode, isInterpretiveMode     :: CmdLineMode -> Bool
 297 isLinkMode, isCompManagerMode :: CmdLineMode -> Bool
 298
 299 isInteractiveMode DoInteractive = True
 300 isInteractiveMode _             = False
 301
 302 -- isInterpretiveMode: byte-code compiler involved
 303 isInterpretiveMode DoInteractive = True
 304 isInterpretiveMode (DoEval _)    = True
 305 isInterpretiveMode _             = False
 306
 307 -- True if we are going to attempt to link in this mode.
 308 -- (we might not actually link, depending on the GhcLink flag)
 309 isLinkMode (StopBefore StopLn) = True
 310 isLinkMode DoMake              = True
 311 isLinkMode _                   = False
 312
 313 isCompManagerMode DoMake        = True
 314 isCompManagerMode DoInteractive = True
 315 isCompManagerMode (DoEval _)    = True
 316 isCompManagerMode _             = False
 317
 318
 319 -- -----------------------------------------------------------------------------
 320 -- Parsing the mode flag
 321
 322 parseModeFlags :: [String] -> IO (CmdLineMode, [String])
 323 parseModeFlags args = do
 324   let ((leftover, errs), (mode, _, flags)) =
 325          runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", [])
 326   when (not (null errs)) $ do
 327     throwDyn (UsageError (unlines errs))
 328   return (mode, flags ++ leftover)
 329
 330 type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
 331   -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
 332   -- so we collect the new ones and return them.
 333
 334 mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
 335 mode_flags =
 336   [  ------- help / version ----------------------------------------------
 337      ( "?"               , PassFlag (setMode ShowUsage))
 338   ,  ( "-help"           , PassFlag (setMode ShowUsage))
 339   ,  ( "-print-libdir"   , PassFlag (setMode PrintLibdir))
 340   ,  ( "V"               , PassFlag (setMode ShowVersion))
 341   ,  ( "-version"        , PassFlag (setMode ShowVersion))
 342   ,  ( "-numeric-version", PassFlag (setMode ShowNumVersion))
 343
 344       ------- interfaces ----------------------------------------------------
 345   ,  ( "-show-iface"     , HasArg (\f -> setMode (ShowInterface f)
 346                                           "--show-iface"))
 347
 348       ------- primary modes ------------------------------------------------
 349   ,  ( "M"              , PassFlag (setMode DoMkDependHS))
 350   ,  ( "E"              , PassFlag (setMode (StopBefore anyHsc)))
 351   ,  ( "C"              , PassFlag (\f -> do setMode (StopBefore HCc) f
 352                                              addFlag "-fvia-C"))
 353   ,  ( "S"              , PassFlag (setMode (StopBefore As)))
 354   ,  ( "-make"          , PassFlag (setMode DoMake))
 355   ,  ( "-interactive"   , PassFlag (setMode DoInteractive))
 356   ,  ( "e"              , HasArg   (\s -> setMode (DoEval s) "-e"))
 357
 358         -- -fno-code says to stop after Hsc but don't generate any code.
 359   ,  ( "fno-code"       , PassFlag (\f -> do setMode (StopBefore HCc) f
 360                                              addFlag "-fno-code"
 361                                              addFlag "-no-recomp"))
 362   ]
 363
 364 setMode :: CmdLineMode -> String -> ModeM ()
 365 setMode m flag = do
 366   (old_mode, old_flag, flags) <- getCmdLineState
 367   when (notNull old_flag && flag /= old_flag) $
 368       throwDyn (UsageError
 369           ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
 370   putCmdLineState (m, flag, flags)
 371
 372 addFlag :: String -> ModeM ()
 373 addFlag s = do
 374   (m, f, flags) <- getCmdLineState
 375   putCmdLineState (m, f, s:flags)
 376
 377
 378 -- -----------------------------------------------------------------------------
 379 -- Compile files in one-shot mode.
 380
 381 oneShot :: DynFlags -> Phase -> [String] -> IO ()
 382 oneShot dflags stop_phase srcs = do
 383         o_files <- compileFiles stop_phase dflags srcs
 384         doLink dflags stop_phase o_files
 385
 386 compileFiles :: Phase
 387              -> DynFlags
 388              -> [String]        -- Source files
 389              -> IO [String]     -- Object files
 390 compileFiles stop_phase dflags srcs
 391   = mapM (compileFile stop_phase dflags) srcs
 392
 393 compileFile :: Phase -> DynFlags -> FilePath -> IO FilePath
 394 compileFile stop_phase dflags src = do
 395    exists <- doesFileExist src
 396    when (not exists) $
 397         throwDyn (CmdLineError ("does not exist: " ++ src))
 398
 399    let
 400         split    = dopt Opt_SplitObjs dflags
 401         o_file   = outputFile dflags
 402         ghc_link = ghcLink dflags       -- Set by -c or -no-link
 403
 404         -- When linking, the -o argument refers to the linker's output.
 405         -- otherwise, we use it as the name for the pipeline's output.
 406         maybe_o_file
 407          | StopLn <- stop_phase, not (isNoLink ghc_link) = Nothing
 408                 -- -o foo applies to linker
 409          | otherwise = o_file
 410                 -- -o foo applies to the file we are compiling now
 411
 412         stop_phase' = case stop_phase of
 413                         As | split -> SplitAs
 414                         other      -> stop_phase
 415
 416    (_, out_file) <- runPipeline stop_phase' dflags
 417                          True maybe_o_file src Nothing{-no ModLocation-}
 418    return out_file
 419
 420
 421 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
 422 doLink dflags stop_phase o_files
 423   | not (isStopLn stop_phase)
 424   = return ()           -- We stopped before the linking phase
 425
 426   | otherwise
 427   = case ghcLink dflags of
 428         NoLink     -> return ()
 429         StaticLink -> staticLink dflags o_files link_pkgs
 430         MkDLL      -> doMkDLL dflags o_files link_pkgs
 431   where
 432    -- Always link in the haskell98 package for static linking.  Other
 433    -- packages have to be specified via the -package flag.
 434     link_pkgs
 435           | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id]
 436           | otherwise = []
 437
 438
 439 -- ----------------------------------------------------------------------------
 440 -- Run --make mode
 441
 442 doMake :: DynFlags -> [String] -> IO ()
 443 doMake dflags []    = throwDyn (UsageError "no input files")
 444 doMake dflags srcs  = do
 445     state  <- cmInit dflags
 446     graph  <- cmDepAnal state srcs
 447     (_, ok_flag, _) <- cmLoadModules state graph
 448     when (failed ok_flag) (exitWith (ExitFailure 1))
 449     return ()
 450
 451
 452 -- ---------------------------------------------------------------------------
 453 -- Various banners and verbosity output.
 454
 455 showBanner :: CmdLineMode -> DynFlags -> IO ()
 456 showBanner cli_mode dflags = do
 457    let verb = verbosity dflags
 458         -- Show the GHCi banner
 459 #  ifdef GHCI
 460    when (isInteractiveMode mode && verb >= 1) $
 461       hPutStrLn stdout ghciWelcomeMsg
 462 #  endif
 463
 464         -- Display details of the configuration in verbose mode
 465    when (not (isInteractiveMode cli_mode) && verb >= 2) $
 466         do hPutStr stderr "Glasgow Haskell Compiler, Version "
 467            hPutStr stderr cProjectVersion
 468            hPutStr stderr ", for Haskell 98, compiled by GHC version "
 469            hPutStrLn stderr cBooterVersion
 470
 471 showVersion :: IO ()
 472 showVersion = do
 473   putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
 474   exitWith ExitSuccess
 475
 476 showGhcUsage cli_mode = do
 477   (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
 478   let usage_path
 479         | DoInteractive <- cli_mode = ghci_usage_path
 480         | otherwise                 = ghc_usage_path
 481   usage <- readFile usage_path
 482   dump usage
 483   exitWith ExitSuccess
 484   where
 485      dump ""          = return ()
 486      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 487      dump (c:s)       = hPutChar stderr c >> dump s
 488
 489 -- -----------------------------------------------------------------------------
 490 -- Util
 491
 492 unknownFlagsErr :: [String] -> a
 493 unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))