[Git][ghc/ghc][master] Fix #16282.
Ben Gamari
gitlab at gitlab.haskell.org
Sun Apr 7 19:22:04 UTC 2019
Ben Gamari pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3a38ea44 by Eric Crockett at 2019-04-07T19:21:59Z
Fix #16282.
Previously, -W(all-)missed-specs was created with 'NoReason',
so no information about the flag was printed along with the warning.
Now, -Wall-missed-specs is listed as the Reason if it was set,
otherwise -Wmissed-specs is listed as the reason.
- - - - -
5 changed files:
- compiler/simplCore/CoreMonad.hs
- compiler/specialise/Specialise.hs
- + testsuite/tests/warnings/should_compile/T16282/T16282.hs
- + testsuite/tests/warnings/should_compile/T16282/T16282.stderr
- + testsuite/tests/warnings/should_compile/T16282/all.T
Changes:
=====================================
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 ()
=====================================
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]
=====================================
testsuite/tests/warnings/should_compile/T16282/T16282.hs
=====================================
@@ -0,0 +1,14 @@
+import Data.Map
+
+-- If someone improves the specializer so that
+-- GHC no longer misses the specialization below,
+-- then this test will fail, as it expects a warning
+-- to be issued.
+-- Another reason this could fail is due to spelling:
+-- the test checks for the "specialisation" spelling,
+-- but due to changes in how the warnings are listed in DynFalgs.hs
+-- the compiler may spit out the "specialization" spelling.
+main :: IO ()
+main = do
+ let m = [] :: [Map String Bool]
+ mapM_ print m
=====================================
testsuite/tests/warnings/should_compile/T16282/T16282.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T16282.hs: warning: [-Wall-missed-specialisations]
+ Could not specialise imported function ‘Data.Map.Internal.$w$cshowsPrec’
+ when specialising ‘Data.Map.Internal.$fShowMap_$cshowsPrec’
+ Probable fix: add INLINABLE pragma on ‘Data.Map.Internal.$w$cshowsPrec’
=====================================
testsuite/tests/warnings/should_compile/T16282/all.T
=====================================
@@ -0,0 +1 @@
+test('T16282', normal, compile, ['-O2 -Wall-missed-specialisations'])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/3a38ea4487173f0f8e3693a75d1c5c7d33f12f05
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/3a38ea4487173f0f8e3693a75d1c5c7d33f12f05
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190407/c3106810/attachment-0001.html>
More information about the ghc-commits
mailing list