summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/basicTypes/SrcLoc.hs10
-rw-r--r--compiler/coreSyn/CoreLint.hs3
-rw-r--r--compiler/deSugar/Desugar.hs7
-rw-r--r--compiler/main/ErrUtils.hs17
-rw-r--r--compiler/main/ErrUtils.hs-boot5
-rw-r--r--compiler/main/HscMain.hs2
-rw-r--r--compiler/main/HscTypes.hs1
-rw-r--r--compiler/simplCore/CoreMonad.hs66
-rw-r--r--compiler/simplCore/SimplCore.hs14
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)
{-
************************************************************************