diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 16 | ||||
| -rw-r--r-- | compiler/specialise/Specialise.hs | 39 |
2 files changed, 31 insertions, 24 deletions
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index d99686aa20..013b1414ee 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -778,8 +778,8 @@ we aren't using annotations heavily. ************************************************************************ -} -msg :: Severity -> SDoc -> CoreM () -msg sev doc +msg :: Severity -> WarnReason -> SDoc -> CoreM () +msg sev reason doc = do { dflags <- getDynFlags ; loc <- getSrcSpanM ; unqual <- getPrintUnqualified @@ -791,7 +791,7 @@ msg sev doc err_sty = mkErrStyle dflags unqual user_sty = mkUserStyle dflags unqual AllTheWay dump_sty = mkDumpStyle dflags unqual - ; liftIO $ putLogMsg dflags NoReason sev loc sty doc } + ; liftIO $ putLogMsg dflags reason sev loc sty doc } -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -799,7 +799,7 @@ putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () -putMsg = msg SevInfo +putMsg = msg SevInfo NoReason -- | Output an error to the screen. Does not cause the compiler to die. errorMsgS :: String -> CoreM () @@ -807,9 +807,9 @@ errorMsgS = errorMsg . text -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () -errorMsg = msg SevError +errorMsg = msg SevError NoReason -warnMsg :: SDoc -> CoreM () +warnMsg :: WarnReason -> SDoc -> CoreM () warnMsg = msg SevWarning -- | Output a fatal error to the screen. Does not cause the compiler to die. @@ -818,7 +818,7 @@ fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg SevFatal +fatalErrorMsg = msg SevFatal NoReason -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () @@ -826,7 +826,7 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg SevDump +debugTraceMsg = msg SevDump NoReason -- | 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 () diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index c62789017f..9d87abc1ad 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -730,28 +730,35 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn ; return (rules2 ++ rules1, final_binds) } - | warnMissingSpecs dflags callers - = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn)) - 2 (vcat [ text "when specialising" <+> quotes (ppr caller) - | caller <- callers]) - , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) - , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) - ; return ([], []) } + | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn + ; return ([], [])} - | otherwise - = return ([], []) where unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers -warnMissingSpecs :: DynFlags -> [Id] -> Bool +-- | Returns whether or not to show a missed-spec warning. +-- If -Wall-missed-specializations is on, show the warning. +-- Otherwise, if -Wmissed-specializations is on, only show a warning +-- if there is at least one imported function being specialized, +-- and if all imported functions are marked with an inline pragma +-- Use the most specific warning as the reason. +tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () -- See Note [Warning about missed specialisations] -warnMissingSpecs dflags callers - | wopt Opt_WarnAllMissedSpecs dflags = True - | not (wopt Opt_WarnMissedSpecs dflags) = False - | null callers = False - | otherwise = all has_inline_prag callers +tryWarnMissingSpecs dflags callers fn calls_for_fn + | wopt Opt_WarnMissedSpecs dflags + && not (null callers) + && allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs + | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ Reason Opt_WarnAllMissedSpecs + | otherwise = return () where - has_inline_prag id = isAnyInlinePragma (idInlinePragma id) + allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers + doWarn reason = + warnMsg reason + (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) + 2 (vcat [ text "when specialising" <+> quotes (ppr caller) + | caller <- callers]) + , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) wantSpecImport :: DynFlags -> Unfolding -> Bool -- See Note [Specialise imported INLINABLE things] |