Main.hs 28.7 KB
Newer Older
1
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
2

3 4 5 6
-----------------------------------------------------------------------------
--
-- GHC Driver program
--
7
-- (c) The University of Glasgow 2005
8 9 10 11 12
--
-----------------------------------------------------------------------------

module Main (main) where

13 14
-- The official GHC API
import qualified GHC
15 16
import GHC		( -- DynFlags(..), HscTarget(..),
                          -- GhcMode(..), GhcLink(..),
17 18
                          Ghc, GhcMonad(..),
			  LoadHowMuch(..) )
19
import CmdLineParser
20

21
-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
22
import LoadIface	( showIface )
23
import HscMain          ( newHscEnv )
24
import DriverPipeline	( oneShot, compileFile )
25
import DriverMkDepend	( doMkDependHS )
26
#ifdef GHCI
27
import InteractiveUI	( interactiveUI, ghciWelcomeMsg )
28
#endif
29

30

31
-- Various other random stuff that we need
Ian Lynagh's avatar
Ian Lynagh committed
32
import Config
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
33
import HscTypes
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
34
import Packages		( dumpPackages )
35
import DriverPhases	( Phase(..), isSourceFilename, anyHsc,
36
			  startPhase, isHaskellSrcFilename )
Thomas Schilling's avatar
Thomas Schilling committed
37
import BasicTypes       ( failed )
38
import StaticFlags
39
import StaticFlagParser
Ian Lynagh's avatar
Ian Lynagh committed
40
import DynFlags
41
import ErrUtils
Ian Lynagh's avatar
Ian Lynagh committed
42
import FastString
43
import Outputable
44
import SrcLoc
45
import Util
46
import Panic
47
import MonadUtils       ( liftIO )
48

49 50 51 52 53 54 55
-- Imports for --abi-hash
import LoadIface           ( loadUserInterface )
import Module              ( mkModuleName )
import Finder              ( findImportedModule, cannotFindInterface )
import TcRnMonad           ( initIfaceCheck )
import Binary              ( openBinMem, put_, fingerprintBinMem )

56
-- Standard Haskell libraries
Simon Marlow's avatar
Simon Marlow committed
57 58 59
import System.IO
import System.Environment
import System.Exit
Ian Lynagh's avatar
Ian Lynagh committed
60
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
61
import Control.Monad
62
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
63 64
import Data.List
import Data.Maybe
65

66 67 68 69 70 71 72
-----------------------------------------------------------------------------
-- ToDo:

-- time commands when run with -v
-- user ways
-- Win32 support: proper signal handling
-- reading the package configuration file is too slow
73
-- -K<size>
74 75

-----------------------------------------------------------------------------
76
-- GHC's command-line interface
77

Ian Lynagh's avatar
Ian Lynagh committed
78
main :: IO ()
79 80
main = do
   hSetBuffering stdout NoBuffering
81
   GHC.defaultErrorHandler defaultLogAction $ do
82 83
    -- 1. extract the -B flag from the args
    argv0 <- getArgs
84

85
    let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
86 87 88
        mbMinusB | null minusB_args = Nothing
                 | otherwise = Just (drop 2 (last minusB_args))

