diff options
-rw-r--r-- | compiler/basicTypes/SrcLoc.hs | 10 | ||||
-rw-r--r-- | compiler/coreSyn/CoreLint.hs | 3 | ||||
-rw-r--r-- | compiler/deSugar/Desugar.hs | 7 | ||||
-rw-r--r-- | compiler/main/ErrUtils.hs | 17 | ||||
-rw-r--r-- | compiler/main/ErrUtils.hs-boot | 5 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 2 | ||||
-rw-r--r-- | compiler/main/HscTypes.hs | 1 | ||||
-rw-r--r-- | compiler/simplCore/CoreMonad.hs | 66 | ||||
-rw-r--r-- | compiler/simplCore/SimplCore.hs | 14 |
9 files changed, 90 insertions, 35 deletions
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 362a925992..65d7e71ac9 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -41,6 +41,7 @@ module SrcLoc ( mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, noSrcSpan, wiredInSrcSpan, -- Something wired into the compiler + interactiveSrcSpan, srcLocSpan, realSrcLocSpan, combineSrcSpans, @@ -131,7 +132,7 @@ mkRealSrcLoc x line col = SrcLoc x line col noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc noSrcLoc = UnhelpfulLoc (fsLit "<no location info>") generatedSrcLoc = UnhelpfulLoc (fsLit "<compiler-generated code>") -interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>") +interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>") -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location mkGeneralSrcLoc :: FastString -> SrcLoc @@ -278,9 +279,10 @@ data SrcSpan = -- derive Show for Token -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -noSrcSpan, wiredInSrcSpan :: SrcSpan -noSrcSpan = UnhelpfulSpan (fsLit "<no location info>") -wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>") +noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan (fsLit "<no location info>") +wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>") +interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>") -- | Create a "bad" 'SrcSpan' that has not location information mkGeneralSrcSpan :: FastString -> SrcSpan diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 5bf2d4f1d2..2b1118e69b 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1905,7 +1905,8 @@ withoutAnnots pass guts = do liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> getUniqueSupplyM <*> getModule <*> getVisibleOrphanMods <*> - getPrintUnqualified <*> pure corem + getPrintUnqualified <*> getSrcSpanM <*> + pure corem -- Nuke existing ticks in module. -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes -- them in absence of @Opt_Debug@? diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 09e2554b05..94ee7faab3 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -171,6 +171,7 @@ deSugar hsc_env ; let mod_guts = ModGuts { mg_module = mod, mg_hsc_src = hsc_src, + mg_loc = mkFileSrcSpan mod_loc, mg_exports = exports, mg_deps = deps, mg_used_names = used_names, @@ -200,6 +201,12 @@ deSugar hsc_env ; return (msgs, Just mod_guts) }}} +mkFileSrcSpan :: ModLocation -> SrcSpan +mkFileSrcSpan mod_loc + = case ml_hs_file mod_loc of + Just file_path -> mkGeneralSrcSpan (mkFastString file_path) + Nothing -> interactiveSrcSpan -- Presumably + dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) dsImpSpecs imp_specs = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 1155b4b874..3a7d9ece23 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -104,12 +104,25 @@ type WarnMsg = ErrMsg data Severity = SevOutput - | SevDump + | SevFatal | SevInteractive + + | SevDump + -- Log messagse intended for compiler developers + -- No file/line/column stuff + | SevInfo + -- Log messages intended for end users. + -- No file/line/column stuff. + | SevWarning | SevError - | SevFatal + -- SevWarning and SevError are used for warnings and errors + -- o The message has a file/line/column heading, + -- plus "warning:" or "error:", + -- added by mkLocMessags + -- o Output is intended for end users + instance Show ErrMsg where show em = errMsgShortString em diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot index ac1673b367..31edcc05ee 100644 --- a/compiler/main/ErrUtils.hs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -5,12 +5,13 @@ import SrcLoc (SrcSpan) data Severity = SevOutput - | SevDump + | SevFatal | SevInteractive + | SevDump | SevInfo | SevWarning | SevError - | SevFatal + type MsgDoc = SDoc diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 328655c6d0..c7cabe6f9a 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1643,6 +1643,8 @@ mkModGuts mod safe binds = ModGuts { mg_module = mod, mg_hsc_src = HsSrcFile, + mg_loc = mkGeneralSrcSpan (moduleNameFS (moduleName mod)), + -- A bit crude mg_exports = [], mg_deps = noDependencies, mg_dir_imps = emptyModuleEnv, diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 7bceda50f6..b3ae6714db 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1054,6 +1054,7 @@ data ModGuts = ModGuts { mg_module :: !Module, -- ^ Module being compiled mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module + mg_loc :: SrcSpan, -- ^ For error messages from inner passes mg_exports :: ![AvailInfo], -- ^ What it exports mg_deps :: !Dependencies, -- ^ What it depends on, directly or -- otherwise diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index fc69fdc681..68b613bc19 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -28,7 +28,7 @@ module CoreMonad ( getHscEnv, getRuleBase, getModule, getDynFlags, getOrigNameCache, getPackageFamInstEnv, getVisibleOrphanMods, - getPrintUnqualified, + getPrintUnqualified, getSrcSpanM, -- ** Writing to the monad addSimplCount, @@ -44,7 +44,7 @@ module CoreMonad ( getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, + putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, dumpIfSet_dyn, @@ -74,11 +74,12 @@ import Var import Outputable import FastString import qualified ErrUtils as Err +import ErrUtils( Severity(..) ) import Maybes import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) import MonadUtils - +import SrcLoc import ListSetOps ( runs ) import Data.List import Data.Ord @@ -516,11 +517,13 @@ newtype CoreState = CoreState { } data CoreReader = CoreReader { - cr_hsc_env :: HscEnv, - cr_rule_base :: RuleBase, - cr_module :: Module, + cr_hsc_env :: HscEnv, + cr_rule_base :: RuleBase, + cr_module :: Module, + cr_print_unqual :: PrintUnqualified, + cr_loc :: SrcSpan, -- Use this for log/error messages so they + -- are at least tagged with the right source file cr_visible_orphan_mods :: !ModuleSet, - cr_print_unqual :: PrintUnqualified, #ifdef GHCI cr_globals :: (MVar PersistentLinkerState, Bool) #else @@ -599,11 +602,12 @@ runCoreM :: HscEnv -> Module -> ModuleSet -> PrintUnqualified + -> SrcSpan -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do - glbls <- saveLinkerGlobals - liftM extract $ runIOEnv (reader glbls) $ unCoreM m state +runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m + = do { glbls <- saveLinkerGlobals + ; liftM extract $ runIOEnv (reader glbls) $ unCoreM m state } where reader glbls = CoreReader { cr_hsc_env = hsc_env, @@ -611,7 +615,8 @@ runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do cr_module = mod, cr_visible_orphan_mods = orph_imps, cr_globals = glbls, - cr_print_unqual = print_unqual + cr_print_unqual = print_unqual, + cr_loc = loc } state = CoreState { cs_uniq_supply = us @@ -678,6 +683,9 @@ getVisibleOrphanMods = read cr_visible_orphan_mods getPrintUnqualified :: CoreM PrintUnqualified getPrintUnqualified = read cr_print_unqual +getSrcSpanM :: CoreM SrcSpan +getSrcSpanM = read cr_loc + addSimplCount :: SimplCount -> CoreM () addSimplCount count = write (CoreWriter { cw_simpl_count = count }) @@ -810,10 +818,21 @@ we aren't using annotations heavily. ************************************************************************ -} -msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM () -msg how doc = do - dflags <- getDynFlags - liftIO $ how dflags doc +msg :: Severity -> SDoc -> CoreM () +msg sev doc + = do { dflags <- getDynFlags + ; loc <- getSrcSpanM + ; unqual <- getPrintUnqualified + ; let sty = case sev of + SevError -> err_sty + SevWarning -> err_sty + SevDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle dflags unqual + user_sty = mkUserStyle unqual AllTheWay + dump_sty = mkDumpStyle unqual + ; liftIO $ + (log_action dflags) dflags sev loc sty doc } -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -821,7 +840,7 @@ putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () -putMsg = msg Err.putMsg +putMsg = msg SevInfo -- | Output a string error to the screen errorMsgS :: String -> CoreM () @@ -829,7 +848,10 @@ errorMsgS = errorMsg . text -- | Output an error to the screen errorMsg :: SDoc -> CoreM () -errorMsg = msg Err.errorMsg +errorMsg = msg SevError + +warnMsg :: SDoc -> CoreM () +warnMsg = msg SevWarning -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die fatalErrorMsgS :: String -> CoreM () @@ -837,7 +859,7 @@ fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg Err.fatalErrorMsg +fatalErrorMsg = msg SevFatal -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () @@ -845,11 +867,15 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg (flip Err.debugTraceMsg 3) +debugTraceMsg = msg SevDump -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () -dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str) +dumpIfSet_dyn flag str doc + = do { dflags <- getDynFlags + ; unqual <- getPrintUnqualified + ; when (dopt flag dflags) $ liftIO $ + Err.dumpSDoc dflags unqual flag str doc } {- ************************************************************************ diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 73cdd704f4..90233d608a 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -68,15 +68,18 @@ import Plugins ( installCoreToDos ) -} core2core :: HscEnv -> ModGuts -> IO ModGuts -core2core hsc_env guts +core2core hsc_env guts@(ModGuts { mg_module = mod + , mg_loc = loc + , mg_deps = deps + , mg_rdr_env = rdr_env }) = do { us <- mkSplitUniqSupply 's' -- make sure all plugins are loaded ; let builtin_passes = getCoreToDo dflags - orph_mods = mkModuleSet (mg_module guts : dep_orphs (mg_deps guts)) + orph_mods = mkModuleSet (mod : dep_orphs deps) ; ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod - orph_mods print_unqual $ + orph_mods print_unqual loc $ do { all_passes <- addPluginPasses builtin_passes ; runCorePasses all_passes guts } @@ -87,15 +90,14 @@ core2core hsc_env guts ; return guts2 } where dflags = hsc_dflags hsc_env - home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts)) + home_pkg_rules = hptRules hsc_env (dep_mods deps) hpt_rule_base = mkRuleBase home_pkg_rules - mod = mg_module guts + print_unqual = mkPrintUnqualified dflags rdr_env -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to -- consume the ModGuts to find the module) but somewhat ugly because mg_module may -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. - print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts) {- ************************************************************************ |