[Git][ghc/ghc][wip/9.2.6-backports] 3 commits: Avoid repeated zonking and tidying of types in `relevant_bindings`
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Thu Feb 9 11:01:04 UTC 2023
Zubin pushed to branch wip/9.2.6-backports at Glasgow Haskell Compiler / GHC
Commits:
fd636a4e by Matthew Pickering at 2023-02-09T16:25:04+05:30
Avoid repeated zonking and tidying of types in `relevant_bindings`
The approach taking in this patch is that the tcl_bndrs in TcLclEnv are
zonked and tidied eagerly, so that work can be shared across multiple
calls to `relevant_bindings`.
To test this patch I tried without the `keepThisHole` filter and the
test finished quickly.
Fixes #14766
- - - - -
e222f33c by sheaf at 2023-02-09T16:27:01+05:30
Fix tyvar scoping within class SPECIALISE pragmas
Type variables from class/instance headers scope over class/instance
method type signatures, but DO NOT scope over the type signatures in
SPECIALISE and SPECIALISE instance pragmas.
The logic in GHC.Rename.Bind.rnMethodBinds correctly accounted for
SPECIALISE inline pragmas, but forgot to apply the same treatment
to method SPECIALISE pragmas, which lead to a Core Lint failure with
an out-of-scope type variable. This patch makes sure we apply the same
logic for both cases.
Fixes #22913
(cherry picked from commit 9ee761bf02cdd11c955454a222c85971d95dce11)
- - - - -
5383016c by Zubin Duggal at 2023-02-09T16:30:52+05:30
changelog: Add entries for #22913 and #14766
- - - - -
5 changed files:
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Errors.hs
- docs/users_guide/9.2.6-notes.rst
- + testsuite/tests/rename/should_compile/T22913.hs
- testsuite/tests/rename/should_compile/all.T
Changes:
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -860,17 +860,15 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
-- Rename the pragmas and signatures
-- Annoyingly the type variables /are/ in scope for signatures, but
- -- /are not/ in scope in the SPECIALISE instance pramas; e.g.
- -- instance Eq a => Eq (T a) where
- -- (==) :: a -> a -> a
- -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
- ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs
+ -- /are not/ in scope in SPECIALISE and SPECIALISE instance pragmas.
+ -- See Note [Type variable scoping in SPECIALISE pragmas].
+ ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs
bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')
sig_ctxt | is_cls_decl = ClsDeclCtxt cls
| otherwise = InstDeclCtxt bound_nms
- ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags
- ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $
- renameSigs sig_ctxt other_sigs
+ ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags
+ ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $
+ renameSigs sig_ctxt other_sigs
-- Rename the bindings RHSs. Again there's an issue about whether the
-- type variables from the class/instance head are in scope.
@@ -881,8 +879,47 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
emptyFVs binds_w_dus
; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
- ; return ( binds'', spec_inst_prags' ++ other_sigs'
- , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }
+ ; return ( binds'', spec_prags' ++ other_sigs'
+ , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) }
+
+{- Note [Type variable scoping in SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When renaming the methods of a class or instance declaration, we must be careful
+with the scoping of the type variables that occur in SPECIALISE and SPECIALISE instance
+pragmas: the type variables from the class/instance header DO NOT scope over these,
+unlike class/instance method type signatures.
+
+Examples:
+
+ 1. SPECIALISE
+
+ class C a where
+ meth :: a
+ instance C (Maybe a) where
+ meth = Nothing
+ {-# SPECIALISE INLINE meth :: Maybe [a] #-}
+
+ 2. SPECIALISE instance
+
+ instance Eq a => Eq (T a) where
+ (==) :: a -> a -> a
+ {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+
+ In both cases, the type variable `a` mentioned in the PRAGMA is NOT the same
+ as the type variable `a` from the instance header.
+ For example, the SPECIALISE instance pragma above is a shorthand for
+
+ {-# SPECIALISE instance forall a. Eq a => Eq (T [a]) #-}
+
+ which is alpha-equivalent to
+
+ {-# SPECIALISE instance forall b. Eq b => Eq (T [b]) #-}
+
+ This shows that the type variables are not bound in the header.
+
+ Getting this scoping wrong can lead to out-of-scope type variable errors from
+ Core Lint, see e.g. #22913.
+-}
rnMethodBindLHS :: Bool -> Name
-> LHsBindLR GhcPs GhcPs
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
+import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Data.Bag
import GHC.Utils.Error ( pprLocMsgEnvelope )
@@ -67,7 +68,7 @@ import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.FV ( fvVarList, unionFV )
-import Control.Monad ( when, unless )
+import Control.Monad ( when, foldM, forM_ )
import Data.Foldable ( toList )
import Data.List ( partition, mapAccumL, sortBy, unfoldr )
@@ -740,23 +741,58 @@ mkSkolReporter ctxt cts
reportHoles :: [Ct] -- other (tidied) constraints
-> ReportErrCtxt -> [Hole] -> TcM ()
-reportHoles tidy_cts ctxt
- = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $
- do { err <- mkHoleError tidy_cts ctxt hole
- ; maybeReportHoleError ctxt hole err
- ; maybeAddDeferredHoleBinding ctxt err hole }
-
-ignoreThisHole :: ReportErrCtxt -> Hole -> Bool
+reportHoles tidy_cts ctxt holes
+ = do
+ let holes' = filter (keepThisHole ctxt) holes
+ -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`
+ -- because otherwise types will be zonked and tidied many times over.
+ (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')
+ let ctxt' = ctxt { cec_tidy = tidy_env' }
+ forM_ holes' $ \hole ->
+ do { err <- mkHoleError lcl_name_cache tidy_cts ctxt' hole
+ ; maybeReportHoleError ctxt hole err
+ ; maybeAddDeferredHoleBinding ctxt err hole }
+
+keepThisHole :: ReportErrCtxt -> Hole -> Bool
-- See Note [Skip type holes rapidly]
-ignoreThisHole ctxt hole
+keepThisHole ctxt hole
= case hole_sort hole of
- ExprHole {} -> False
- TypeHole -> ignore_type_hole
- ConstraintHole -> ignore_type_hole
+ ExprHole {} -> True
+ TypeHole -> keep_type_hole
+ ConstraintHole -> keep_type_hole
+ where
+ keep_type_hole = case cec_type_holes ctxt of
+ HoleDefer -> False
+ _ -> True
+
+-- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.
+-- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied
+-- type for each Id in any of the binder stacks in the 'TcLclEnv's.
+-- Since there is a huge overlap between these stacks, is is much,
+-- much faster to do them all at once, avoiding duplication.
+zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)
+zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)
where
- ignore_type_hole = case cec_type_holes ctxt of
- HoleDefer -> True
- _ -> False
+ go envs tc_bndr = case tc_bndr of
+ TcTvBndr {} -> return envs
+ TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs
+ TcIdBndr_ExpType name et _top_lvl ->
+ do { mb_ty <- readExpType_maybe et
+ -- et really should be filled in by now. But there's a chance
+ -- it hasn't, if, say, we're reporting a kind error en route to
+ -- checking a term. See test indexed-types/should_fail/T8129
+ -- Or we are reporting errors from the ambiguity check on
+ -- a local type signature
+ ; case mb_ty of
+ Just ty -> go_one name ty envs
+ Nothing -> return envs
+ }
+ go_one name ty (tidy_env, name_env) = do
+ if name `elemNameEnv` name_env
+ then return (tidy_env, name_env)
+ else do
+ (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty
+ return (tidy_env', extendNameEnv name_env name tidy_ty)
{- Note [Skip type holes rapidly]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1193,8 +1229,8 @@ mkIrredErr ctxt cts
(ct1:_) = cts
----------------
-mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc)
-mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ
+mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc)
+mkHoleError _ _tidy_simples _ctxt hole@(Hole { hole_occ = occ
, hole_ty = hole_ty
, hole_loc = ct_loc })
| isOutOfScopeHole hole
@@ -1219,12 +1255,12 @@ mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ
boring_type = isTyVarTy hole_ty
-- general case: not an out-of-scope error
-mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
+mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ
, hole_ty = hole_ty
, hole_sort = sort
, hole_loc = ct_loc })
- = do { (ctxt, binds_msg)
- <- relevant_bindings False ctxt lcl_env (tyCoVarsOfType hole_ty)
+ = do { binds_msg
+ <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty)
-- The 'False' means "don't filter the bindings"; see Trac #8191
; show_hole_constraints <- goptM Opt_ShowHoleConstraints
@@ -2945,21 +2981,23 @@ relevantBindings want_filtering ctxt ct
-- Put a zonked, tidied CtOrigin into the Ct
loc' = setCtLocOrigin loc tidy_orig
ct' = setCtLoc ct loc'
- ctxt1 = ctxt { cec_tidy = env1 }
- ; (ctxt2, doc) <- relevant_bindings want_filtering ctxt1 lcl_env ct_fvs
- ; return (ctxt2, doc, ct') }
+ ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]
+
+ ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs
+ ; let ctxt' = ctxt { cec_tidy = env2 }
+ ; return (ctxt', doc, ct') }
where
loc = ctLoc ct
lcl_env = ctLocEnv loc
-- slightly more general version, to work also with holes
relevant_bindings :: Bool
- -> ReportErrCtxt
-> TcLclEnv
+ -> NameEnv Type -- Cache of already zonked and tidied types
-> TyCoVarSet
- -> TcM (ReportErrCtxt, SDoc)
-relevant_bindings want_filtering ctxt lcl_env ct_tvs
+ -> TcM SDoc
+relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs
= do { dflags <- getDynFlags
; traceTc "relevant_bindings" $
vcat [ ppr ct_tvs
@@ -2968,8 +3006,8 @@ relevant_bindings want_filtering ctxt lcl_env ct_tvs
, pprWithCommas id
[ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]
- ; (tidy_env', docs, discards)
- <- go dflags (cec_tidy ctxt) (maxRelevantBinds dflags)
+ ; (docs, discards)
+ <- go dflags (maxRelevantBinds dflags)
emptyVarSet [] False
(removeBindingShadowing $ tcl_bndrs lcl_env)
-- tcl_bndrs has the innermost bindings first,
@@ -2979,9 +3017,7 @@ relevant_bindings want_filtering ctxt lcl_env ct_tvs
hang (text "Relevant bindings include")
2 (vcat docs $$ ppWhen discards discardMsg)
- ctxt' = ctxt { cec_tidy = tidy_env' }
-
- ; return (ctxt', doc) }
+ ; return doc }
where
run_out :: Maybe Int -> Bool
run_out Nothing = False
@@ -2991,17 +3027,17 @@ relevant_bindings want_filtering ctxt lcl_env ct_tvs
dec_max = fmap (\n -> n - 1)
- go :: DynFlags -> TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc]
+ go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc]
-> Bool -- True <=> some filtered out due to lack of fuel
-> [TcBinder]
- -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out
+ -> TcM ([SDoc], Bool) -- The bool says if we filtered any out
-- because of lack of fuel
- go _ tidy_env _ _ docs discards []
- = return (tidy_env, reverse docs, discards)
- go dflags tidy_env n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
+ go _ _ _ docs discards []
+ = return (reverse docs, discards)
+ go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
= case tc_bndr of
TcTvBndr {} -> discard_it
- TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl
+ TcIdBndr id top_lvl -> go2 (idName id) top_lvl
TcIdBndr_ExpType name et top_lvl ->
do { mb_ty <- readExpType_maybe et
-- et really should be filled in by now. But there's a chance
@@ -3010,14 +3046,16 @@ relevant_bindings want_filtering ctxt lcl_env ct_tvs
-- Or we are reporting errors from the ambiguity check on
-- a local type signature
; case mb_ty of
- Just ty -> go2 name ty top_lvl
+ Just _ty -> go2 name top_lvl
Nothing -> discard_it -- No info; discard
}
where
- discard_it = go dflags tidy_env n_left tvs_seen docs
+ discard_it = go dflags n_left tvs_seen docs
discards tc_bndrs
- go2 id_name id_type top_lvl
- = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type
+ go2 id_name top_lvl
+ = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of
+ Just tty -> tty
+ Nothing -> pprPanic "relevant_bindings" (ppr id_name)
; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
; let id_tvs = tyCoVarsOfType tidy_ty
doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty
@@ -3039,12 +3077,12 @@ relevant_bindings want_filtering ctxt lcl_env ct_tvs
else if run_out n_left && id_tvs `subVarSet` tvs_seen
-- We've run out of n_left fuel and this binding only
-- mentions already-seen type variables, so discard it
- then go dflags tidy_env n_left tvs_seen docs
+ then go dflags n_left tvs_seen docs
True -- Record that we have now discarded something
tc_bndrs
-- Keep this binding, decrement fuel
- else go dflags tidy_env' (dec_max n_left) new_seen
+ else go dflags (dec_max n_left) new_seen
(doc:docs) discards tc_bndrs }
=====================================
docs/users_guide/9.2.6-notes.rst
=====================================
@@ -58,6 +58,12 @@ Compiler
- Fix a driver bug where certain non-fatal Safe Haskell related warnings were
being marked as fatal (:ghc-ticket:`22728`).
+- Fix a core lint error arises from incorrect scoping of type variables in
+ specialise pragmas inside class instances (:ghc-ticket:`22913`).
+
+- Improve typchecker performance for modules with holes in type signatures
+ (:ghc-ticket:`14766`).
+
Runtime system
--------------
=====================================
testsuite/tests/rename/should_compile/T22913.hs
=====================================
@@ -0,0 +1,10 @@
+module T22913 where
+
+class FromSourceIO a where
+ fromSourceIO :: a
+instance FromSourceIO (Maybe o) where
+ fromSourceIO = undefined
+ {-# SPECIALISE INLINE fromSourceIO :: Maybe o #-}
+ -- This SPECIALISE pragma caused a Core Lint error
+ -- due to incorrectly scoping the type variable 'o' from the instance header
+ -- over the SPECIALISE pragma.
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -178,3 +178,4 @@ test('T18497', [], makefile_test, ['T18497'])
test('T18264', [], makefile_test, ['T18264'])
test('T18302', expect_broken(18302), compile, [''])
test('T17853', [], multimod_compile, ['T17853', '-v0'])
+test('T22913', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/06a4a65fff9268589270e99762d5d18a64cabc6c...5383016c78fe4b2555e0aae9248bea5b42f67a78
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/06a4a65fff9268589270e99762d5d18a64cabc6c...5383016c78fe4b2555e0aae9248bea5b42f67a78
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/20230209/c09d234c/attachment-0001.html>
More information about the ghc-commits
mailing list