Commit e2b57381 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Allow proper errors/warnings in core2core passes

This patch makes it possible for core-to-core passes to emit
proper error messages and warnings.

  * New function CoreMonad.warnMsg

  * CoreMonad.warnMsg and errorMsg now print a proper warning/error
    message heading.

  * CoreMonad carries a SrcSpan, which is used in warning/error
    messages.  It is initialised to be the source file name, but
    a core-to-core pass could set it more specifically if it had
    better location information.

There was a bit of plumbing needed to get the filename to the
right place.
parent 575abf42
...@@ -41,6 +41,7 @@ module SrcLoc ( ...@@ -41,6 +41,7 @@ module SrcLoc (
mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
noSrcSpan, noSrcSpan,
wiredInSrcSpan, -- Something wired into the compiler wiredInSrcSpan, -- Something wired into the compiler
interactiveSrcSpan,
srcLocSpan, realSrcLocSpan, srcLocSpan, realSrcLocSpan,
combineSrcSpans, combineSrcSpans,
...@@ -131,7 +132,7 @@ mkRealSrcLoc x line col = SrcLoc x line col ...@@ -131,7 +132,7 @@ mkRealSrcLoc x line col = SrcLoc x line col
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
noSrcLoc = UnhelpfulLoc (fsLit "<no location info>") noSrcLoc = UnhelpfulLoc (fsLit "<no location info>")
generatedSrcLoc = UnhelpfulLoc (fsLit "<compiler-generated code>") 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 -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
mkGeneralSrcLoc :: FastString -> SrcLoc mkGeneralSrcLoc :: FastString -> SrcLoc
...@@ -278,9 +279,10 @@ data SrcSpan = ...@@ -278,9 +279,10 @@ data SrcSpan =
-- derive Show for Token -- derive Show for Token
-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
noSrcSpan, wiredInSrcSpan :: SrcSpan noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
noSrcSpan = UnhelpfulSpan (fsLit "<no location info>") noSrcSpan = UnhelpfulSpan (fsLit "<no location info>")
wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>") wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>")
interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")
-- | Create a "bad" 'SrcSpan' that has not location information -- | Create a "bad" 'SrcSpan' that has not location information
mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan :: FastString -> SrcSpan
......
...@@ -1905,7 +1905,8 @@ withoutAnnots pass guts = do ...@@ -1905,7 +1905,8 @@ withoutAnnots pass guts = do
liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
getUniqueSupplyM <*> getModule <*> getUniqueSupplyM <*> getModule <*>
getVisibleOrphanMods <*> getVisibleOrphanMods <*>
getPrintUnqualified <*> pure corem getPrintUnqualified <*> getSrcSpanM <*>
pure corem
-- Nuke existing ticks in module. -- Nuke existing ticks in module.
-- TODO: Ticks in unfoldings. Maybe change unfolding so it removes -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
-- them in absence of @Opt_Debug@? -- them in absence of @Opt_Debug@?
......
...@@ -171,6 +171,7 @@ deSugar hsc_env ...@@ -171,6 +171,7 @@ deSugar hsc_env
; let mod_guts = ModGuts { ; let mod_guts = ModGuts {
mg_module = mod, mg_module = mod,
mg_hsc_src = hsc_src, mg_hsc_src = hsc_src,
mg_loc = mkFileSrcSpan mod_loc,
mg_exports = exports, mg_exports = exports,
mg_deps = deps, mg_deps = deps,
mg_used_names = used_names, mg_used_names = used_names,
...@@ -200,6 +201,12 @@ deSugar hsc_env ...@@ -200,6 +201,12 @@ deSugar hsc_env
; return (msgs, Just mod_guts) ; 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 :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs dsImpSpecs imp_specs
= do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
......
...@@ -104,12 +104,25 @@ type WarnMsg = ErrMsg ...@@ -104,12 +104,25 @@ type WarnMsg = ErrMsg
data Severity data Severity
= SevOutput = SevOutput
| SevDump | SevFatal
| SevInteractive | SevInteractive
| SevDump
-- Log messagse intended for compiler developers
-- No file/line/column stuff
| SevInfo | SevInfo
-- Log messages intended for end users.
-- No file/line/column stuff.
| SevWarning | SevWarning
| SevError | 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 instance Show ErrMsg where
show em = errMsgShortString em show em = errMsgShortString em
......
...@@ -5,12 +5,13 @@ import SrcLoc (SrcSpan) ...@@ -5,12 +5,13 @@ import SrcLoc (SrcSpan)
data Severity data Severity
= SevOutput = SevOutput
| SevDump | SevFatal
| SevInteractive | SevInteractive
| SevDump
| SevInfo | SevInfo
| SevWarning | SevWarning
| SevError | SevError
| SevFatal
type MsgDoc = SDoc type MsgDoc = SDoc
......
...@@ -1643,6 +1643,8 @@ mkModGuts mod safe binds = ...@@ -1643,6 +1643,8 @@ mkModGuts mod safe binds =
ModGuts { ModGuts {
mg_module = mod, mg_module = mod,
mg_hsc_src = HsSrcFile, mg_hsc_src = HsSrcFile,
mg_loc = mkGeneralSrcSpan (moduleNameFS (moduleName mod)),
-- A bit crude
mg_exports = [], mg_exports = [],
mg_deps = noDependencies, mg_deps = noDependencies,
mg_dir_imps = emptyModuleEnv, mg_dir_imps = emptyModuleEnv,
......
...@@ -1054,6 +1054,7 @@ data ModGuts ...@@ -1054,6 +1054,7 @@ data ModGuts
= ModGuts { = ModGuts {
mg_module :: !Module, -- ^ Module being compiled mg_module :: !Module, -- ^ Module being compiled
mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module 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_exports :: ![AvailInfo], -- ^ What it exports
mg_deps :: !Dependencies, -- ^ What it depends on, directly or mg_deps :: !Dependencies, -- ^ What it depends on, directly or
-- otherwise -- otherwise
......
...@@ -28,7 +28,7 @@ module CoreMonad ( ...@@ -28,7 +28,7 @@ module CoreMonad (
getHscEnv, getRuleBase, getModule, getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache, getPackageFamInstEnv, getDynFlags, getOrigNameCache, getPackageFamInstEnv,
getVisibleOrphanMods, getVisibleOrphanMods,
getPrintUnqualified, getPrintUnqualified, getSrcSpanM,
-- ** Writing to the monad -- ** Writing to the monad
addSimplCount, addSimplCount,
...@@ -44,7 +44,7 @@ module CoreMonad ( ...@@ -44,7 +44,7 @@ module CoreMonad (
getAnnotations, getFirstAnnotations, getAnnotations, getFirstAnnotations,
-- ** Screen output -- ** Screen output
putMsg, putMsgS, errorMsg, errorMsgS, putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
fatalErrorMsg, fatalErrorMsgS, fatalErrorMsg, fatalErrorMsgS,
debugTraceMsg, debugTraceMsgS, debugTraceMsg, debugTraceMsgS,
dumpIfSet_dyn, dumpIfSet_dyn,
...@@ -74,11 +74,12 @@ import Var ...@@ -74,11 +74,12 @@ import Var
import Outputable import Outputable
import FastString import FastString
import qualified ErrUtils as Err import qualified ErrUtils as Err
import ErrUtils( Severity(..) )
import Maybes import Maybes
import UniqSupply import UniqSupply
import UniqFM ( UniqFM, mapUFM, filterUFM ) import UniqFM ( UniqFM, mapUFM, filterUFM )
import MonadUtils import MonadUtils
import SrcLoc
import ListSetOps ( runs ) import ListSetOps ( runs )
import Data.List import Data.List
import Data.Ord import Data.Ord
...@@ -516,11 +517,13 @@ newtype CoreState = CoreState { ...@@ -516,11 +517,13 @@ newtype CoreState = CoreState {
} }
data CoreReader = CoreReader { data CoreReader = CoreReader {
cr_hsc_env :: HscEnv, cr_hsc_env :: HscEnv,
cr_rule_base :: RuleBase, cr_rule_base :: RuleBase,
cr_module :: Module, 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_visible_orphan_mods :: !ModuleSet,
cr_print_unqual :: PrintUnqualified,
#ifdef GHCI #ifdef GHCI
cr_globals :: (MVar PersistentLinkerState, Bool) cr_globals :: (MVar PersistentLinkerState, Bool)
#else #else
...@@ -599,11 +602,12 @@ runCoreM :: HscEnv ...@@ -599,11 +602,12 @@ runCoreM :: HscEnv
-> Module -> Module
-> ModuleSet -> ModuleSet
-> PrintUnqualified -> PrintUnqualified
-> SrcSpan
-> CoreM a -> CoreM a
-> IO (a, SimplCount) -> IO (a, SimplCount)
runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
glbls <- saveLinkerGlobals = do { glbls <- saveLinkerGlobals
liftM extract $ runIOEnv (reader glbls) $ unCoreM m state ; liftM extract $ runIOEnv (reader glbls) $ unCoreM m state }
where where
reader glbls = CoreReader { reader glbls = CoreReader {
cr_hsc_env = hsc_env, cr_hsc_env = hsc_env,
...@@ -611,7 +615,8 @@ runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do ...@@ -611,7 +615,8 @@ runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do
cr_module = mod, cr_module = mod,
cr_visible_orphan_mods = orph_imps, cr_visible_orphan_mods = orph_imps,
cr_globals = glbls, cr_globals = glbls,
cr_print_unqual = print_unqual cr_print_unqual = print_unqual,
cr_loc = loc
} }
state = CoreState { state = CoreState {
cs_uniq_supply = us cs_uniq_supply = us
...@@ -678,6 +683,9 @@ getVisibleOrphanMods = read cr_visible_orphan_mods ...@@ -678,6 +683,9 @@ getVisibleOrphanMods = read cr_visible_orphan_mods
getPrintUnqualified :: CoreM PrintUnqualified getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified = read cr_print_unqual getPrintUnqualified = read cr_print_unqual
getSrcSpanM :: CoreM SrcSpan
getSrcSpanM = read cr_loc
addSimplCount :: SimplCount -> CoreM () addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count }) addSimplCount count = write (CoreWriter { cw_simpl_count = count })
...@@ -810,10 +818,21 @@ we aren't using annotations heavily. ...@@ -810,10 +818,21 @@ we aren't using annotations heavily.
************************************************************************ ************************************************************************
-} -}
msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM () msg :: Severity -> SDoc -> CoreM ()
msg how doc = do msg sev doc
dflags <- getDynFlags = do { dflags <- getDynFlags
liftIO $ how dflags doc ; 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 -- | Output a String message to the screen
putMsgS :: String -> CoreM () putMsgS :: String -> CoreM ()
...@@ -821,7 +840,7 @@ putMsgS = putMsg . text ...@@ -821,7 +840,7 @@ putMsgS = putMsg . text
-- | Output a message to the screen -- | Output a message to the screen
putMsg :: SDoc -> CoreM () putMsg :: SDoc -> CoreM ()
putMsg = msg Err.putMsg putMsg = msg SevInfo
-- | Output a string error to the screen -- | Output a string error to the screen
errorMsgS :: String -> CoreM () errorMsgS :: String -> CoreM ()
...@@ -829,7 +848,10 @@ errorMsgS = errorMsg . text ...@@ -829,7 +848,10 @@ errorMsgS = errorMsg . text
-- | Output an error to the screen -- | Output an error to the screen
errorMsg :: SDoc -> CoreM () 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 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
fatalErrorMsgS :: String -> CoreM () fatalErrorMsgS :: String -> CoreM ()
...@@ -837,7 +859,7 @@ fatalErrorMsgS = fatalErrorMsg . text ...@@ -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 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
fatalErrorMsg :: SDoc -> CoreM () fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg = msg Err.fatalErrorMsg fatalErrorMsg = msg SevFatal
-- | Output a string debugging message at verbosity level of @-v@ or higher -- | Output a string debugging message at verbosity level of @-v@ or higher
debugTraceMsgS :: String -> CoreM () debugTraceMsgS :: String -> CoreM ()
...@@ -845,11 +867,15 @@ debugTraceMsgS = debugTraceMsg . text ...@@ -845,11 +867,15 @@ debugTraceMsgS = debugTraceMsg . text
-- | Outputs a debugging message at verbosity level of @-v@ or higher -- | Outputs a debugging message at verbosity level of @-v@ or higher
debugTraceMsg :: SDoc -> CoreM () 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 -- | 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 :: 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 }
{- {-
************************************************************************ ************************************************************************
......
...@@ -68,15 +68,18 @@ import Plugins ( installCoreToDos ) ...@@ -68,15 +68,18 @@ import Plugins ( installCoreToDos )
-} -}
core2core :: HscEnv -> ModGuts -> IO ModGuts 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' = do { us <- mkSplitUniqSupply 's'
-- make sure all plugins are loaded -- make sure all plugins are loaded
; let builtin_passes = getCoreToDo dflags ; 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 ; (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 do { all_passes <- addPluginPasses builtin_passes
; runCorePasses all_passes guts } ; runCorePasses all_passes guts }
...@@ -87,15 +90,14 @@ core2core hsc_env guts ...@@ -87,15 +90,14 @@ core2core hsc_env guts
; return guts2 } ; return guts2 }
where where
dflags = hsc_dflags hsc_env 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 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. -- 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 -- 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 -- 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 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
-- would mean our cached value would go out of date. -- would mean our cached value would go out of date.
print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
{- {-
************************************************************************ ************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment