[Git][ghc/ghc][master] 2 commits: Add `isInScope` check to `lintCoercion`

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
f3fb1ce9 by fendor at 2020-06-01T06:36:18-04:00
Add `isInScope` check to `lintCoercion`

Mirrors the behaviour of `lintType`.

- - - - -
5ac4d946 by fendor at 2020-06-01T06:36:18-04:00
Lint rhs of IfaceRule

- - - - -


2 changed files:

- compiler/GHC/Core/Lint.hs
- compiler/GHC/IfaceToCore.hs


Changes:

=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1890,7 +1890,12 @@ lintCoercion (CoVarCo cv)
   = do { subst <- getTCvSubst
        ; case lookupCoVar subst cv of
            Just linted_co -> return linted_co ;
-           Nothing -> -- lintCoBndr always extends the substitition
+           Nothing
+              | cv `isInScope` subst
+                   -> return (CoVarCo cv)
+              | otherwise
+                   ->
+                      -- lintCoBndr always extends the substitition
                       failWithL $
                       hang (text "The coercion variable" <+> pprBndr LetBind cv)
                          2 (text "is out of scope")


=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Tc.Utils.TcType
 import GHC.Core.Type
 import GHC.Core.Coercion
 import GHC.Core.Coercion.Axiom
+import GHC.Core.FVs
 import GHC.Core.TyCo.Rep    -- needs to build types & coercions in a knot
 import GHC.Core.TyCo.Subst ( substTyCoVars )
 import GHC.Driver.Types
@@ -1061,8 +1062,24 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
                 -- Typecheck the payload lazily, in the hope it'll never be looked at
                 forkM (text "Rule" <+> pprRuleName name) $
                 bindIfaceBndrs bndrs                      $ \ bndrs' ->
-                do { args' <- mapM tcIfaceExpr args
-                   ; rhs'  <- tcIfaceExpr rhs
+                do { args'  <- mapM tcIfaceExpr args
+                   ; rhs'   <- tcIfaceExpr rhs
+                   ; whenGOptM Opt_DoCoreLinting $ do
+                      { dflags <- getDynFlags
+                      ; (_, lcl_env) <- getEnvs
+                      ; let in_scope :: [Var]
+                            in_scope = ((nonDetEltsUFM $ if_tv_env lcl_env) ++
+                                        (nonDetEltsUFM $ if_id_env lcl_env) ++
+                                        bndrs' ++
+                                        exprsFreeIdsList args')
+                      ; case lintExpr dflags in_scope rhs' of
+                          Nothing       -> return ()
+                          Just fail_msg -> do { mod <- getIfModule
+                                              ; pprPanic "Iface Lint failure"
+                                                  (vcat [ text "In interface for" <+> ppr mod
+                                                        , hang doc 2 fail_msg
+                                                        , ppr name <+> equals <+> ppr rhs'
+                                                        , text "Iface expr =" <+> ppr rhs ]) } }
                    ; return (bndrs', args', rhs') }
         ; let mb_tcs = map ifTopFreeName args
         ; this_mod <- getIfModule
@@ -1091,6 +1108,8 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
     ifTopFreeName (IfaceExt n)                      = Just n
     ifTopFreeName _                                 = Nothing
 
+    doc = text "Unfolding of" <+> ppr name
+
 {-
 ************************************************************************
 *                                                                      *



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e5220e25baedfa7ae0ec055c03cb4429dd1af05...5ac4d94607d4a898f0015114e929ee9a38118985

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e5220e25baedfa7ae0ec055c03cb4429dd1af05...5ac4d94607d4a898f0015114e929ee9a38118985
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/20200601/94b31fd8/attachment-0001.html>