89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
    let argv1' = map (mkGeneralLocated "on the commandline") argv1
    (argv2, staticFlagWarnings) <- parseStaticFlags argv1'

    -- 2. Parse the "mode" flags (--make, --interactive etc.)
    (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2

    let flagWarnings = staticFlagWarnings ++ modeFlagWarnings

    -- If all we want to do is something like showing the version number
    -- then do it now, before we start a GHC session etc. This makes
    -- getting basic information much more resilient.

    -- In particular, if we wait until later before giving the version
    -- number then bootstrapping gets confused, as it tries to find out
    -- what version of GHC it's using before package.conf exists, so
    -- starting the session fails.
    case mode of
        Left preStartupMode ->
            do case preStartupMode of
108
                   ShowSupportedExtensions -> showSupportedExtensions
109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
                   ShowVersion             -> showVersion
                   ShowNumVersion          -> putStrLn cProjectVersion
                   Print str               -> putStrLn str
        Right postStartupMode ->
            -- start our GHC session
            GHC.runGhc mbMinusB $ do

            dflags <- GHC.getSessionDynFlags

            case postStartupMode of
                Left preLoadMode ->
                    liftIO $ do
                        case preLoadMode of
                            ShowInfo               -> showInfo dflags
                            ShowGhcUsage           -> showGhcUsage  dflags
                            ShowGhciUsage          -> showGhciUsage dflags
                            PrintWithDynFlags f    -> putStrLn (f dflags)
                Right postLoadMode ->
                    main' postLoadMode dflags argv3 flagWarnings

main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
      -> Ghc ()
main' postLoadMode dflags0 args flagWarnings = do
132 133 134 135 136 137
  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
  -- can be further adjusted on a module by module basis, using only
  -- the -fvia-C and -fasm flags.  If the default HscTarget is not
  -- HscC or HscAsm, -fvia-C and -fasm have no effect.
  let dflt_target = hscTarget dflags0
      (mode, lang, link)
138 139 140 141 142
         = case postLoadMode of
               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
               DoMake          -> (CompManager, dflt_target,    LinkBinary)
               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
143
               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
144
               _               -> (OneShot,     dflt_target,    LinkBinary)
145 146

  let dflags1 = dflags0{ ghcMode   = mode,
147
                         hscTarget = lang,
148
                         ghcLink   = link,
149
                         -- leave out hscOutName for now
Thomas Schilling's avatar
Thomas Schilling committed
150
                         hscOutName = panic "Main.main:hscOutName not set",
151 152 153 154
                         verbosity = case postLoadMode of
                                         DoEval _ -> 0
                                         _other   -> 1
                        }
155

156 157
      -- turn on -fimplicit-import-qualified for GHCi now, so that it
      -- can be overriden from the command-line
158 159
      dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled
               | DoEval _      <- postLoadMode = imp_qual_enabled
160 161 162
               | otherwise                 = dflags1
        where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified

Thomas Schilling's avatar
Thomas Schilling committed
163 164
        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
165
  (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
166

167
  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
168 169

  handleSourceError (\e -> do
170 171 172
       GHC.printException e
       liftIO $ exitWith (ExitFailure 1)) $ do
         liftIO $ handleFlagWarnings dflags2 flagWarnings'
173

Thomas Schilling's avatar
Thomas Schilling committed
174
        -- make sure we clean up after ourselves
Ian Lynagh's avatar
Ian Lynagh committed
175
  GHC.defaultCleanupHandler dflags2 $ do
176

177
  liftIO $ showBanner postLoadMode dflags2
178

179
  -- we've finished manipulating the DynFlags, update the session
180
  _ <- GHC.setSessionDynFlags dflags2
Thomas Schilling's avatar
Thomas Schilling committed
181 182
  dflags3 <- GHC.getSessionDynFlags
  hsc_env <- GHC.getSession
183 184

  let
dterei's avatar
dterei committed
185
     -- To simplify the handling of filepaths, we normalise all filepaths right
sof's avatar
sof committed
186
     -- away - e.g., for win32 platforms, backslashes are converted
sof's avatar
sof committed
187
     -- into forward slashes.
188
    normal_fileish_paths = map (normalise . unLoc) fileish_args
189
    (srcs, objs)         = partition_args normal_fileish_paths [] []
190

dterei's avatar
dterei committed
191
  -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
192
  --       the command-line.
Thomas Schilling's avatar
Thomas Schilling committed
193
  liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)
194

Thomas Schilling's avatar
Thomas Schilling committed
195
        ---------------- Display configuration -----------
Ian Lynagh's avatar
Ian Lynagh committed
196
  when (verbosity dflags3 >= 4) $
Thomas Schilling's avatar
Thomas Schilling committed
197
        liftIO $ dumpPackages dflags3
198

Ian Lynagh's avatar
Ian Lynagh committed
199
  when (verbosity dflags3 >= 3) $ do
Thomas Schilling's avatar
Thomas Schilling committed
200
        liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
201

Thomas Schilling's avatar
Thomas Schilling committed
202
        ---------------- Final sanity checking -----------
203
  liftIO $ checkOptions postLoadMode dflags3 srcs objs
204

Ian Lynagh's avatar
Ian Lynagh committed
205
  ---------------- Do the business -----------
Thomas Schilling's avatar
Thomas Schilling committed
206
  handleSourceError (\e -> do
207
       GHC.printException e
208
       liftIO $ exitWith (ExitFailure 1)) $ do
209
    case postLoadMode of
Thomas Schilling's avatar
Thomas Schilling committed
210 211
       ShowInterface f        -> liftIO $ doShowIface dflags3 f
       DoMake                 -> doMake srcs
212 213
       DoMkDependHS           -> doMkDependHS (map fst srcs)
       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
Thomas Schilling's avatar
Thomas Schilling committed
214 215
       DoInteractive          -> interactiveUI srcs Nothing
       DoEval exprs           -> interactiveUI srcs $ Just $ reverse exprs
216
       DoAbiHash              -> abiHash srcs
Thomas Schilling's avatar
Thomas Schilling committed
217 218

  liftIO $ dumpFinalStats dflags3
219

220
#ifndef GHCI
Thomas Schilling's avatar
Thomas Schilling committed
221 222
interactiveUI :: b -> c -> Ghc ()
interactiveUI _ _ =
223
  ghcError (CmdLineError "not built for interactive use")
224 225
#endif

226 227 228 229 230
-- -----------------------------------------------------------------------------
-- Splitting arguments into source files and object files.  This is where we
-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
-- file indicating the phase specified by the -x option in force, if any.

Ian Lynagh's avatar
Ian Lynagh committed
231 232
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
233 234 235 236 237 238
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
  | "none" <- suff	= partition_args args srcs objs
  | StopLn <- phase	= partition_args args srcs (slurp ++ objs)
  | otherwise		= partition_args rest (these_srcs ++ srcs) objs
	where phase = startPhase suff
dterei's avatar
dterei committed
239
	      (slurp,rest) = break (== "-x") args
240 241 242 243 244 245 246 247 248 249 250
	      these_srcs = zip slurp (repeat (Just phase))
partition_args (arg:args) srcs objs
  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
  | otherwise               = partition_args args srcs (arg:objs)

    {-
      We split out the object files (.o, .dll) and add them
      to v_Ld_inputs for use by the linker.

      The following things should be considered compilation manager inputs:

dterei's avatar
dterei committed
251
       - haskell source files (strings ending in .hs, .lhs or other
252 253 254 255 256 257 258 259 260 261
         haskellish extension),

       - module names (not forgetting hierarchical module names),

       - and finally we consider everything not containing a '.' to be
         a comp manager input, as shorthand for a .hs or .lhs filename.

      Everything else is considered to be a linker object, and passed
      straight through to the linker.
    -}
Ian Lynagh's avatar
Ian Lynagh committed
262
looks_like_an_input :: String -> Bool
dterei's avatar
dterei committed
263
looks_like_an_input m =  isSourceFilename m
264 265
		      || looksLikeModuleName m
		      || '.' `notElem` m
266

267 268 269
-- -----------------------------------------------------------------------------
-- Option sanity checks

Thomas Schilling's avatar
Thomas Schilling committed
270 271 272
-- | Ensure sanity of options.
--
-- Throws 'UsageError' or 'CmdLineError' if not.
273
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
274
     -- Final sanity checking before kicking off a compilation (pipeline).
275
checkOptions mode dflags srcs objs = do
ross's avatar
ross committed
276
     -- Complain about any unknown flags
277
   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
ross's avatar
ross committed
278 279
   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)

