Core lint: Lint top-level non-rec bindings with correct RecFlag (#19516)wip/T19516

This patch arranges it so that top-level bindings are linted
group-by-group and with their correct `RecFlag`. Before, CoreLint
treated all top-level bindings as one big recursive group.

Fixes #19516.

2 files changed, 23 insertions, 15 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 168e33e189..46ecd8bed3 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -41,7 +41,7 @@ module GHC.Core (
         isId, cmpAltCon, cmpAlt, ltAlt,
 
         -- ** Simple 'Expr' access functions and predicates
-        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
+        decomposeBind, bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
         collectBinders, collectTyBinders, collectTyAndValBinders,
         collectNBinders,
         collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
@@ -2123,6 +2123,11 @@ exprToCoercion_maybe _             = Nothing
 ************************************************************************
 -}
 
+-- | Turn a binding group into a 'RecFlag' and a list of bindings.
+decomposeBind :: Bind b -> (RecFlag, [(b, Expr b)])
+decomposeBind (NonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])
+decomposeBind (Rec pairs)       = (Recursive,    pairs)
+
 -- | Extract every variable by this group
 bindersOf  :: Bind b -> [b]
 -- If you edit this function, you may need to update the GHC formalism
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 40de306802..cf6f8292be 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -476,14 +476,13 @@ lintCoreBindings dflags pass local_in_scope binds
     addLoc TopLevelBindings           $
     do { checkL (null dups) (dupVars dups)
        ; checkL (null ext_dups) (dupExtVars ext_dups)
-       ; lintRecBindings TopLevel all_pairs $ \_ ->
+       ; lintBindings TopLevel binds $ \_ ->
          return () }
   where
-    all_pairs = flattenBinds binds
      -- Put all the top-level binders in scope at the start
      -- This is because rewrite rules can bring something
      -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"
-    binders = map fst all_pairs
+    binders = bindersOfBinds binds
 
     flags = (defaultLintFlags dflags)
                { lf_check_global_ids = check_globals
@@ -596,19 +595,23 @@ Check a core binding, returning the list of variables bound.
 -- Returns a UsageEnv because this function is called in lintCoreExpr for
 -- Let
 
-lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
+lintBindings :: TopLevelFlag -> [CoreBind]
                 -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv])
-lintRecBindings top_lvl pairs thing_inside
-  = lintIdBndrs top_lvl bndrs $ \ bndrs' ->
-    do { ues <- zipWithM lint_pair bndrs' rhss
-       ; a <- thing_inside bndrs'
-       ; return (a, ues) }
+lintBindings top_lvl binds thing_inside = lint_binds [] [] binds
   where
-    (bndrs, rhss) = unzip pairs
-    lint_pair bndr' rhs
+    lint_binds lbndrs ues binds = case binds of
+      []          -> do { a <- thing_inside lbndrs
+                        ; return (a, ues) }
+      bind:binds' -> do { let (rec_flag, pairs) = decomposeBind bind
+                        ; let (bndrs, rhss)     = unzip pairs
+                        ; lintIdBndrs top_lvl bndrs $ \lbndrs' -> do
+                          do { ues' <- zipWithM (lint_pair rec_flag) lbndrs' rhss
+                             ; lint_binds (lbndrs'++lbndrs) (ues'++ues) binds' } }
+    lint_pair :: RecFlag -> LintedId -> CoreExpr -> LintM UsageEnv
+    lint_pair rec_flag bndr' rhs
       = addLoc (RhsOf bndr') $
         do { (rhs_ty, ue) <- lintRhs bndr' rhs         -- Check the rhs
-           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty
+           ; lintLetBind top_lvl rec_flag bndr' rhs rhs_ty
            ; return ue }
 
 lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)
@@ -634,7 +637,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
         -- See Note [Core let/app invariant] in GHC.Core
        ; checkL ( isJoinId binder
                || not (isUnliftedType binder_ty)
-               || (isNonRec rec_flag && exprOkForSpeculation rhs)
+               || (isNotTopLevel top_lvl && isNonRec rec_flag && exprOkForSpeculation rhs)
                || exprIsTickedString rhs)
            (badBndrTyMsg binder (text "unlifted"))
 
@@ -909,7 +912,7 @@ lintCoreExpr e@(Let (Rec pairs) body)
 
           -- See Note [Multiplicity of let binders] in Var
         ; ((body_type, body_ue), ues) <-
-            lintRecBindings NotTopLevel pairs $ \ bndrs' ->
+            lintBindings NotTopLevel [Rec pairs] $ \ bndrs' ->
             lintLetBody bndrs' body
         ; return (body_type, body_ue  `addUE` scaleUE Many (foldr1 addUE ues)) }
   where