[Git][ghc/ghc][wip/core-lint-let] Core Lint: distinguish let and letrec in locations

[Krzysztof Gogolewski (@monoidal)]

Krzysztof Gogolewski pushed to branch wip/core-lint-let at Glasgow Haskell Compiler / GHC


Commits:
9c4efac0 by Krzysztof Gogolewski at 2023-06-06T21:47:05+02:00
Core Lint: distinguish let and letrec in locations

Lint messages were saying "in the body of letrec" even for non-recursive
let.

I've also renamed BodyOfLetRec to BodyOfLet in stg, since there's no
separate letrec.

- - - - -


3 changed files:

- compiler/GHC/Core/Lint.hs
- compiler/GHC/Stg/Lint.hs
- testsuite/tests/corelint/T21115b.stderr


Changes:

=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -558,9 +558,9 @@ lintRecBindings top_lvl pairs thing_inside
            ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty
            ; return ue }
 
-lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)
-lintLetBody bndrs body
-  = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
+lintLetBody :: LintLocInfo -> [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)
+lintLetBody loc bndrs body
+  = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body)
        ; mapM_ (lintJoinBndrType body_ty) bndrs
        ; return (body_ty, body_ue) }
 
@@ -892,7 +892,7 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
                 -- Now extend the substitution so we
                 -- take advantage of it in the body
         ; extendTvSubstL tv ty'        $
-          addLoc (BodyOfLetRec [tv]) $
+          addLoc (BodyOfLet tv) $
           lintCoreExpr body } }
 
 lintCoreExpr (Let (NonRec bndr rhs) body)
@@ -904,7 +904,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body)
          -- Now lint the binder
        ; lintBinder LetBind bndr $ \bndr' ->
     do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty
-       ; addAliasUE bndr let_ue (lintLetBody [bndr'] body) } }
+       ; addAliasUE bndr let_ue (lintLetBody (BodyOfLet bndr') [bndr'] body) } }
 
   | otherwise
   = failWithL (mkLetErr bndr rhs)       -- Not quite accurate
@@ -924,7 +924,7 @@ lintCoreExpr e@(Let (Rec pairs) body)
           -- See Note [Multiplicity of let binders] in Var
         ; ((body_type, body_ue), ues) <-
             lintRecBindings NotTopLevel pairs $ \ bndrs' ->
-            lintLetBody bndrs' body
+            lintLetBody (BodyOfLetRec bndrs') bndrs' body
         ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1 addUE ues)) }
   where
     bndrs = map fst pairs
@@ -3074,6 +3074,7 @@ data LintLocInfo
   | LambdaBodyOf Id     -- The lambda-binder
   | RuleOf Id           -- Rules attached to a binder
   | UnfoldingOf Id      -- Unfolding of a binder
+  | BodyOfLet Id        -- The let-bound variable
   | BodyOfLetRec [Id]   -- One of the binders
   | CaseAlt CoreAlt     -- Case alternative
   | CasePat CoreAlt     -- The *pattern* of the case alternative
@@ -3362,6 +3363,9 @@ dumpLoc (RuleOf b)
 dumpLoc (UnfoldingOf b)
   = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)
 
+dumpLoc (BodyOfLet b)
+  = (noSrcLoc, text "In the body of let with binder" <+> pp_binder b)
+
 dumpLoc (BodyOfLetRec [])
   = (noSrcLoc, text "In body of a letrec with no binders")
 


=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -283,13 +283,13 @@ lintStgExpr (StgOpApp _ args _) =
 
 lintStgExpr (StgLet _ binds body) = do
     binders <- lintStgBinds NotTopLevel binds
-    addLoc (BodyOfLetRec binders) $
+    addLoc (BodyOfLet binders) $
       addInScopeVars binders $
         lintStgExpr body
 
 lintStgExpr (StgLetNoEscape _ binds body) = do
     binders <- lintStgBinds NotTopLevel binds
-    addLoc (BodyOfLetRec binders) $
+    addLoc (BodyOfLet binders) $
       addInScopeVars binders $
         lintStgExpr body
 
@@ -446,7 +446,7 @@ data LintFlags = LintFlags { lf_unarised :: !Bool
 data LintLocInfo
   = RhsOf Id            -- The variable bound
   | LambdaBodyOf [Id]   -- The lambda-binder
-  | BodyOfLetRec [Id]   -- One of the binders
+  | BodyOfLet [Id]      -- One of the binders
 
 dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
 dumpLoc (RhsOf v) =
@@ -454,8 +454,8 @@ dumpLoc (RhsOf v) =
 dumpLoc (LambdaBodyOf bs) =
   (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
 
-dumpLoc (BodyOfLetRec bs) =
-  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
+dumpLoc (BodyOfLet bs) =
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of let with binders " <> pp_binders bs <> char ']' )
 
 
 pp_binders :: [Id] -> SDoc


=====================================
testsuite/tests/corelint/T21115b.stderr
=====================================
@@ -4,8 +4,8 @@ T21115b.hs:9:1: warning:
     scrut ds
     In the RHS of foo :: Double# -> Int#
     In the body of lambda with binder ds :: Double#
-    In the body of letrec with binders fail :: (# #) -> Int#
-    In the body of letrec with binders fail :: (# #) -> Int#
+    In the body of let with binder fail :: (# #) -> Int#
+    In the body of let with binder fail :: (# #) -> Int#
     Substitution: <InScope = {}
                    IdSubst   = []
                    TvSubst   = []



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9c4efac01009d8b7929a11ccb74a32c1dc1fca32

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9c4efac01009d8b7929a11ccb74a32c1dc1fca32
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/20230606/b431e6d1/attachment-0001.html>