280
   when (notNull (filter isRTSWay (wayNames dflags))
281
         && isInterpretiveMode mode) $
282
        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
283

284
	-- -prof and --interactive are not a good combination
285
   when (notNull (filter (not . isRTSWay) (wayNames dflags))
286
         && isInterpretiveMode mode) $
dterei's avatar
dterei committed
287
      do ghcError (UsageError
288
                   "--interactive can't be used with -prof or -unreg.")
289
	-- -ohi sanity check
dterei's avatar
dterei committed
290
   if (isJust (outputHi dflags) &&
291
      (isCompManagerMode mode || srcs `lengthExceeds` 1))
292
	then ghcError (UsageError "-ohi can only be used when compiling a single source file")
293 294 295
	else do

	-- -o sanity checking
296
   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
297
	 && not (isLinkMode mode))
298
	then ghcError (UsageError "can't apply -o to multiple source files")
299
	else do
300

301
   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
302 303 304 305

   when (not_linking && not (null objs)) $
        hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)

306 307
	-- Check that there are some input files
	-- (except in the interactive case)
308
   if null srcs && (null objs || not_linking) && needsInputsMode mode
309
	then ghcError (UsageError "no input files")
310 311 312
	else do

     -- Verify that output files point somewhere sensible.
313 314 315 316 317 318
   verifyOutputFiles dflags


-- Compiler output options

-- called to verify that the output files & directories
dterei's avatar
dterei committed
319
-- point somewhere valid.
320 321 322 323
--
-- The assumption is that the directory portion of these output
-- options will have to exist by the time 'verifyOutputFiles'
-- is invoked.
dterei's avatar
dterei committed
324
--
325 326
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles dflags = do
327
  -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
328 329 330 331 332 333 334 335 336 337 338
  let ofile = outputFile dflags
  when (isJust ofile) $ do
     let fn = fromJust ofile
     flg <- doesDirNameExist fn
     when (not flg) (nonExistentDir "-o" fn)
  let ohi = outputHi dflags
  when (isJust ohi) $ do
     let hi = fromJust ohi
     flg <- doesDirNameExist hi
     when (not flg) (nonExistentDir "-ohi" hi)
 where
dterei's avatar
dterei committed
339 340 341
   nonExistentDir flg dir =
     ghcError (CmdLineError ("error: directory portion of " ++
                             show dir ++ " does not exist (used with " ++
342 343 344 345 346
			     show flg ++ " option.)"))

-----------------------------------------------------------------------------
-- GHC modes of operation

347 348 349 350 351
type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode

data PreStartupMode
  = ShowVersion             -- ghc -V/--version
Ian Lynagh's avatar
Ian Lynagh committed
352
  | ShowNumVersion          -- ghc --numeric-version
353
  | ShowSupportedExtensions -- ghc --supported-extensions
354 355
  | Print String            -- ghc --print-foo

356 357 358 359
showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
showVersionMode             = mkPreStartupMode ShowVersion
showNumVersionMode          = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382

mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = Left

isShowVersionMode :: Mode -> Bool
isShowVersionMode (Left ShowVersion) = True
isShowVersionMode _ = False

isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode (Left ShowNumVersion) = True
isShowNumVersionMode _ = False

data PreLoadMode
  = ShowGhcUsage                           -- ghc -?
  | ShowGhciUsage                          -- ghci -?
  | ShowInfo                               -- ghc --info
  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo

showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
showGhcUsageMode = mkPreLoadMode ShowGhcUsage
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
showInfoMode = mkPreLoadMode ShowInfo

383 384 385 386
printSetting :: String -> Mode
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
                   $ lookup k (compilerInfo dflags)
387 388 389 390 391 392 393 394 395 396 397

mkPreLoadMode :: PreLoadMode -> Mode
mkPreLoadMode = Right . Left

isShowGhcUsageMode :: Mode -> Bool
isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
isShowGhcUsageMode _ = False

isShowGhciUsageMode :: Mode -> Bool
isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
isShowGhciUsageMode _ = False
398

399 400
data PostLoadMode
  = ShowInterface FilePath  -- ghc --show-iface
Ian Lynagh's avatar
Ian Lynagh committed
401 402 403 404 405
  | DoMkDependHS            -- ghc -M
  | StopBefore Phase        -- ghc -E | -C | -S
                            -- StopBefore StopLn is the default
  | DoMake                  -- ghc --make
  | DoInteractive           -- ghc --interactive
Ian Lynagh's avatar
Ian Lynagh committed
406
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
407
  | DoAbiHash               -- ghc --abi-hash
408

Simon Marlow's avatar
Simon Marlow committed
409
doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
410 411 412
doMkDependHSMode = mkPostLoadMode DoMkDependHS
doMakeMode = mkPostLoadMode DoMake
doInteractiveMode = mkPostLoadMode DoInteractive
413
doAbiHashMode = mkPostLoadMode DoAbiHash
414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429

showInterfaceMode :: FilePath -> Mode
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)

stopBeforeMode :: Phase -> Mode
stopBeforeMode phase = mkPostLoadMode (StopBefore phase)

doEvalMode :: String -> Mode
doEvalMode str = mkPostLoadMode (DoEval [str])

mkPostLoadMode :: PostLoadMode -> Mode
mkPostLoadMode = Right . Right

isDoInteractiveMode :: Mode -> Bool
isDoInteractiveMode (Right (Right DoInteractive)) = True
isDoInteractiveMode _ = False
430

431 432 433 434 435 436 437 438
isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopLn))) = True
isStopLnMode _ = False

isDoMakeMode :: Mode -> Bool
isDoMakeMode (Right (Right DoMake)) = True
isDoMakeMode _ = False

Ian Lynagh's avatar
Ian Lynagh committed
439
#ifdef GHCI
440
isInteractiveMode :: PostLoadMode -> Bool
441 442
isInteractiveMode DoInteractive = True
isInteractiveMode _		= False
Ian Lynagh's avatar
Ian Lynagh committed
443
#endif
444 445

-- isInterpretiveMode: byte-code compiler involved
446
isInterpretiveMode :: PostLoadMode -> Bool
447 448 449 450
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _)    = True
isInterpretiveMode _             = False

451
needsInputsMode :: PostLoadMode -> Bool
452 453 454 455 456
needsInputsMode DoMkDependHS	= True
needsInputsMode (StopBefore _)	= True
needsInputsMode DoMake		= True
needsInputsMode _		= False

457 458
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
459
isLinkMode :: PostLoadMode -> Bool
460 461
isLinkMode (StopBefore StopLn) = True
isLinkMode DoMake	       = True
462 463
isLinkMode DoInteractive       = True
isLinkMode (DoEval _)          = True
464 465
isLinkMode _   		       = False

466
isCompManagerMode :: PostLoadMode -> Bool
467 468 469 470 471 472 473 474
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _)    = True
isCompManagerMode _             = False

-- -----------------------------------------------------------------------------
-- Parsing the mode flag

475
parseModeFlags :: [Located String]
476
               -> IO (Mode,
477 478
                      [Located String],
                      [Located String])
479
parseModeFlags args = do
480
  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
481
          runCmdLine (processArgs mode_flags args)
482 483
                     (Nothing, [], [])
      mode = case mModeFlag of
484
             Nothing     -> doMakeMode
485 486
             Just (m, _) -> m
      errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
487
  when (not (null errs)) $ ghcError $ errorsToGhcException errs
488
  return (mode, flags' ++ leftover, warns)
489

490
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
491 492 493
  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
  -- so we collect the new ones and return them.

494
mode_flags :: [Flag ModeM]
495 496
mode_flags =
  [  ------- help / version ----------------------------------------------
497 498 499 500 501 502 503 504
    Flag "?"                     (PassFlag (setMode showGhcUsageMode))
  , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
  , Flag "V"                     (PassFlag (setMode showVersionMode))
  , Flag "-version"              (PassFlag (setMode showVersionMode))
  , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
  , Flag "-info"                 (PassFlag (setMode showInfoMode))
  , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
  , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
505
  ] ++
506
  [ Flag k'                      (PassFlag (setMode (printSetting k)))
507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526
  | k <- ["Project version",
          "Booter version",
          "Stage",
          "Build platform",
          "Host platform",
          "Target platform",
          "Have interpreter",
          "Object splitting supported",
          "Have native code generator",
          "Support SMP",
          "Unregisterised",
          "Tables next to code",
          "RTS ways",
          "Leading underscore",
          "Debug on",
          "LibDir",
          "Global Package DB",
          "C compiler flags",
          "Gcc Linker flags",
          "Ld Linker flags"],
527 528 529 530
    let k' = "-print-" ++ map (replaceSpace . toLower) k
        replaceSpace ' ' = '-'
        replaceSpace c   = c
  ] ++
531
      ------- interfaces ----------------------------------------------------
532
  [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
533
                                               "--show-iface"))
534 535

      ------- primary modes ------------------------------------------------
536 537 538 539 540 541 542 543 544 545 546
  , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
                                            addFlag "-no-link" f))
  , Flag "M"            (PassFlag (setMode doMkDependHSMode))
  , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
  , Flag "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
                                            addFlag "-fvia-C" f))
  , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
  , Flag "-make"        (PassFlag (setMode doMakeMode))
  , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
  , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
  , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
547 548
  ]

549 550
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
551 552 553 554 555 556
    (mModeFlag, errs, flags') <- getCmdLineState
    let (modeFlag', errs') =
            case mModeFlag of
            Nothing -> ((newMode, newFlag), errs)
            Just (oldMode, oldFlag) ->
                case (oldMode, newMode) of
557 558 559 560 561
                    -- -c/--make are allowed together, and mean --make -no-link
                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
                      || isStopLnMode newMode && isDoMakeMode oldMode ->
                      ((doMakeMode, "--make"), [])

562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592
                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    _ | isShowGhcUsageMode oldMode &&
                        isDoInteractiveMode newMode ->
                            ((showGhciUsageMode, oldFlag), [])
                      | isShowGhcUsageMode newMode &&
                        isDoInteractiveMode oldMode ->
                            ((showGhciUsageMode, newFlag), [])
                    -- Otherwise, --help/--version/--numeric-version always win
                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
                      | isDominantFlag newMode -> ((newMode, newFlag), [])
                    -- We need to accumulate eval flags like "-e foo -e bar"
                    (Right (Right (DoEval esOld)),
                     Right (Right (DoEval [eNew]))) ->
                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),
                         errs)
                    -- Saying e.g. --interactive --interactive is OK
                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
                    -- Otherwise, complain
                    _ -> let err = flagMismatchErr oldFlag newFlag
                         in ((oldMode, oldFlag), err : errs)
    putCmdLineState (Just modeFlag', errs', flags')
  where isDominantFlag f = isShowGhcUsageMode   f ||
                           isShowGhciUsageMode  f ||
                           isShowVersionMode    f ||
                           isShowNumVersionMode f

flagMismatchErr :: String -> String -> String
flagMismatchErr oldFlag newFlag
    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"

593 594
addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
595 596 597
  (m, e, flags') <- getCmdLineState
  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
    where loc = "addFlag by " ++ flag ++ " on the commandline"
598

599 600 601
-- ----------------------------------------------------------------------------
-- Run --make mode

Thomas Schilling's avatar
Thomas Schilling committed
602 603
doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake srcs  = do
604 605
    let (hs_srcs, non_hs_srcs) = partition haskellish srcs

dterei's avatar
dterei committed
606
	haskellish (f,Nothing) =
607
	  looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
dterei's avatar
dterei committed
608
	haskellish (_,Just phase) =
609
	  phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
610

Thomas Schilling's avatar
Thomas Schilling committed
611
    hsc_env <- GHC.getSession
612 613 614 615 616 617

    -- if we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    if (null hs_srcs)
618
       then liftIO (oneShot hsc_env StopLn srcs)
619 620
       else do

621
    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
Thomas Schilling's avatar
Thomas Schilling committed
622 623
                 non_hs_srcs
    liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
624 625

    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
Thomas Schilling's avatar
Thomas Schilling committed
626 627 628 629
    GHC.setTargets targets
    ok_flag <- GHC.load LoadAllTargets

    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
630 631
    return ()

632 633 634 635 636 637

-- ---------------------------------------------------------------------------
-- --show-iface mode

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
638
  hsc_env <- newHscEnv dflags
639 640
  showIface hsc_env file

641 642
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
643

644 645
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner _postLoadMode dflags = do
646
   let verb = verbosity dflags
Ian Lynagh's avatar
Ian Lynagh committed
647

648 649
#ifdef GHCI
   -- Show the GHCi banner
650
   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
651 652
#endif

Ian Lynagh's avatar
Ian Lynagh committed
653 654 655 656
   -- Display details of the configuration in verbose mode
   when (verb >= 2) $
    do hPutStr stderr "Glasgow Haskell Compiler, Version "
       hPutStr stderr cProjectVersion
Ian Lynagh's avatar
Ian Lynagh committed
657
       hPutStr stderr ", stage "
Ian Lynagh's avatar
Ian Lynagh committed
658 659 660
       hPutStr stderr cStage
       hPutStr stderr " booted by GHC version "
       hPutStrLn stderr cBooterVersion
661

662 663
-- We print out a Read-friendly string, but a prettier one than the
-- Show instance gives us
664 665 666
showInfo :: DynFlags -> IO ()
showInfo dflags = do
        let sq x = " [" ++ x ++ "\n ]"
667
        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
668

669
showSupportedExtensions :: IO ()
670
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
Ian Lynagh's avatar
Ian Lynagh committed
671

672
showVersion :: IO ()
673 674 675 676 677 678 679 680 681 682 683 684
showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)

showGhcUsage :: DynFlags -> IO ()
showGhcUsage = showUsage False

showGhciUsage :: DynFlags -> IO ()
showGhciUsage = showUsage True

showUsage :: Bool -> DynFlags -> IO ()
showUsage ghci dflags = do
  let usage_path = if ghci then ghciUsagePath dflags
                           else ghcUsagePath dflags
685 686 687
  usage <- readFile usage_path
  dump usage
  where
688
     dump ""          = return ()
689
     dump ('$':'$':s) = putStr progName >> dump s
690
     dump (c:s)       = putChar c >> dump s
691

692
dumpFinalStats :: DynFlags -> IO ()
dterei's avatar
dterei committed
693
dumpFinalStats dflags =
694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714
  when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags

dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats dflags = do
  buckets <- getFastStringTable
  let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
      msg = text "FastString stats:" $$
	    nest 4 (vcat [text "size:           " <+> int (length buckets),
			  text "entries:        " <+> int entries,
			  text "longest chain:  " <+> int longest,
			  text "z-encoded:      " <+> (is_z `pcntOf` entries),
			  text "has z-encoding: " <+> (has_z `pcntOf` entries)
			 ])
	-- we usually get more "has z-encoding" than "z-encoded", because
	-- when we z-encode a string it might hash to the exact same string,
	-- which will is not counted as "z-encoded".  Only strings whose
	-- Z-encoding is different from the original string are counted in
	-- the "z-encoded" total.
  putMsg dflags msg
  where
   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
Ian Lynagh's avatar
Ian Lynagh committed
715 716

countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)
717
countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
dterei's avatar
dterei committed
718
countFS entries longest is_z has_z (b:bs) =
719 720 721 722 723 724 725 726 727
  let
	len = length b
	longest' = max len longest
	entries' = entries + len
	is_zs = length (filter isZEncoded b)
	has_zs = length (filter hasZEncoding b)
  in
	countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs

