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 -- The official GHC API
  15 import qualified GHC
  16 import GHC              ( Session, DynFlags(..), GhcMode(..), HscTarget(..),
  17                           LoadHowMuch(..), dopt, DynFlag(..) )
  18 import CmdLineParser
  19
  20 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
  21 import LoadIface        ( showIface )
  22 import HscMain          ( newHscEnv )
  23 import DriverPipeline   ( oneShot, compileFile )
  24 import DriverMkDepend   ( doMkDependHS )
  25 #ifdef GHCI
  26 import InteractiveUI    ( ghciWelcomeMsg, interactiveUI )
  27 #endif
  28
  29 -- Various other random stuff that we need
  30 import Config           ( cProjectVersion, cBooterVersion, cProjectName )
  31 import Packages         ( dumpPackages )
  32 import DriverPhases     ( Phase(..), isSourceFilename, anyHsc,
  33                           startPhase, isHaskellSrcFilename )
  34 import StaticFlags      ( staticFlags, v_Ld_inputs, parseStaticFlags )
  35 import DynFlags         ( defaultDynFlags )
  36 import BasicTypes       ( failed )
  37 import ErrUtils         ( putMsg )
  38 import FastString       ( getFastStringTable, isZEncoded, hasZEncoding )
  39 import Outputable
  40 import Util
  41 import Panic
  42
  43 -- Standard Haskell libraries
  44 import EXCEPTION        ( throwDyn )
  45 import IO
  46 import Directory        ( doesDirectoryExist )
  47 import System           ( getArgs, exitWith, ExitCode(..) )
  48 import Monad
  49 import List
  50 import Maybe
  51
  52 -----------------------------------------------------------------------------
  53 -- ToDo:
  54
  55 -- time commands when run with -v
  56 -- user ways
  57 -- Win32 support: proper signal handling
  58 -- reading the package configuration file is too slow
  59 -- -K<size>
  60
  61 -----------------------------------------------------------------------------
  62 -- GHC's command-line interface
  63
  64 main =
  65   GHC.defaultErrorHandler defaultDynFlags $ do
  66
  67   -- 1. extract the -B flag from the args
  68   argv0 <- getArgs
  69
  70   let
  71         (minusB_args, argv1) = partition (prefixMatch "-B") argv0
  72         mbMinusB | null minusB_args = Nothing
  73                  | otherwise = Just (drop 2 (last minusB_args))
  74
  75   argv2 <- parseStaticFlags argv1
  76
  77   -- 2. Parse the "mode" flags (--make, --interactive etc.)
  78   (cli_mode, argv3) <- parseModeFlags argv2
  79
  80   let mode = case cli_mode of
  81                 DoInteractive   -> Interactive
  82                 DoEval _        -> Interactive
  83                 DoMake          -> BatchCompile
  84                 DoMkDependHS    -> MkDepend
  85                 _               -> OneShot
  86
  87   -- start our GHC session
  88   session <- GHC.newSession mode mbMinusB
  89
  90   dflags0 <- GHC.getSessionDynFlags session
  91
  92   -- set the default HscTarget.  The HscTarget can be further
  93   -- adjusted on a module by module basis, using only the -fvia-C and
  94   -- -fasm flags.  If the default HscTarget is not HscC or HscAsm,
  95   -- -fvia-C and -fasm have no effect.
  96   let lang = case cli_mode of
  97                  DoInteractive  -> HscInterpreted
  98                  DoEval _       -> HscInterpreted
  99                  _other         -> hscTarget dflags0
 100
 101   let dflags1 = dflags0{ ghcMode = mode,
 102                          hscTarget  = lang,
 103                          -- leave out hscOutName for now
 104                          hscOutName = panic "Main.main:hscOutName not set",
 105                          verbosity = case cli_mode of
 106                                          DoEval _ -> 0
 107                                          _other   -> 1
 108                         }
 109
 110         -- The rest of the arguments are "dynamic"
 111         -- Leftover ones are presumably files
 112   (dflags, fileish_args) <- GHC.parseDynamicFlags dflags1 argv3
 113
 114         -- make sure we clean up after ourselves
 115   GHC.defaultCleanupHandler dflags $ do
 116
 117         -- Display banner
 118   showBanner cli_mode dflags
 119
 120   -- we've finished manipulating the DynFlags, update the session
 121   GHC.setSessionDynFlags session dflags
 122   dflags <- GHC.getSessionDynFlags session
 123
 124   let
 125      -- To simplify the handling of filepaths, we normalise all filepaths right
 126      -- away - e.g., for win32 platforms, backslashes are converted
 127      -- into forward slashes.
 128     normal_fileish_paths = map normalisePath fileish_args
 129     (srcs, objs)         = partition_args normal_fileish_paths [] []
 130
 131   -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
 132   --       the command-line.
 133   mapM_ (consIORef v_Ld_inputs) (reverse objs)
 134
 135         ---------------- Display configuration -----------
 136   when (verbosity dflags >= 4) $
 137         dumpPackages dflags
 138
 139   when (verbosity dflags >= 3) $ do
 140         hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
 141
 142         ---------------- Final sanity checking -----------
 143   checkOptions cli_mode dflags srcs objs
 144
 145         ---------------- Do the business -----------
 146   case cli_mode of
 147         ShowUsage       -> showGhcUsage dflags cli_mode
 148         PrintLibdir     -> putStrLn (topDir dflags)
 149         ShowVersion     -> showVersion
 150         ShowNumVersion  -> putStrLn cProjectVersion
 151         ShowInterface f -> doShowIface dflags f
 152         DoMake          -> doMake session srcs
 153         DoMkDependHS    -> doMkDependHS session (map fst srcs)
 154         StopBefore p    -> oneShot dflags p srcs
 155         DoInteractive   -> interactiveUI session srcs Nothing
 156         DoEval expr     -> interactiveUI session srcs (Just expr)
 157
 158   dumpFinalStats dflags
 159   exitWith ExitSuccess
 160
 161 #ifndef GHCI
 162 interactiveUI _ _ _ =
 163   throwDyn (CmdLineError "not built for interactive use")
 164 #endif
 165
 166 -- -----------------------------------------------------------------------------
 167 -- Splitting arguments into source files and object files.  This is where we
 168 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
 169 -- file indicating the phase specified by the -x option in force, if any.
 170
 171 partition_args [] srcs objs = (reverse srcs, reverse objs)
 172 partition_args ("-x":suff:args) srcs objs
 173   | "none" <- suff      = partition_args args srcs objs
 174   | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
 175   | otherwise           = partition_args rest (these_srcs ++ srcs) objs
 176         where phase = startPhase suff
 177               (slurp,rest) = break (== "-x") args
 178               these_srcs = zip slurp (repeat (Just phase))
 179 partition_args (arg:args) srcs objs
 180   | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
 181   | otherwise               = partition_args args srcs (arg:objs)
 182
 183     {-
 184       We split out the object files (.o, .dll) and add them
 185       to v_Ld_inputs for use by the linker.
 186
 187       The following things should be considered compilation manager inputs:
 188
 189        - haskell source files (strings ending in .hs, .lhs or other
 190          haskellish extension),
 191
 192        - module names (not forgetting hierarchical module names),
 193
 194        - and finally we consider everything not containing a '.' to be
 195          a comp manager input, as shorthand for a .hs or .lhs filename.
 196
 197       Everything else is considered to be a linker object, and passed
 198       straight through to the linker.
 199     -}
 200 looks_like_an_input m =  isSourceFilename m
 201                       || looksLikeModuleName m
 202                       || '.' `notElem` m
 203
 204 -- -----------------------------------------------------------------------------
 205 -- Option sanity checks
 206
 207 checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
 208      -- Final sanity checking before kicking off a compilation (pipeline).
 209 checkOptions cli_mode dflags srcs objs = do
 210      -- Complain about any unknown flags
 211    let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
 212    when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
 213
 214         -- -prof and --interactive are not a good combination
 215    when (notNull (wayNames dflags)  && isInterpretiveMode cli_mode) $
 216       do throwDyn (UsageError
 217                    "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
 218         -- -ohi sanity check
 219    if (isJust (outputHi dflags) &&
 220       (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))
 221         then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
 222         else do
 223
 224         -- -o sanity checking
 225    if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
 226          && not (isLinkMode cli_mode))
 227         then throwDyn (UsageError "can't apply -o to multiple source files")
 228         else do
 229
 230         -- Check that there are some input files
 231         -- (except in the interactive case)
 232    if null srcs && null objs && needsInputsMode cli_mode
 233         then throwDyn (UsageError "no input files")
 234         else do
 235
 236      -- Verify that output files point somewhere sensible.
 237    verifyOutputFiles dflags
 238
 239
 240 -- Compiler output options
 241
 242 -- called to verify that the output files & directories
 243 -- point somewhere valid.
 244 --
 245 -- The assumption is that the directory portion of these output
 246 -- options will have to exist by the time 'verifyOutputFiles'
 247 -- is invoked.
 248 --
 249 verifyOutputFiles :: DynFlags -> IO ()
 250 verifyOutputFiles dflags = do
 251   let odir = objectDir dflags
 252   when (isJust odir) $ do
 253      let dir = fromJust odir
 254      flg <- doesDirectoryExist dir
 255      when (not flg) (nonExistentDir "-odir" dir)
 256   let ofile = outputFile dflags
 257   when (isJust ofile) $ do
 258      let fn = fromJust ofile
 259      flg <- doesDirNameExist fn
 260      when (not flg) (nonExistentDir "-o" fn)
 261   let ohi = outputHi dflags
 262   when (isJust ohi) $ do
 263      let hi = fromJust ohi
 264      flg <- doesDirNameExist hi
 265      when (not flg) (nonExistentDir "-ohi" hi)
 266  where
 267    nonExistentDir flg dir =
 268      throwDyn (CmdLineError ("error: directory portion of " ++
 269                              show dir ++ " does not exist (used with " ++
 270                              show flg ++ " option.)"))
 271
 272 -----------------------------------------------------------------------------
 273 -- GHC modes of operation
 274
 275 data CmdLineMode
 276   = ShowUsage                   -- ghc -?
 277   | PrintLibdir                 -- ghc --print-libdir
 278   | ShowVersion                 -- ghc -V/--version
 279   | ShowNumVersion              -- ghc --numeric-version
 280   | ShowInterface String        -- ghc --show-iface
 281   | DoMkDependHS                -- ghc -M
 282   | StopBefore Phase            -- ghc -E | -C | -S
 283                                 -- StopBefore StopLn is the default
 284   | DoMake                      -- ghc --make
 285   | DoInteractive               -- ghc --interactive
 286   | DoEval String               -- ghc -e
 287   deriving (Show)
 288
 289 isInteractiveMode, isInterpretiveMode     :: CmdLineMode -> Bool
 290 isLinkMode, isCompManagerMode :: CmdLineMode -> Bool
 291
 292 isInteractiveMode DoInteractive = True
 293 isInteractiveMode _             = False
 294
 295 -- isInterpretiveMode: byte-code compiler involved
 296 isInterpretiveMode DoInteractive = True
 297 isInterpretiveMode (DoEval _)    = True
 298 isInterpretiveMode _             = False
 299
 300 needsInputsMode DoMkDependHS    = True
 301 needsInputsMode (StopBefore _)  = True
 302 needsInputsMode DoMake          = True
 303 needsInputsMode _               = False
 304
 305 -- True if we are going to attempt to link in this mode.
 306 -- (we might not actually link, depending on the GhcLink flag)
 307 isLinkMode (StopBefore StopLn) = True
 308 isLinkMode DoMake              = True
 309 isLinkMode _                   = False
 310
 311 isCompManagerMode DoMake        = True
 312 isCompManagerMode DoInteractive = True
 313 isCompManagerMode (DoEval _)    = True
 314 isCompManagerMode _             = False
 315
 316
 317 -- -----------------------------------------------------------------------------
 318 -- Parsing the mode flag
 319
 320 parseModeFlags :: [String] -> IO (CmdLineMode, [String])
 321 parseModeFlags args = do
 322   let ((leftover, errs), (mode, _, flags)) =
 323          runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", [])
 324   when (not (null errs)) $ do
 325     throwDyn (UsageError (unlines errs))
 326   return (mode, flags ++ leftover)
 327
 328 type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
 329   -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
 330   -- so we collect the new ones and return them.
 331
 332 mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
 333 mode_flags =
 334   [  ------- help / version ----------------------------------------------
 335      ( "?"               , PassFlag (setMode ShowUsage))
 336   ,  ( "-help"           , PassFlag (setMode ShowUsage))
 337   ,  ( "-print-libdir"   , PassFlag (setMode PrintLibdir))
 338   ,  ( "V"               , PassFlag (setMode ShowVersion))
 339   ,  ( "-version"        , PassFlag (setMode ShowVersion))
 340   ,  ( "-numeric-version", PassFlag (setMode ShowNumVersion))
 341
 342       ------- interfaces ----------------------------------------------------
 343   ,  ( "-show-iface"     , HasArg (\f -> setMode (ShowInterface f)
 344                                           "--show-iface"))
 345
 346       ------- primary modes ------------------------------------------------
 347   ,  ( "M"              , PassFlag (setMode DoMkDependHS))
 348   ,  ( "E"              , PassFlag (setMode (StopBefore anyHsc)))
 349   ,  ( "C"              , PassFlag (\f -> do setMode (StopBefore HCc) f
 350                                              addFlag "-fvia-C"))
 351   ,  ( "S"              , PassFlag (setMode (StopBefore As)))
 352   ,  ( "-make"          , PassFlag (setMode DoMake))
 353   ,  ( "-interactive"   , PassFlag (setMode DoInteractive))
 354   ,  ( "e"              , HasArg   (\s -> setMode (DoEval s) "-e"))
 355
 356         -- -fno-code says to stop after Hsc but don't generate any code.
 357   ,  ( "fno-code"       , PassFlag (\f -> do setMode (StopBefore HCc) f
 358                                              addFlag "-fno-code"
 359                                              addFlag "-no-recomp"))
 360   ]
 361
 362 setMode :: CmdLineMode -> String -> ModeM ()
 363 setMode m flag = do
 364   (old_mode, old_flag, flags) <- getCmdLineState
 365   when (notNull old_flag && flag /= old_flag) $
 366       throwDyn (UsageError
 367           ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
 368   putCmdLineState (m, flag, flags)
 369
 370 addFlag :: String -> ModeM ()
 371 addFlag s = do
 372   (m, f, flags) <- getCmdLineState
 373   putCmdLineState (m, f, s:flags)
 374
 375
 376 -- ----------------------------------------------------------------------------
 377 -- Run --make mode
 378
 379 doMake :: Session -> [(String,Maybe Phase)] -> IO ()
 380 doMake sess []    = throwDyn (UsageError "no input files")
 381 doMake sess srcs  = do
 382     let (hs_srcs, non_hs_srcs) = partition haskellish srcs
 383
 384         haskellish (f,Nothing) =
 385           looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
 386         haskellish (f,Just phase) =
 387           phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
 388
 389     dflags <- GHC.getSessionDynFlags sess
 390     o_files <- mapM (compileFile dflags StopLn) non_hs_srcs
 391     mapM_ (consIORef v_Ld_inputs) (reverse o_files)
 392
 393     targets <- mapM (uncurry GHC.guessTarget) hs_srcs
 394     GHC.setTargets sess targets
 395     ok_flag <- GHC.load sess LoadAllTargets
 396     when (failed ok_flag) (exitWith (ExitFailure 1))
 397     return ()
 398
 399
 400 -- ---------------------------------------------------------------------------
 401 -- --show-iface mode
 402
 403 doShowIface :: DynFlags -> FilePath -> IO ()
 404 doShowIface dflags file = do
 405   hsc_env <- newHscEnv dflags
 406   showIface hsc_env file
 407
 408 -- ---------------------------------------------------------------------------
 409 -- Various banners and verbosity output.
 410
 411 showBanner :: CmdLineMode -> DynFlags -> IO ()
 412 showBanner cli_mode dflags = do
 413    let verb = verbosity dflags
 414         -- Show the GHCi banner
 415 #  ifdef GHCI
 416    when (isInteractiveMode cli_mode && verb >= 1) $
 417       hPutStrLn stdout ghciWelcomeMsg
 418 #  endif
 419
 420         -- Display details of the configuration in verbose mode
 421    when (not (isInteractiveMode cli_mode) && verb >= 2) $
 422         do hPutStr stderr "Glasgow Haskell Compiler, Version "
 423            hPutStr stderr cProjectVersion
 424            hPutStr stderr ", for Haskell 98, compiled by GHC version "
 425 #ifdef GHCI
 426            -- GHCI is only set when we are bootstrapping...
 427            hPutStrLn stderr cProjectVersion
 428 #else
 429            hPutStrLn stderr cBooterVersion
 430 #endif
 431
 432 showVersion :: IO ()
 433 showVersion = do
 434   putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
 435   exitWith ExitSuccess
 436
 437 showGhcUsage dflags cli_mode = do
 438   let usage_path
 439         | DoInteractive <- cli_mode = ghcUsagePath dflags
 440         | otherwise                 = ghciUsagePath dflags
 441   usage <- readFile usage_path
 442   dump usage
 443   exitWith ExitSuccess
 444   where
 445      dump ""          = return ()
 446      dump ('$':'$':s) = putStr progName >> dump s
 447      dump (c:s)       = putChar c >> dump s
 448
 449 dumpFinalStats :: DynFlags -> IO ()
 450 dumpFinalStats dflags =
 451   when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
 452
 453 dumpFastStringStats :: DynFlags -> IO ()
 454 dumpFastStringStats dflags = do
 455   buckets <- getFastStringTable
 456   let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
 457       msg = text "FastString stats:" $$
 458             nest 4 (vcat [text "size:           " <+> int (length buckets),
 459                           text "entries:        " <+> int entries,
 460                           text "longest chain:  " <+> int longest,
 461                           text "z-encoded:      " <+> (is_z `pcntOf` entries),
 462                           text "has z-encoding: " <+> (has_z `pcntOf` entries)
 463                          ])
 464         -- we usually get more "has z-encoding" than "z-encoded", because
 465         -- when we z-encode a string it might hash to the exact same string,
 466         -- which will is not counted as "z-encoded".  Only strings whose
 467         -- Z-encoding is different from the original string are counted in
 468         -- the "z-encoded" total.
 469   putMsg dflags msg
 470   where
 471    x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
 472
 473 countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
 474 countFS entries longest is_z has_z (b:bs) =
 475   let
 476         len = length b
 477         longest' = max len longest
 478         entries' = entries + len
 479         is_zs = length (filter isZEncoded b)
 480         has_zs = length (filter hasZEncoding b)
 481   in
 482         countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs
 483
 484 -- -----------------------------------------------------------------------------
 485 -- Util
 486
 487 unknownFlagsErr :: [String] -> a
 488 unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))