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