projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Remove CPP from nativeGen/TargetReg.hs
[ghc-hetmet.git]
/
ghc
/
Main.hs
diff --git
a/ghc/Main.hs
b/ghc/Main.hs
index
3b4d5e0
..
12d8dd2
100644
(file)
--- 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(..),
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.)
import CmdLineParser
-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
@@
-44,7
+44,7
@@
import Outputable
import SrcLoc
import Util
import Panic
import SrcLoc
import Util
import Panic
--- import MonadUtils ( liftIO )
+import MonadUtils ( liftIO )
-- Imports for --abi-hash
import LoadIface ( loadUserInterface )
-- Imports for --abi-hash
import LoadIface ( loadUserInterface )
@@
-78,7
+78,8
@@
import Data.Maybe
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
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
-- 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
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
-- 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
---------------- 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
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
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
showNumVersionMode = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
-printMode :: String -> Mode
-printMode str = mkPreStartupMode (Print str)
-
mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = Left
mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = Left
@@
-384,8
+381,10
@@
showGhcUsageMode = mkPreLoadMode ShowGhcUsage
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
showInfoMode = mkPreLoadMode ShowInfo
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
mkPreLoadMode :: PreLoadMode -> Mode
mkPreLoadMode = Right . Left
@@
-497,62
+496,59
@@
mode_flags :: [Flag ModeM]
mode_flags =
[ ------- help / version ----------------------------------------------
Flag "?" (PassFlag (setMode showGhcUsageMode))
mode_flags =
[ ------- help / version ----------------------------------------------
Flag "?" (PassFlag (setMode showGhcUsageMode))
- Supported
, Flag "-help" (PassFlag (setMode showGhcUsageMode))
, Flag "-help" (PassFlag (setMode showGhcUsageMode))
- Supported
, Flag "V" (PassFlag (setMode showVersionMode))
, Flag "V" (PassFlag (setMode showVersionMode))
- Supported
, Flag "-version" (PassFlag (setMode showVersionMode))
, Flag "-version" (PassFlag (setMode showVersionMode))
- Supported
, Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
, Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
- Supported
, Flag "-info" (PassFlag (setMode showInfoMode))
, Flag "-info" (PassFlag (setMode showInfoMode))
- Supported
, Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
, Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
- Supported
, Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
, Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
- Supported
] ++
] ++
- [ Flag k' (PassFlag (setMode mode))
- Supported
- | (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
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)
"--show-iface"))
] ++
------- interfaces ----------------------------------------------------
[ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
"--show-iface"))
- Supported
------- primary modes ------------------------------------------------
, Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
addFlag "-no-link" f))
------- primary modes ------------------------------------------------
, Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
addFlag "-no-link" f))
- Supported
, Flag "M" (PassFlag (setMode doMkDependHSMode))
, Flag "M" (PassFlag (setMode doMkDependHSMode))
- Supported
, Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
, Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
- Supported
, Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
addFlag "-fvia-C" f))
, Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
addFlag "-fvia-C" f))
- Supported
, Flag "S" (PassFlag (setMode (stopBeforeMode As)))
, Flag "S" (PassFlag (setMode (stopBeforeMode As)))
- Supported
, Flag "-make" (PassFlag (setMode doMakeMode))
, Flag "-make" (PassFlag (setMode doMakeMode))
- Supported
, Flag "-interactive" (PassFlag (setMode doInteractiveMode))
, Flag "-interactive" (PassFlag (setMode doInteractiveMode))
- Supported
, Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))
, Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))
- Supported
, Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
, Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
- Supported
]
]
-setMode :: Mode -> String -> ModeM ()
-setMode newMode newFlag = do
+setMode :: Mode -> String -> EwM ModeM ()
+setMode newMode newFlag = liftEwM $ do
(mModeFlag, errs, flags') <- getCmdLineState
let (modeFlag', errs') =
case mModeFlag of
(mModeFlag, errs, flags') <- getCmdLineState
let (modeFlag', errs') =
case mModeFlag of
@@
-595,8
+591,8
@@
flagMismatchErr :: String -> String -> String
flagMismatchErr oldFlag newFlag
= "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
flagMismatchErr oldFlag newFlag
= "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
-addFlag :: String -> String -> ModeM ()
-addFlag s flag = do
+addFlag :: String -> String -> EwM ModeM ()
+addFlag s flag = liftEwM $ do
(m, e, flags') <- getCmdLineState
putCmdLineState (m, e, mkGeneralLocated loc s : flags')
where loc = "addFlag by " ++ flag ++ " on the commandline"
(m, e, flags') <- getCmdLineState
putCmdLineState (m, e, mkGeneralLocated loc s : flags')
where loc = "addFlag by " ++ flag ++ " on the commandline"
@@
-611,7
+607,7
@@
doMake srcs = do
haskellish (f,Nothing) =
looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
haskellish (_,Just phase) =
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
hsc_env <- GHC.getSession
@@
-620,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)
-- 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
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)
non_hs_srcs
liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
@@
-643,7
+636,7
@@
doMake srcs = do
doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
- hsc_env <- newHscEnv defaultCallbacks dflags
+ hsc_env <- newHscEnv dflags
showIface hsc_env file
-- ---------------------------------------------------------------------------
showIface hsc_env file
-- ---------------------------------------------------------------------------
@@
-662,7
+655,7
@@
showBanner _postLoadMode dflags = do
when (verb >= 2) $
do hPutStr stderr "Glasgow Haskell Compiler, Version "
hPutStr stderr cProjectVersion
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
hPutStr stderr cStage
hPutStr stderr " booted by GHC version "
hPutStrLn stderr cBooterVersion
@@
-672,9
+665,7
@@
showBanner _postLoadMode dflags = do
showInfo :: DynFlags -> IO ()
showInfo dflags = do
let sq x = " [" ++ x ++ "\n ]"
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
showSupportedExtensions :: IO ()
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions