[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: -Wunused-pattern-binds: Recurse into patterns to check whether there's a splice
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Sep 15 11:43:13 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3828ed3c by Matthew Pickering at 2022-09-15T07:42:49-04:00
-Wunused-pattern-binds: Recurse into patterns to check whether there's a splice
See the examples in #22057 which show we have to traverse deeply into a
pattern to determine whether it contains a splice or not. The original
implementation pointed this out but deemed this very shallow traversal
"too expensive".
Fixes #22057
I also fixed an oversight in !7821 which meant we lost a warning which
was present in 9.2.2.
Fixes #22067
- - - - -
c742e8e7 by Bodigrim at 2022-09-15T07:42:53-04:00
Avoid partial head and tail in ghc-heap; replace with total pattern-matching
- - - - -
7 changed files:
- compiler/GHC/Rename/Bind.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc
- + testsuite/tests/rename/should_compile/T22057.hs
- + testsuite/tests/rename/should_compile/T22067.hs
- + testsuite/tests/rename/should_compile/T22067.stderr
- testsuite/tests/rename/should_compile/all.T
Changes:
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -493,18 +493,10 @@ rnBind _ bind@(PatBind { pat_lhs = pat
bind' = bind { pat_rhs = grhss'
, pat_ext = fvs' }
- ok_nobind_pat
- = -- See Note [Pattern bindings that bind no variables]
- case unLoc pat of
- WildPat {} -> True
- BangPat {} -> True -- #9127, #13646
- SplicePat {} -> True
- _ -> False
-
-- Warn if the pattern binds no variables
-- See Note [Pattern bindings that bind no variables]
; whenWOptM Opt_WarnUnusedPatternBinds $
- when (null bndrs && not ok_nobind_pat) $
+ when (null bndrs && not (isOkNoBindPattern pat)) $
addTcRnDiagnostic (TcRnUnusedPatternBinds bind')
; fvs' `seq` -- See Note [Free-variable space leak]
@@ -540,29 +532,66 @@ rnBind sig_fn (PatSynBind x bind)
rnBind _ b = pprPanic "rnBind" (ppr b)
+ -- See Note [Pattern bindings that bind no variables]
+isOkNoBindPattern :: LPat GhcRn -> Bool
+isOkNoBindPattern (L _ pat) =
+ case pat of
+ WildPat{} -> True -- Exception (1)
+ BangPat {} -> True -- Exception (2) #9127, #13646
+ p -> patternContainsSplice p -- Exception (3)
+
+ where
+ lpatternContainsSplice :: LPat GhcRn -> Bool
+ lpatternContainsSplice (L _ p) = patternContainsSplice p
+ patternContainsSplice :: Pat GhcRn -> Bool
+ patternContainsSplice p =
+ case p of
+ -- A top-level splice has been evaluated by this point, so we know the pattern it is evaluated to
+ SplicePat (HsUntypedSpliceTop _ p) _ -> patternContainsSplice p
+ -- A nested splice isn't evaluated so we can't guess what it will expand to
+ SplicePat (HsUntypedSpliceNested {}) _ -> True
+ -- The base cases
+ VarPat {} -> False
+ WildPat {} -> False
+ LitPat {} -> False
+ NPat {} -> False
+ NPlusKPat {} -> False
+ -- Recursive cases
+ BangPat _ lp -> lpatternContainsSplice lp
+ LazyPat _ lp -> lpatternContainsSplice lp
+ AsPat _ _ _ lp -> lpatternContainsSplice lp
+ ParPat _ _ lp _ -> lpatternContainsSplice lp
+ ViewPat _ _ lp -> lpatternContainsSplice lp
+ SigPat _ lp _ -> lpatternContainsSplice lp
+ ListPat _ lps -> any lpatternContainsSplice lps
+ TuplePat _ lps _ -> any lpatternContainsSplice lps
+ SumPat _ lp _ _ -> lpatternContainsSplice lp
+ ConPat _ _ cpd -> any lpatternContainsSplice (hsConPatArgs cpd)
+ XPat (HsPatExpanded _orig new) -> patternContainsSplice new
+
{- Note [Pattern bindings that bind no variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally, we want to warn about pattern bindings like
Just _ = e
because they don't do anything! But we have three exceptions:
-* A wildcard pattern
+(1) A wildcard pattern
_ = rhs
which (a) is not that different from _v = rhs
(b) is sometimes used to give a type sig for,
or an occurrence of, a variable on the RHS
-* A strict pattern binding; that is, one with an outermost bang
+(2) A strict pattern binding; that is, one with an outermost bang
!Just _ = e
This can fail, so unlike the lazy variant, it is not a no-op.
Moreover, #13646 argues that even for single constructor
types, you might want to write the constructor. See also #9127.
-* A splice pattern
+(3) A splice pattern
$(th-lhs) = rhs
It is impossible to determine whether or not th-lhs really
- binds any variable. We should disable the warning for any pattern
- which contain splices, but that is a more expensive check.
+ binds any variable. You have to recurse all the way into the pattern to check
+ it doesn't contain any splices like this. See #22057.
Note [Free-variable space leak]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -71,7 +71,6 @@ import GHC.Exts.Heap.Utils
import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI
-import Control.Monad
import Data.Bits
import Foreign
import GHC.Exts
@@ -221,135 +220,119 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
t | t >= THUNK && t <= THUNK_STATIC -> do
pure $ ThunkClosure itbl pts npts
- THUNK_SELECTOR -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
- pure $ SelectorClosure itbl (head pts)
+ THUNK_SELECTOR -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
+ hd : _ -> pure $ SelectorClosure itbl hd
t | t >= FUN && t <= FUN_STATIC -> do
pure $ FunClosure itbl pts npts
- AP -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to AP"
- -- We expect at least the arity, n_args, and fun fields
- unless (length payloadWords >= 2) $
- fail "Expected at least 2 raw words to AP"
- let splitWord = payloadWords !! 0
- pure $ APClosure itbl
+ AP -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to AP"
+ hd : tl -> case payloadWords of
+ -- We expect at least the arity, n_args, and fun fields
+ splitWord : _ : _ ->
+ pure $ APClosure itbl
#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
- (head pts) (tail pts)
-
- PAP -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to PAP"
- -- We expect at least the arity, n_args, and fun fields
- unless (length payloadWords >= 2) $
- fail "Expected at least 2 raw words to PAP"
- let splitWord = payloadWords !! 0
- pure $ PAPClosure itbl
+ hd tl
+ _ -> fail "Expected at least 2 raw words to AP"
+
+ PAP -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to PAP"
+ hd : tl -> case payloadWords of
+ -- We expect at least the arity, n_args, and fun fields
+ splitWord : _ : _ ->
+ pure $ PAPClosure itbl
#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
- (head pts) (tail pts)
-
- AP_STACK -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to AP_STACK"
- pure $ APStackClosure itbl (head pts) (tail pts)
-
- IND -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to IND"
- pure $ IndClosure itbl (head pts)
-
- IND_STATIC -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to IND_STATIC"
- pure $ IndClosure itbl (head pts)
-
- BLACKHOLE -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to BLACKHOLE"
- pure $ BlackholeClosure itbl (head pts)
-
- BCO -> do
- unless (length pts >= 3) $
- fail $ "Expected at least 3 ptr argument to BCO, found "
- ++ show (length pts)
- unless (length payloadWords >= 4) $
- fail $ "Expected at least 4 words to BCO, found "
- ++ show (length payloadWords)
- let splitWord = payloadWords !! 3
- pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
+ hd tl
+ _ -> fail "Expected at least 2 raw words to PAP"
+
+ AP_STACK -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to AP_STACK"
+ hd : tl -> pure $ APStackClosure itbl hd tl
+
+ IND -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to IND"
+ hd : _ -> pure $ IndClosure itbl hd
+
+ IND_STATIC -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to IND_STATIC"
+ hd : _ -> pure $ IndClosure itbl hd
+
+ BLACKHOLE -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to BLACKHOLE"
+ hd : _ -> pure $ BlackholeClosure itbl hd
+
+ BCO -> case pts of
+ pts0 : pts1 : pts2 : _ -> case payloadWords of
+ _ : _ : _ : splitWord : payloadRest ->
+ pure $ BCOClosure itbl pts0 pts1 pts2
#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
- (drop 4 payloadWords)
+ payloadRest
+ _ -> fail $ "Expected at least 4 words to BCO, found "
+ ++ show (length payloadWords)
+ _ -> fail $ "Expected at least 3 ptr argument to BCO, found "
+ ++ show (length pts)
- ARR_WORDS -> do
- unless (length payloadWords >= 1) $
- fail $ "Expected at least 1 words to ARR_WORDS, found "
+ ARR_WORDS -> case payloadWords of
+ [] -> fail $ "Expected at least 1 words to ARR_WORDS, found "
++ show (length payloadWords)
- pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords)
+ hd : tl -> pure $ ArrWordsClosure itbl hd tl
- t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
- unless (length payloadWords >= 2) $
- fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
+ t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+ p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts
+ _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
++ "found " ++ show (length payloadWords)
- pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts
- t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
- unless (length payloadWords >= 1) $
- fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
+ t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+ [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
++ "found " ++ show (length payloadWords)
- pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts
+ hd : _ -> pure $ SmallMutArrClosure itbl hd pts
- t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
- unless (length pts >= 1) $
- fail $ "Expected at least 1 words to MUT_VAR, found "
+ t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of
+ [] -> fail $ "Expected at least 1 words to MUT_VAR, found "
++ show (length pts)
- pure $ MutVarClosure itbl (head pts)
+ hd : _ -> pure $ MutVarClosure itbl hd
- t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
- unless (length pts >= 3) $
- fail $ "Expected at least 3 ptrs to MVAR, found "
+ t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of
+ pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2
+ _ -> fail $ "Expected at least 3 ptrs to MVAR, found "
++ show (length pts)
- pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
BLOCKING_QUEUE ->
pure $ OtherClosure itbl pts rawHeapWords
- -- pure $ BlockingQueueClosure itbl
- -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
- -- pure $ OtherClosure itbl pts rawHeapWords
- --
- WEAK -> do
- pure $ WeakClosure
+ WEAK -> case pts of
+ pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure
{ info = itbl
- , cfinalizers = pts !! 0
- , key = pts !! 1
- , value = pts !! 2
- , finalizer = pts !! 3
- , weakLink = case drop 4 pts of
+ , cfinalizers = pts0
+ , key = pts1
+ , value = pts2
+ , finalizer = pts3
+ , weakLink = case rest of
[] -> Nothing
[p] -> Just p
- _ -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts)
+ _ -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts)
}
+ _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts)
TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- pts
-> withArray rawHeapWords (\ptr -> do
fields <- FFIClosures.peekTSOFields decodeCCS ptr
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc
=====================================
@@ -110,11 +110,7 @@ parse (Ptr addr) = if not . all (>0) . fmap length $ [p,m,occ]
(m, occ)
= (intercalate "." $ reverse modWords, occWord)
where
- (modWords, occWord) =
- if length rest1 < 1 -- XXXXXXXXx YUKX
- --then error "getConDescAddress:parse:length rest1 < 1"
- then parseModOcc [] []
- else parseModOcc [] (tail rest1)
+ (modWords, occWord) = parseModOcc [] (drop 1 rest1)
-- We only look for dots if str could start with a module name,
-- i.e. if it starts with an upper case character.
-- Otherwise we might think that "X.:->" is the module name in
=====================================
testsuite/tests/rename/should_compile/T22057.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# OPTIONS -Wall #-}
+module Thing (thing) where
+
+import Language.Haskell.TH
+
+thing :: Q ()
+thing = do
+ name <- newName "x"
+ -- warning:
+ _ <- [| let ($(pure (VarP name)), _) = (3.0, 4.0) in $(pure (VarE name)) |]
+ -- warning:
+ _ <- [| let ($(pure (VarP name)) ) = 3.0 in $(pure (VarE name)) |]
+ -- no warning:
+ _ <- [| let $(pure (VarP name)) = 3.0 in $(pure (VarE name)) |]
+ return ()
=====================================
testsuite/tests/rename/should_compile/T22067.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TTT where
+
+a :: ()
+a = let () = () in ()
+
+b :: ()
+b = let $([p|()|]) = () in ()
+
=====================================
testsuite/tests/rename/should_compile/T22067.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T22067.hs:5:9: warning: [-Wunused-pattern-binds (in -Wextra, -Wunused-binds)]
+ This pattern-binding binds no variables: () = ()
+
+T22067.hs:8:9: warning: [-Wunused-pattern-binds (in -Wextra, -Wunused-binds)]
+ This pattern-binding binds no variables: (()) = ()
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -188,3 +188,5 @@ test('T18862', normal, compile, [''])
test('unused_haddock', normal, compile, ['-haddock -Wall'])
test('T19984', normal, compile, ['-fwarn-unticked-promoted-constructors'])
test('T21654', normal, compile, ['-Wunused-top-binds'])
+test('T22057', normal, compile, ['-Wall'])
+test('T22067', normal, compile, ['-Wall'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d8f299106344aca32a0d97aac4a02296617c3a4...c742e8e7b2c13fec8ad15485c7ff44457f0fc7d6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d8f299106344aca32a0d97aac4a02296617c3a4...c742e8e7b2c13fec8ad15485c7ff44457f0fc7d6
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/20220915/afc53ecc/attachment-0001.html>
More information about the ghc-commits
mailing list