Another round of External Core fixes
[ghc-hetmet.git] / compiler / main / Main.hs
index f7c5be7..4c31fcd 100644 (file)
@@ -1,4 +1,5 @@
 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+
 -----------------------------------------------------------------------------
 --
 -- GHC Driver program
@@ -13,7 +14,8 @@ module Main (main) where
 
 -- The official GHC API
 import qualified GHC
-import GHC             ( Session, DynFlags(..), GhcMode(..), HscTarget(..),
+import GHC             ( Session, DynFlags(..), HscTarget(..), 
+                          GhcMode(..), GhcLink(..),
                          LoadHowMuch(..), dopt, DynFlag(..) )
 import CmdLineParser
 
@@ -23,19 +25,19 @@ import HscMain          ( newHscEnv )
 import DriverPipeline  ( oneShot, compileFile )
 import DriverMkDepend  ( doMkDependHS )
 #ifdef GHCI
-import InteractiveUI   ( ghciWelcomeMsg, interactiveUI )
+import InteractiveUI   ( interactiveUI, ghciWelcomeMsg )
 #endif
 
 -- Various other random stuff that we need
-import Config          ( cProjectVersion, cBooterVersion, cProjectName )
+import Config
 import Packages                ( dumpPackages )
 import DriverPhases    ( Phase(..), isSourceFilename, anyHsc,
                          startPhase, isHaskellSrcFilename )
-import StaticFlags     ( staticFlags, v_Ld_inputs, parseStaticFlags )
-import DynFlags         ( defaultDynFlags )
+import StaticFlags
+import DynFlags
 import BasicTypes      ( failed )
 import ErrUtils                ( putMsg )
-import FastString      ( getFastStringTable, isZEncoded, hasZEncoding )
+import FastString
 import Outputable
 import Util
 import Panic
@@ -46,6 +48,7 @@ import System.IO
 import System.Directory        ( doesDirectoryExist )
 import System.Environment
 import System.Exit
+import System.FilePath
 import Control.Monad
 import Data.List
 import Data.Maybe
@@ -62,6 +65,7 @@ import Data.Maybe
 -----------------------------------------------------------------------------
 -- GHC's command-line interface
 
+main :: IO ()
 main =
   GHC.defaultErrorHandler defaultDynFlags $ do
   
@@ -69,7 +73,7 @@ main =
   argv0 <- getArgs
 
   let
-        (minusB_args, argv1) = partition (prefixMatch "-B") argv0
+        (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
         mbMinusB | null minusB_args = Nothing
                  | otherwise = Just (drop 2 (last minusB_args))
 
@@ -78,29 +82,43 @@ main =
   -- 2. Parse the "mode" flags (--make, --interactive etc.)
   (cli_mode, argv3) <- parseModeFlags argv2
 
-  let mode = case cli_mode of
-               DoInteractive   -> Interactive
-               DoEval _        -> Interactive
-               DoMake          -> BatchCompile
-               DoMkDependHS    -> MkDepend
-               _               -> OneShot
+  -- If all we want to do is to show the version number then do it
+  -- now, before we start a GHC session etc.
+  -- If we do it later 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 cli_mode of
+    ShowInfo                -> do showInfo
+                                  exitWith ExitSuccess
+    ShowSupportedLanguages  -> do showSupportedLanguages
+                                  exitWith ExitSuccess
+    ShowVersion             -> do showVersion
+                                  exitWith ExitSuccess
+    ShowNumVersion          -> do putStrLn cProjectVersion
+                                  exitWith ExitSuccess
+    _                       -> return ()
 
   -- start our GHC session
-  session <- GHC.newSession mode mbMinusB
+  session <- GHC.newSession mbMinusB
 
   dflags0 <- GHC.getSessionDynFlags session
 
-  -- set the default HscTarget.  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 lang = case cli_mode of 
-                DoInteractive  -> HscInterpreted
-                DoEval _       -> HscInterpreted
-                _other         -> hscTarget dflags0
-
-  let dflags1 = dflags0{ ghcMode = mode,
-                        hscTarget  = lang,
+  -- 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)
+         = case cli_mode of
+               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
+               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
+               DoMake          -> (CompManager, dflt_target,    LinkBinary)
+               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
+               _               -> (OneShot,     dflt_target,    LinkBinary)
+
+  let dflags1 = dflags0{ ghcMode   = mode,
+                        hscTarget = lang,
+                         ghcLink   = link,
                         -- leave out hscOutName for now
                         hscOutName = panic "Main.main:hscOutName not set",
                         verbosity = case cli_mode of
@@ -115,7 +133,6 @@ main =
        -- make sure we clean up after ourselves
   GHC.defaultCleanupHandler dflags $ do
 
-       -- Display banner
   showBanner cli_mode dflags
 
   -- we've finished manipulating the DynFlags, update the session
@@ -126,7 +143,7 @@ main =
      -- To simplify the handling of filepaths, we normalise all filepaths right 
      -- away - e.g., for win32 platforms, backslashes are converted
      -- into forward slashes.
-    normal_fileish_paths = map normalisePath fileish_args
+    normal_fileish_paths = map normalise fileish_args
     (srcs, objs)         = partition_args normal_fileish_paths [] []
 
   -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on 
@@ -143,23 +160,27 @@ main =
        ---------------- Final sanity checking -----------
   checkOptions cli_mode dflags srcs objs
 
-       ---------------- Do the business -----------
+  ---------------- Do the business -----------
+  let alreadyHandled = panic (show cli_mode ++
+                              " should already have been handled")
   case cli_mode of
-       ShowUsage       -> showGhcUsage dflags cli_mode
-       PrintLibdir     -> putStrLn (topDir dflags)
-       ShowVersion     -> showVersion
-        ShowNumVersion  -> putStrLn cProjectVersion
-        ShowInterface f -> doShowIface dflags f
-       DoMake          -> doMake session srcs
-       DoMkDependHS    -> doMkDependHS session (map fst srcs)
-       StopBefore p    -> oneShot dflags p srcs
-       DoInteractive   -> interactiveUI session srcs Nothing
-       DoEval expr     -> interactiveUI session srcs (Just expr)
+    ShowUsage              -> showGhcUsage dflags cli_mode
+    PrintLibdir            -> putStrLn (topDir dflags)
+    ShowSupportedLanguages -> alreadyHandled
+    ShowVersion            -> alreadyHandled
+    ShowNumVersion         -> alreadyHandled
+    ShowInterface f        -> doShowIface dflags f
+    DoMake                 -> doMake session srcs
+    DoMkDependHS           -> doMkDependHS session (map fst srcs)
+    StopBefore p           -> oneShot dflags p srcs
+    DoInteractive          -> interactiveUI session srcs Nothing
+    DoEval exprs           -> interactiveUI session srcs $ Just $ reverse exprs
 
   dumpFinalStats dflags
   exitWith ExitSuccess
 
 #ifndef GHCI
+interactiveUI :: a -> b -> c -> IO ()
 interactiveUI _ _ _ = 
   throwDyn (CmdLineError "not built for interactive use")
 #endif
@@ -169,6 +190,8 @@ interactiveUI _ _ _ =
 -- 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.
 
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+               -> ([(String, Maybe Phase)], [String])
 partition_args [] srcs objs = (reverse srcs, reverse objs)
 partition_args ("-x":suff:args) srcs objs
   | "none" <- suff     = partition_args args srcs objs
@@ -198,6 +221,7 @@ partition_args (arg:args) srcs objs
       Everything else is considered to be a linker object, and passed
       straight through to the linker.
     -}
+looks_like_an_input :: String -> Bool
 looks_like_an_input m =  isSourceFilename m 
                      || looksLikeModuleName m
                      || '.' `notElem` m
@@ -212,10 +236,15 @@ checkOptions cli_mode dflags srcs objs = do
    let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
    when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
 
+   when (notNull (filter isRTSWay (wayNames dflags))
+         && isInterpretiveMode cli_mode) $
+        putStrLn ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
+
        -- -prof and --interactive are not a good combination
-   when (notNull (wayNames dflags)  && isInterpretiveMode cli_mode) $
+   when (notNull (filter (not . isRTSWay) (wayNames dflags))
+         && isInterpretiveMode cli_mode) $
       do throwDyn (UsageError 
-                   "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
+                   "--interactive can't be used with -prof or -unreg.")
        -- -ohi sanity check
    if (isJust (outputHi dflags) && 
       (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))
@@ -274,30 +303,34 @@ verifyOutputFiles dflags = do
 -- GHC modes of operation
 
 data CmdLineMode
-  = ShowUsage                  -- ghc -?
-  | PrintLibdir                        -- ghc --print-libdir
-  | ShowVersion                        -- ghc -V/--version
-  | ShowNumVersion             -- ghc --numeric-version
-  | ShowInterface String       -- ghc --show-iface
-  | DoMkDependHS               -- ghc -M
-  | StopBefore Phase           -- ghc -E | -C | -S
-                               -- StopBefore StopLn is the default
-  | DoMake                     -- ghc --make
-  | DoInteractive              -- ghc --interactive
-  | DoEval String              -- ghc -e
+  = ShowUsage               -- ghc -?
+  | PrintLibdir             -- ghc --print-libdir
+  | ShowInfo                -- ghc --info
+  | ShowSupportedLanguages  -- ghc --supported-languages
+  | ShowVersion             -- ghc -V/--version
+  | ShowNumVersion          -- ghc --numeric-version
+  | ShowInterface String    -- ghc --show-iface
+  | DoMkDependHS            -- ghc -M
+  | StopBefore Phase        -- ghc -E | -C | -S
+                            -- StopBefore StopLn is the default
+  | DoMake                  -- ghc --make
+  | DoInteractive           -- ghc --interactive
+  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
   deriving (Show)
 
-isInteractiveMode, isInterpretiveMode     :: CmdLineMode -> Bool
-isLinkMode, isCompManagerMode :: CmdLineMode -> Bool
-
+#ifdef GHCI
+isInteractiveMode :: CmdLineMode -> Bool
 isInteractiveMode DoInteractive = True
 isInteractiveMode _            = False
+#endif
 
 -- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: CmdLineMode -> Bool
 isInterpretiveMode DoInteractive = True
 isInterpretiveMode (DoEval _)    = True
 isInterpretiveMode _             = False
 
+needsInputsMode :: CmdLineMode -> Bool
 needsInputsMode DoMkDependHS   = True
 needsInputsMode (StopBefore _) = True
 needsInputsMode DoMake         = True
@@ -305,10 +338,12 @@ needsInputsMode _         = False
 
 -- True if we are going to attempt to link in this mode.
 -- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: CmdLineMode -> Bool
 isLinkMode (StopBefore StopLn) = True
 isLinkMode DoMake             = True
 isLinkMode _                          = False
 
+isCompManagerMode :: CmdLineMode -> Bool
 isCompManagerMode DoMake        = True
 isCompManagerMode DoInteractive = True
 isCompManagerMode (DoEval _)    = True
@@ -333,40 +368,49 @@ type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
 mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
 mode_flags =
   [  ------- help / version ----------------------------------------------
-     ( "?"              , PassFlag (setMode ShowUsage))
-  ,  ( "-help"          , PassFlag (setMode ShowUsage))
-  ,  ( "-print-libdir"   , PassFlag (setMode PrintLibdir))
-  ,  ( "V"              , PassFlag (setMode ShowVersion))
-  ,  ( "-version"       , PassFlag (setMode ShowVersion))
-  ,  ( "-numeric-version", PassFlag (setMode ShowNumVersion))
+     ( "?"                   , PassFlag (setMode ShowUsage))
+  ,  ( "-help"               , PassFlag (setMode ShowUsage))
+  ,  ( "-print-libdir"       , PassFlag (setMode PrintLibdir))
+  ,  ( "V"                   , PassFlag (setMode ShowVersion))
+  ,  ( "-version"            , PassFlag (setMode ShowVersion))
+  ,  ( "-numeric-version"    , PassFlag (setMode ShowNumVersion))
+  ,  ( "-info"               , PassFlag (setMode ShowInfo))
+  ,  ( "-supported-languages", PassFlag (setMode ShowSupportedLanguages))
 
       ------- interfaces ----------------------------------------------------
   ,  ( "-show-iface"     , HasArg (\f -> setMode (ShowInterface f)
-                                         "--show-iface"))
+                                                 "--show-iface"))
 
       ------- primary modes ------------------------------------------------
-  ,  ( "M"             , PassFlag (setMode DoMkDependHS))
-  ,  ( "E"             , PassFlag (setMode (StopBefore anyHsc)))
-  ,  ( "C"             , PassFlag (\f -> do setMode (StopBefore HCc) f
-                                            addFlag "-fvia-C"))
-  ,  ( "S"             , PassFlag (setMode (StopBefore As)))
-  ,  ( "-make"         , PassFlag (setMode DoMake))
-  ,  ( "-interactive"  , PassFlag (setMode DoInteractive))
-  ,  ( "e"              , HasArg   (\s -> setMode (DoEval s) "-e"))
-
-       -- -fno-code says to stop after Hsc but don't generate any code.
-  ,  ( "fno-code"      , PassFlag (\f -> do setMode (StopBefore HCc) f
-                                            addFlag "-fno-code"
-                                            addFlag "-no-recomp"))
+  ,  ( "M"              , PassFlag (setMode DoMkDependHS))
+  ,  ( "E"              , PassFlag (setMode (StopBefore anyHsc)))
+  ,  ( "C"              , PassFlag (\f -> do setMode (StopBefore HCc) f
+                                             addFlag "-fvia-C"))
+  ,  ( "S"              , PassFlag (setMode (StopBefore As)))
+  ,  ( "-make"          , PassFlag (setMode DoMake))
+  ,  ( "-interactive"   , PassFlag (setMode DoInteractive))
+  ,  ( "e"              , HasArg   (\s -> updateMode (updateDoEval s) "-e"))
+
+       -- -fno-code says to stop after Hsc but don't generate any code.
+  ,  ( "fno-code"       , PassFlag (\f -> do setMode (StopBefore HCc) f
+                                             addFlag "-fno-code"
+                                             addFlag "-no-recomp"))
   ]
 
 setMode :: CmdLineMode -> String -> ModeM ()
-setMode m flag = do
+setMode m flag = updateMode (\_ -> m) flag
+
+updateDoEval :: String -> CmdLineMode -> CmdLineMode
+updateDoEval expr (DoEval exprs) = DoEval (expr : exprs)
+updateDoEval expr _              = DoEval [expr]
+
+updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM ()
+updateMode f flag = do
   (old_mode, old_flag, flags) <- getCmdLineState
-  when (notNull old_flag && flag /= old_flag) $
-      throwDyn (UsageError 
-          ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
-  putCmdLineState (m, flag, flags)
+  if notNull old_flag && flag /= old_flag
+      then throwDyn (UsageError
+               ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
+      else putCmdLineState (f old_mode, flag, flags)
 
 addFlag :: String -> ModeM ()
 addFlag s = do
@@ -378,13 +422,13 @@ addFlag s = do
 -- Run --make mode
 
 doMake :: Session -> [(String,Maybe Phase)] -> IO ()
-doMake sess []    = throwDyn (UsageError "no input files")
+doMake _    []    = throwDyn (UsageError "no input files")
 doMake sess srcs  = do 
     let (hs_srcs, non_hs_srcs) = partition haskellish srcs
 
        haskellish (f,Nothing) = 
          looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
-       haskellish (f,Just phase) = 
+       haskellish (_,Just phase) = 
          phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
 
     dflags <- GHC.getSessionDynFlags sess
@@ -410,35 +454,45 @@ doShowIface dflags file = do
 -- Various banners and verbosity output.
 
 showBanner :: CmdLineMode -> DynFlags -> IO ()
-showBanner cli_mode dflags = do
+showBanner _cli_mode dflags = do
    let verb = verbosity dflags
-       -- Show the GHCi banner
-#  ifdef GHCI
-   when (isInteractiveMode cli_mode && verb >= 1) $
-      hPutStrLn stdout ghciWelcomeMsg
-#  endif
-
-       -- Display details of the configuration in verbose mode
-   when (not (isInteractiveMode cli_mode) && verb >= 2) $
-       do hPutStr stderr "Glasgow Haskell Compiler, Version "
-          hPutStr stderr cProjectVersion
-          hPutStr stderr ", for Haskell 98, compiled by GHC version "
+
 #ifdef GHCI
-          -- GHCI is only set when we are bootstrapping...
-          hPutStrLn stderr cProjectVersion
-#else
-          hPutStrLn stderr cBooterVersion
+   -- Show the GHCi banner
+   when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg
 #endif
 
+   -- Display details of the configuration in verbose mode
+   when (verb >= 2) $
+    do hPutStr stderr "Glasgow Haskell Compiler, Version "
+       hPutStr stderr cProjectVersion
+       hPutStr stderr ", for Haskell 98, stage "
+       hPutStr stderr cStage
+       hPutStr stderr " booted by GHC version "
+       hPutStrLn stderr cBooterVersion
+
+-- We print out a Read-friendly string, but a prettier one than the
+-- Show instance gives us
+showInfo :: IO ()
+showInfo = do
+    let sq x = " [" ++ x ++ "\n ]"
+    putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo
+    exitWith ExitSuccess
+
+showSupportedLanguages :: IO ()
+showSupportedLanguages = do mapM_ putStrLn supportedLanguages
+                            exitWith ExitSuccess
+
 showVersion :: IO ()
 showVersion = do
   putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
   exitWith ExitSuccess
 
+showGhcUsage :: DynFlags -> CmdLineMode -> IO ()
 showGhcUsage dflags cli_mode = do 
   let usage_path 
-       | DoInteractive <- cli_mode = ghcUsagePath dflags
-       | otherwise                 = ghciUsagePath dflags
+       | DoInteractive <- cli_mode = ghciUsagePath dflags
+       | otherwise                 = ghcUsagePath dflags
   usage <- readFile usage_path
   dump usage
   exitWith ExitSuccess
@@ -470,7 +524,8 @@ dumpFastStringStats dflags = do
   putMsg dflags msg
   where
    x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
-  
+
+countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)
 countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
 countFS entries longest is_z has_z (b:bs) = 
   let