[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