728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760
-- -----------------------------------------------------------------------------
-- ABI hash support

{-
        ghc --abi-hash Data.Foo System.Bar

Generates a combined hash of the ABI for modules Data.Foo and
System.Bar.  The modules must already be compiled, and appropriate -i
options may be necessary in order to find the .hi files.

This is used by Cabal for generating the InstalledPackageId for a
package.  The InstalledPackageId must change when the visible ABI of
the package chagnes, so during registration Cabal calls ghc --abi-hash
to get a hash of the package's ABI.
-}

abiHash :: [(String, Maybe Phase)] -> Ghc ()
abiHash strs = do
  hsc_env <- getSession
  let dflags = hsc_dflags hsc_env

  liftIO $ do

  let find_it str = do
         let modname = mkModuleName str
         r <- findImportedModule hsc_env modname Nothing
         case r of
           Found _ m -> return m
           _error    -> ghcError $ CmdLineError $ showSDoc $
                          cannotFindInterface dflags modname r

  mods <- mapM find_it (map fst strs)

Simon Marlow's avatar
Simon Marlow committed
761
  let get_iface modl = loadUserInterface False (text "abiHash") modl
762 763 764
  ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods

  bh <- openBinMem (3*1024) -- just less than a block
765 766 767
  put_ bh opt_HiVersion
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
768 769 770 771 772
  mapM_ (put_ bh . mi_mod_hash) ifaces
  f <- fingerprintBinMem bh

  putStrLn (showSDoc (ppr f))

773 774 775 776
-- -----------------------------------------------------------------------------
-- Util

unknownFlagsErr :: [String] -> a
777
unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))
778