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 (
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
......
......@@ -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@?
......
......@@ -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
......
......@@ -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
......
......@@ -5,12 +5,13 @@ import SrcLoc (SrcSpan)
data Severity
= SevOutput
| SevDump
| SevFatal
| SevInteractive
| SevDump
| SevInfo
| SevWarning
| SevError
| SevFatal
type MsgDoc = SDoc
......
......@@ -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,
......
......@@ -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
......
......@@ -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 }
{-
************************************************************************
......
......@@ -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)
{-
************************************************************************
......
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