X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FMain.hs;h=12d8dd202b4bbe07f139bec9881e7f3ac177950a;hb=3bb66cc52ced70cd7081fb8a2e32a1005528d5a0;hp=fab773ba95771c608e6bf95637ee1ee79ca110d2;hpb=0cb74388d80c12f0804db61744a041be7fcfa10b;p=ghc-hetmet.git

diff --git a/ghc/Main.hs b/ghc/Main.hs
index fab773b..12d8dd2 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -14,8 +14,8 @@ module Main (main) where
 import qualified GHC
 import GHC		( -- DynFlags(..), HscTarget(..),
                           -- GhcMode(..), GhcLink(..),
-			  LoadHowMuch(..), -- dopt, DynFlag(..),
-                          defaultCallbacks )
+                          Ghc, GhcMonad(..),
+			  LoadHowMuch(..) )
 import CmdLineParser
 
 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
@@ -44,7 +44,7 @@ import Outputable
 import SrcLoc
 import Util
 import Panic
--- import MonadUtils       ( liftIO )
+import MonadUtils       ( liftIO )
 
 -- Imports for --abi-hash
 import LoadIface           ( loadUserInterface )
@@ -78,7 +78,8 @@ import Data.Maybe
 main :: IO ()
 main = do
    hSetBuffering stdout NoBuffering
-   GHC.defaultErrorHandler defaultDynFlags $ do
+   let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings")
+   GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do
     -- 1. extract the -B flag from the args
     argv0 <- getArgs
 
@@ -167,9 +168,9 @@ main' postLoadMode dflags0 args flagWarnings = do
   let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
 
   handleSourceError (\e -> do
-       GHC.printExceptionAndWarnings e
-       liftIO $ exitWith (ExitFailure 1)) $
-    handleFlagWarnings dflags2 flagWarnings'
+       GHC.printException e
+       liftIO $ exitWith (ExitFailure 1)) $ do
+         liftIO $ handleFlagWarnings dflags2 flagWarnings'
 
         -- make sure we clean up after ourselves
   GHC.defaultCleanupHandler dflags2 $ do
@@ -204,14 +205,13 @@ main' postLoadMode dflags0 args flagWarnings = do
 
   ---------------- Do the business -----------
   handleSourceError (\e -> do
-       GHC.printExceptionAndWarnings e
+       GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
     case postLoadMode of
        ShowInterface f        -> liftIO $ doShowIface dflags3 f
        DoMake                 -> doMake srcs
-       DoMkDependHS           -> do doMkDependHS (map fst srcs)
-                                    GHC.printWarnings
-       StopBefore p           -> oneShot hsc_env p srcs >> GHC.printWarnings
+       DoMkDependHS           -> doMkDependHS (map fst srcs)
+       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
        DoInteractive          -> interactiveUI srcs Nothing
        DoEval exprs           -> interactiveUI srcs $ Just $ reverse exprs
        DoAbiHash              -> abiHash srcs
@@ -359,9 +359,6 @@ showVersionMode             = mkPreStartupMode ShowVersion
 showNumVersionMode          = mkPreStartupMode ShowNumVersion
 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
 
-printMode :: String -> Mode
-printMode str              = mkPreStartupMode (Print str)
-
 mkPreStartupMode :: PreStartupMode -> Mode
 mkPreStartupMode = Left
 
@@ -384,8 +381,10 @@ showGhcUsageMode = mkPreLoadMode ShowGhcUsage
 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
 showInfoMode = mkPreLoadMode ShowInfo
 
-printWithDynFlagsMode :: (DynFlags -> String) -> Mode
-printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f)
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+                   $ lookup k (compilerInfo dflags)
 
 mkPreLoadMode :: PreLoadMode -> Mode
 mkPreLoadMode = Right . Left
@@ -505,14 +504,30 @@ mode_flags =
   , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
   , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
   ] ++
-  [ Flag k'                     (PassFlag (setMode mode))
-  | (k, v) <- compilerInfo,
+  [ Flag k'                     (PassFlag (setMode (printSetting k)))
+  | 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"],
     let k' = "-print-" ++ map (replaceSpace . toLower) k
         replaceSpace ' ' = '-'
         replaceSpace c   = c
-        mode = case v of
-               String str -> printMode str
-               FromDynFlags f -> printWithDynFlagsMode f
   ] ++
       ------- interfaces ----------------------------------------------------
   [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
@@ -592,7 +607,7 @@ doMake srcs  = do
 	haskellish (f,Nothing) = 
 	  looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
 	haskellish (_,Just phase) = 
-	  phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
+	  phase `notElem` [As, Cc, Cobjc, CmmCpp, Cmm, StopLn]
 
     hsc_env <- GHC.getSession
 
@@ -601,13 +616,10 @@ doMake srcs  = do
     -- This means that "ghc Foo.o Bar.o -o baz" links the program as
     -- we expect.
     if (null hs_srcs)
-       then oneShot hsc_env StopLn srcs >> GHC.printWarnings
+       then liftIO (oneShot hsc_env StopLn srcs)
        else do
 
-    o_files <- mapM (\x -> do
-                        f <- compileFile hsc_env StopLn x
-                        GHC.printWarnings
-                        return f)
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
                  non_hs_srcs
     liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
 
@@ -624,7 +636,7 @@ doMake srcs  = do
 
 doShowIface :: DynFlags -> FilePath -> IO ()
 doShowIface dflags file = do
-  hsc_env <- newHscEnv defaultCallbacks dflags
+  hsc_env <- newHscEnv dflags
   showIface hsc_env file
 
 -- ---------------------------------------------------------------------------
@@ -643,7 +655,7 @@ showBanner _postLoadMode dflags = do
    when (verb >= 2) $
     do hPutStr stderr "Glasgow Haskell Compiler, Version "
        hPutStr stderr cProjectVersion
-       hPutStr stderr ", for Haskell 98, stage "
+       hPutStr stderr ", stage "
        hPutStr stderr cStage
        hPutStr stderr " booted by GHC version "
        hPutStrLn stderr cBooterVersion
@@ -653,9 +665,7 @@ showBanner _postLoadMode dflags = do
 showInfo :: DynFlags -> IO ()
 showInfo dflags = do
         let sq x = " [" ++ x ++ "\n ]"
-        putStrLn $ sq $ concat $ intersperse "\n ," $ map (show . flatten) compilerInfo
-    where flatten (k, String v)       = (k, v)
-          flatten (k, FromDynFlags f) = (k, f dflags)
+        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
 
 showSupportedExtensions :: IO ()
 showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions