Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC Commits: 60381bd4 by Simon Peyton Jones at 2025-11-06T17:44:19+00:00 More [skip ci] - - - - - 13 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -54,7 +54,7 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Misc ((<||>)) +import GHC.Utils.Misc import Data.Function import Data.List (sortBy) @@ -80,12 +80,16 @@ type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen -- --------------------------------------------------------------------- type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag -type instance XXValBindsLR (GhcPass pL) pR = NHsValBindsLR pL -data NHsValBindsLR (p :: Pass) where - NvbPs :: NHsValBindsLR 'Parsed - NvbRn :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR 'Renamed - NvbTc :: [(RecFlag, LHsBinds GhcRn, Bool)] -> [LSig GhcRn] -> NHsValBindsLR 'Typechecked +type instance XXValBindsLR (GhcPass pL) _ = HsValBindGroups pL + +data HsValBindGroups p -- Divided into strongly connected components + = HsVBG [HsValBindGroup (GhcPass p)] [LSig GhcRn] + +type family HsValBindGroup p +type instance HsValBindGroup GhcPs = () +type instance HsValBindGroup GhcRn = (RecFlag, LHsBinds GhcRn) +type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, TopLevelFlag) -- --------------------------------------------------------------------- @@ -449,18 +453,17 @@ instance (OutputableBndrId pl, OutputableBndrId pr) ppr (ValBinds _ binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) - ppr (XValBindsLR nvbs) - = case nvbs of - NvbPs -> empty - NvbRn prs sigs -> ppr_vb prs sigs - NvbTc triples sigs -> ppr_vb [(a,b) | (a,b,_)<-triples] sigs - -- Discard closed-flag for now + ppr (XValBindsLR (HsVBG bs sigs)) + = getPprDebug $ \case + False -> pprDeclList (pprLHsBindsForUser (concat (map snd prs)) sigs) + True -> -- Print with sccs showing + vcat (map ppr sigs) $$ vcat (map ppr_scc prs) where - ppr_vb prs sigs - = getPprDebug $ \case - False -> pprDeclList (pprLHsBindsForUser (concat (map snd prs)) sigs) - True -> -- Print with sccs showing - vcat (map ppr sigs) $$ vcat (map ppr_scc prs) + prs :: [(RecFlag, LHsBinds (GhcPass pl))] + prs = case ghcPass @pl of + GhcPs -> [] + GhcRn -> bs + GhcTc -> [(a,b)|(a,b,_)<-bs] -- Discard closed-flag for now ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds pp_rec Recursive = text "rec" @@ -513,14 +516,12 @@ eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs -isEmptyValBinds (XValBindsLR NvbPs) = True -isEmptyValBinds (XValBindsLR (NvbRn ds sigs)) = null ds && null sigs -isEmptyValBinds (XValBindsLR (NvbTc ds sigs)) = null ds && null sigs +isEmptyValBinds (XValBindsLR (HsVBG ds sigs)) = null ds && null sigs emptyValBindsIn :: HsValBindsLR (GhcPass a) (GhcPass b) emptyValBindsIn = ValBinds NoAnnSortKey [] [] emptyValBindsRn :: HsValBindsLR GhcRn GhcRn -emptyValBindsRn = XValBindsLR (NvbRn [] []) +emptyValBindsRn = XValBindsLR (HsVBG [] []) emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR emptyLHsBinds = [] @@ -528,19 +529,21 @@ emptyLHsBinds = [] isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool isEmptyLHsBinds = null +hsValBindGroupsBinds :: forall p. IsPass p + => [HsValBindGroup (GhcPass p)] -> [LHsBind (GhcPass p)] +hsValBindGroupsBinds binds + = case ghcPass @p of + GhcPs -> [] + GhcRn -> concatMap snd binds + GhcTc -> concatMap sndOf3 binds + ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) -plusHsValBinds (XValBindsLR nvbs1) (XValBindsLR nvbs2) - = XValBindsLR (nvbs1 `plus` nvbs2) - where - plus :: NHsValBindsLR p -> NHsValBindsLR p -> NHsValBindsLR p - NvbPs `plus` NvbPs = NvbPs - (NvbRn ds1 sigs1) `plus` (NvbRn ds2 sigs2) = NvbRn (ds1 ++ ds2) (sigs1 ++ sigs2) - (NvbTc ds1 sigs1) `plus` (NvbTc ds2 sigs2) = NvbTc (ds1 ++ ds2) (sigs1 ++ sigs2) - +plusHsValBinds (XValBindsLR (HsVBG ds1 ss1)) (XValBindsLR (HsVBG ds2 ss2)) + = XValBindsLR (HsVBG (ds1++ds2) (ss1++ss2)) plusHsValBinds _ _ = panic "HsBinds.plusHsValBinds" ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -56,9 +57,9 @@ deriving instance Data (HsValBindsLR GhcRn GhcRn) deriving instance Data (HsValBindsLR GhcTc GhcTc) -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) -deriving instance Data (NHsValBindsLR 'Parsed) -deriving instance Data (NHsValBindsLR 'Renamed) -deriving instance Data (NHsValBindsLR 'Typechecked) +deriving instance Data (HsValBindGroups 'Parsed) +deriving instance Data (HsValBindGroups 'Renamed) +deriving instance Data (HsValBindGroups 'Typechecked) -- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) deriving instance Data (HsBindLR GhcPs GhcPs) ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -886,24 +886,23 @@ isInfixFunBind (FunBind { fun_matches = MG _ matches }) isInfixFunBind _ = False -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds -spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan -spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan +spanHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> SrcSpan +spanHsLocaLBinds (EmptyLocalBinds _) + = noSrcSpan +spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) + = get_bind_spans bs [] spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) - = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) - where - bsSpans :: [SrcSpan] - bsSpans = map getLocA bs - sigsSpans :: [SrcSpan] - sigsSpans = map getLocA sigs -spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs))) - = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) + = get_bind_spans bs sigs +spanHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG bs ss))) + = get_bind_spans (hsValBindGroupsBinds @p bs) ss + +get_bind_spans :: (HasLoc l) => [GenLocated l a] -> [GenLocated l b] -> SrcSpan +get_bind_spans binds sigs + = foldr combineSrcSpans noSrcSpan (bs_spans ++ sigs_spans) where - bsSpans :: [SrcSpan] - bsSpans = map getLocA $ concatMap snd bs - sigsSpans :: [SrcSpan] - sigsSpans = map getLocA sigs -spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) - = foldr combineSrcSpans noSrcSpan (map getLocA bs) + bs_spans, sigs_spans :: [SrcSpan] + bs_spans = map getLocA binds + sigs_spans = map getLocA sigs ------------ -- | Convenience function using 'mkFunBind'. @@ -1075,7 +1074,7 @@ isBangedHsBind (PatBind {pat_lhs = pat}) isBangedHsBind _ = False -collectLocalBinders :: CollectPass (GhcPass idL) +collectLocalBinders :: (IsPass idL, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] @@ -1085,14 +1084,14 @@ collectLocalBinders flag = \case HsIPBinds {} -> [] EmptyLocalBinds _ -> [] -collectHsIdBinders :: CollectPass (GhcPass idL) +collectHsIdBinders :: (IsPass idL, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively collectHsIdBinders flag = collect_hs_val_binders True flag -collectHsValBinders :: CollectPass (GhcPass idL) +collectHsValBinders :: (IsPass idL, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] @@ -1118,21 +1117,14 @@ collectHsBindListBinders :: forall p idR. CollectPass p -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) [] -collect_hs_val_binders :: CollectPass (GhcPass idL) +collect_hs_val_binders :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL)) => Bool -> CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collect_hs_val_binders ps flag = \case - ValBinds _ binds _ -> collect_binds ps flag binds [] - XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds - -collect_out_binds :: forall p. CollectPass p - => Bool - -> CollectFlag p - -> [(RecFlag, LHsBinds p)] - -> [IdP p] -collect_out_binds ps flag = foldr (collect_binds ps flag . snd) [] + ValBinds _ binds _ -> collect_binds ps flag binds [] + XValBindsLR (HsVBG grps _) -> collect_binds ps flag (hsValBindGroupsBinds @idL grps) [] collect_binds :: forall p idR. CollectPass p => Bool @@ -1529,8 +1521,8 @@ hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p) -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" -hsPatSynSelectors (XValBindsLR (NValBinds binds _)) - = foldr addPatSynSelector [] . concat $ map snd binds +hsPatSynSelectors (XValBindsLR (HsVBG grps _)) + = foldr addPatSynSelector [] $ hsValBindGroupsBinds grps addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] addPatSynSelector bind sels @@ -1538,11 +1530,10 @@ addPatSynSelector bind sels = map recordPatSynField as ++ sels | otherwise = sels -getPatSynBinds :: forall id. UnXRec id - => [(RecFlag, LHsBinds id)] -> [PatSynBind id id] +getPatSynBinds :: [(RecFlag, LHsBinds GhcRn)] -> [PatSynBind GhcRn GhcRn] getPatSynBinds binds = [ psb | (_, lbinds) <- binds - , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ] + , L _ (PatSynBind _ psb) <- lbinds ] ------------------- hsLInstDeclBinders :: (IsPass p, OutputableBndrId p) @@ -1813,8 +1804,8 @@ lStmtsImplicits = hs_lstmts hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [ImplicitFieldBinders])] -hsValBindsImplicits (XValBindsLR (NvbRn binds _)) - = concatMap (lhsBindsImplicits . snd) binds +hsValBindsImplicits (XValBindsLR (HsVBG grps _)) + = lhsBindsImplicits (hsValBindGroupsBinds grps) hsValBindsImplicits (ValBinds _ binds _) = lhsBindsImplicits binds ===================================== compiler/GHC/HsToCore/Docs.hs ===================================== @@ -525,12 +525,12 @@ ungroup (HsGroup {..}) = mkDecls (ValD noExtField) (valbinds hs_valds) where typesigs :: HsValBinds GhcRn -> [LSig GhcRn] - typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig + typesigs (XValBindsLR (HsVBG _ sig)) = filter (isUserSig . unLoc) sig typesigs ValBinds{} = error "expected XValBindsLR" valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn] - valbinds (XValBindsLR (NValBinds binds _)) = - concat . snd . unzip $ binds + valbinds (XValBindsLR (HsVBG grps _)) = + concat . snd . unzip $ grps valbinds ValBinds{} = error "expected XValBindsLR" -- | Collect docs and attach them to the right declarations. ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -380,8 +380,8 @@ sequenceGrdDagMapM f as = sequenceGrdDags <$> traverse f as -- recursion, pattern bindings etc. -- See Note [Long-distance information for HsLocalBinds]. desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag -desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) = - sequenceGrdDagMapM (sequenceGrdDagMapM go) (map snd binds) +desugarLocalBinds (HsValBinds _ (XValBindsLR (HsVBG grps _))) = + sequenceGrdDagMapM go (hsValBindGroupsBinds grps) where go :: LHsBind GhcTc -> DsM GrdDag go (L _ FunBind{fun_id = L _ x, fun_matches = mg}) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE NondecreasingIndentation, DataKinds #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -850,15 +850,12 @@ addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) -> TM (HsValBindsLR GhcTc (GhcPass b)) -addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do - b <- liftM2 NValBinds - (mapM (\ (rec,binds') -> - liftM2 (,) - (return rec) - (addTickLHsBinds binds')) - binds) - (return sigs) - return $ XValBindsLR b +addTickHsValBinds (XValBindsLR (HsVBG grps sigs)) = do + grps' <- mapM (\ (rec,binds,static) -> + do { binds' <- addTickLHsBinds binds + ; return (rec,binds',static) }) + grps + return $ XValBindsLR (HsVBG grps' sigs) addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) @@ -1422,7 +1419,8 @@ instance CollectFldBinders (HsLocalBinds GhcTc) where collectFldBinds EmptyLocalBinds{} = emptyVarEnv instance CollectFldBinders (HsValBinds GhcTc) where collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds - collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds) + collectFldBinds (XValBindsLR (HsVBG grps _)) + = collectFldBinds (hsValBindGroupsBinds @'Typechecked grps) instance CollectFldBinders (HsBind GhcTc) where collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) = ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -430,7 +430,7 @@ getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) +grhss_span :: (IsPass p, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (NE.map getLocA xs) @@ -1437,7 +1437,7 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where valBinds ] -scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope +scopeHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> Scope scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) = foldr combineScopes NoScope (bsScope ++ sigsScope) where @@ -1445,11 +1445,11 @@ scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) bsScope = map (mkScope . getLoc) bs sigsScope :: [Scope] sigsScope = map (mkScope . getLocA) sigs -scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs))) +scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG grps sigs))) = foldr combineScopes NoScope (bsScope ++ sigsScope) where bsScope :: [Scope] - bsScope = map (mkScope . getLoc) $ concatMap snd bs + bsScope = map (mkScope . getLoc) (hsValBindGroupsBinds @p grps) sigsScope :: [Scope] sigsScope = map (mkScope . getLocA) sigs @@ -1473,9 +1473,9 @@ instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) whe ] XValBindsLR x -> [ toHie $ RS sc x ] -instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . snd) binds) +instance HiePass p => ToHie (RScoped (HsValBindGroups p)) where + toHie (RS sc (HsVBG binds sigs)) = concatM $ + [ toHie (map (BC RegularBind sc) (hsValBindGroupsBinds @p binds)) , toHie $ fmap (SC (SI BindSig Nothing)) sigs ] ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -225,7 +225,7 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot bound_names (ValBinds _ _ sigs) = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs - ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } + ; return (XValBindsLR (HsVBG [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) {- @@ -356,7 +356,7 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs) -- so that the binders are removed from -- the uses in the sigs - ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } } + ; return (XValBindsLR (HsVBG anal_binds sigs'), valbind'_dus) } } rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -182,7 +182,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn "Start rnmono" empty ; let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; - (rn_val_decls@(XValBindsLR (NValBinds _ sigs')), bind_dus) <- if is_boot + (rn_val_decls@(XValBindsLR (HsVBG _ sigs')), bind_dus) <- if is_boot -- For an hs-boot, use tc_bndrs (which collects how we're renamed -- signatures), since val_bndr_set is empty (there are no x = ... -- bindings in an hs-boot.) ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -59,7 +59,7 @@ import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Core.Class ( Class ) import GHC.Core.Coercion( mkSymCo ) -import GHC.Core.Type (mkStrLitTy, mkCastTy) +import GHC.Core.Type (mkStrLitTy, mkCastTy, definitelyLiftedType) import GHC.Core.TyCo.Ppr( pprTyVars ) import GHC.Core.TyCo.Tidy( tidyOpenTypeX ) @@ -83,7 +83,6 @@ import GHC.Types.Basic import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Names( ipClassName ) -import GHC.Types.Unique.FM import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt @@ -198,7 +197,7 @@ tcTopBinds binds sigs ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } - `addTypecheckedBinds` map snd binds' } + `addTypecheckedBinds` map sndOf3 binds' } ; return (tcg_env', tcl_env) } -- The top level bindings are flattened into a giant @@ -229,9 +228,9 @@ tcLocalBinds (EmptyLocalBinds x) thing_inside = do { thing <- thing_inside ; return (EmptyLocalBinds x, thing) } -tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside - = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } +tcLocalBinds (HsValBinds x (XValBindsLR (HsVBG grps sigs))) thing_inside + = do { (grps', thing) <- tcValBinds NotTopLevel grps sigs thing_inside + ; return (HsValBinds x (XValBindsLR (HsVBG grps' sigs)), thing) } tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside @@ -261,9 +260,9 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside tcValBinds :: TopLevelFlag -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) + -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing) -tcValBinds top_lvl binds sigs thing_inside +tcValBinds top_lvl grps sigs thing_inside = do { -- Typecheck the signatures -- It's easier to do so now, once for all the SCCs together -- because a single signature f,g :: <type> @@ -281,24 +280,24 @@ tcValBinds top_lvl binds sigs thing_inside -- only unrestricted variables. ; tcExtendSigIds top_lvl poly_ids $ do { (binds', (extra_binds', thing)) - <- tcBindGroups top_lvl sig_fn prag_fn binds $ + <- tcBindGroups top_lvl sig_fn prag_fn grps $ do { thing <- thing_inside -- See Note [Pattern synonym builders don't yield dependencies] -- in GHC.Rename.Bind ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns - ; let extra_binds = [ (NonRecursive, builder) + ; let extra_binds = [ (NonRecursive, builder, TopLevel) | builder <- patsyn_builders ] ; return (extra_binds, thing) } ; return (binds' ++ extra_binds', thing) }} where - patsyns = getPatSynBinds binds - prag_fn = mkPragEnv sigs (concatMap snd binds) + patsyns = getPatSynBinds grps + prag_fn = mkPragEnv sigs (hsValBindGroupsBinds grps) ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) + -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time -- Here a "strongly connected component" has the straightforward @@ -310,9 +309,8 @@ tcBindGroups _ _ _ [] thing_inside ; return ([], thing) } tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside - = do { -- See Note [Closed binder groups] - ; (group', (groups', thing)) - <- tc_group top_lvl sig_fn prag_fn group closed $ + = do { (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group $ tcBindGroups top_lvl sig_fn prag_fn groups thing_inside ; return (group' : groups', thing) } @@ -336,30 +334,54 @@ before we sub-divide it based on what type signatures it has. tc_group :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv -> (RecFlag, LHsBinds GhcRn) -> TcM thing - -> TcM ((RecFlag, LHsBinds GhcTc, Bool), thing) - + -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing) -- Typecheck one strongly-connected component of the original program. +tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside + = case rec_flag of + NonRecursive -> tc_nonrec_group top_lvl sig_fn prag_fn binds thing_inside + Recursive -> tc_rec_group top_lvl sig_fn prag_fn binds thing_inside + +--------------------- +tc_nonrec_group :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> LHsBinds GhcRn -> TcM thing + -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing) +tc_nonrec_group top_lvl sig_fn prag_fn [lbind] thing_inside + | L loc (PatSynBind _ psb) <- lbind + = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn + ; thing <- setGblEnv tcg_env thing_inside + ; return ((NonRecursive, aux_binds, TopLevel), thing) } -tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside - -- A single non-recursive binding + | otherwise + = -- A single non-recursive binding -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly - = do { type_env <- getLclTypeEnv - ; let closed = isClosedBndrGroup type_env binds - bind = case binds of - [bind] -> bind - [] -> panic "tc_group: empty list of binds" - _ -> panic "tc_group: NonRecursive binds is not a singleton bag" - ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed - thing_inside - ; return ( (NonRecursive, bind'), thing) } - -tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside - = -- To maximise polymorphism, we do a new - -- strongly-connected-component analysis, this time omitting - -- any references to variables with type signatures. - -- (This used to be optional, but isn't now.) - -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". + do { type_env <- getLclTypeEnv + ; let closed = isClosedBndrGroup type_env [lbind] + ; (bind', ids) <- tcPolyBinds top_lvl sig_fn prag_fn + NonRecursive NonRecursive + closed + [lbind] + + ; let final_closed = adjustClosedForUnlifted closed ids + + ; thing <- tcExtendLetEnv top_lvl sig_fn final_closed ids thing_inside + ; return ( (NonRecursive, bind', sendToTopLevel final_closed), thing ) } + +tc_nonrec_group _ _ _ binds _ -- Non-rec groups should always be a singleton + = pprPanic "tc_nonrec_group" (ppr binds) + +--------------------- +tc_rec_group :: forall thing. + TopLevelFlag -> TcSigFun -> TcPragEnv + -> LHsBinds GhcRn -> TcM thing + -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing) +tc_rec_group top_lvl sig_fn prag_fn binds thing_inside + = -- For a recursive group, to maximise polymorphism, we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- (This used to be optional, but isn't now.) + -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". do { traceTc "tc_group rec" (pprLHsBinds binds) ; type_env <- getLclTypeEnv ; let closed = isClosedBndrGroup type_env binds @@ -371,7 +393,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside -- Typecheck the SCCs in turn ; (binds1, thing) <- go closed sccs - ; return ((Recursive, binds1), thing) } + ; return ((Recursive, binds1, sendToTopLevel closed), thing) } -- Rec them all together where mbFirstPatSyn = find (isPatSyn . unLoc) binds @@ -383,7 +405,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside go :: IsGroupClosed -> [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing) go closed (scc:sccs) - = do { (binds1, ids1) <- tc_scc scc + = do { (binds1, ids1) <- tc_scc closed scc -- recursive bindings must be unrestricted -- (the ids added to the environment here are -- the name of the recursive definitions) @@ -392,11 +414,11 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside ; return (binds1 ++ binds2, thing) } go _ [] = do { thing <- thing_inside; return ([], thing) } - tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] - tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds + tc_scc closed (AcyclicSCC bind) = tc_sub_group NonRecursive closed [bind] + tc_scc closed (CyclicSCC binds) = tc_sub_group Recursive closed binds - tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn - Recursive rec_tc closed binds + tc_sub_group rec_tc closed binds + = tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds recursivePatSynErr :: SrcSpan -- ^ The location of the first pattern synonym binding @@ -406,25 +428,6 @@ recursivePatSynErr recursivePatSynErr loc binds = failAt loc $ TcRnRecursivePatternSynonym binds -tc_single :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> LHsBind GhcRn -> IsGroupClosed -> TcM thing - -> TcM (LHsBinds GhcTc, thing) -tc_single _top_lvl sig_fn prag_fn - (L loc (PatSynBind _ psb)) - _ thing_inside - = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn - ; thing <- setGblEnv tcg_env thing_inside - ; return (aux_binds, thing) - } - -tc_single top_lvl sig_fn prag_fn lbind closed thing_inside - = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn - NonRecursive NonRecursive - closed - [lbind] - ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside - ; return (binds1, thing) } ------------------------ type BKey = Int -- Just number off the bindings @@ -432,18 +435,15 @@ type BKey = Int -- Just number off the bindings mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". mkEdges sig_fn binds - = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), - Just key <- [lookupNameEnv key_map n], no_sig n ] + = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (lHsBindFreeVars bind) + , Just key <- [lookupNameEnv key_map n] + , no_sig n ] | (bind, key) <- keyd_binds ] -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices -- is still deterministic even if the edges are in nondeterministic order -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. where - bind_fvs (FunBind { fun_ext = fvs }) = fvs - bind_fvs (PatBind { pat_ext = fvs }) = fvs - bind_fvs _ = emptyNameSet - no_sig :: Name -> Bool no_sig n = not (hasCompleteSig sig_fn n) @@ -1818,7 +1818,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds | has_mult_anns_and_pats = False -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear] - | IsGroupClosed _ True <- closed + | IsGroupClosed _ _ True <- closed , not (null binders) = True -- The 'True' means that all of the group's -- free vars have ClosedTypeId=True; so we can ignore @@ -1855,46 +1855,51 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed isClosedBndrGroup type_env binds - = IsGroupClosed fv_env type_closed + = IsGroupClosed is_top fv_env type_closed where - type_closed = allUFM (nameSetAll is_closed_type_id) fv_env - fv_env :: NameEnv NameSet - fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - - bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = L _ f - , fun_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(f, open_fvs)] - bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat] - bindFvs _ - = [] - - get_open_fvs fvs = filterNameSet (not . is_closed) fvs - - is_closed :: Name -> ClosedTypeId - is_closed name + fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ] + + bind_fvs :: [([Name],NameSet)] + bind_fvs = map (get_bind_fvs . unLoc) binds + + get_bind_fvs :: HsBindLR GhcRn GhcRn -> ([Name], NameSet) + get_bind_fvs (FunBind { fun_id = L _ f, fun_ext = fvs }) + = ([f],fvs) + get_bind_fvs (PatBind { pat_lhs = pat, pat_ext = fvs }) + = (collectPatBinders CollNoDictBinders pat, fvs) + get_bind_fvs _ = ([], emptyNameSet) + + all_bndrs = concatMap fst bind_fvs + all_fvs = foldr (unionNameSet . snd) emptyNameSet bind_fvs + `delListFromNameSet` all_bndrs + -- all_fvs does not include the binders of this group + + is_top | nameSetAll id_is_top all_fvs = TopLevel + | otherwise = NotTopLevel + + id_is_top :: Name -> Bool + id_is_top name | Just thing <- lookupNameEnv type_env name = case thing of - AGlobal {} -> True - ATcId { tct_info = ClosedLet } -> True - _ -> False + AGlobal {} -> True + ATcId { tct_info = LetBound { lb_top = top } } -> isTopLevel top + _ -> False - | otherwise - = True -- The free-var set for a top level binding mentions + | otherwise -- Imported Ids + = True + --------------------- + type_closed :: ClosedTypeId + type_closed = nameSetAll is_closed_type_id all_fvs is_closed_type_id :: Name -> Bool - -- We're already removed Global and ClosedLet Ids is_closed_type_id name | Just thing <- lookupNameEnv type_env name = case thing of - ATcId { tct_info = NonClosedLet _ cl } -> cl - ATcId { tct_info = NotLetBound } -> False - ATyVar {} -> False + AGlobal {} -> True + ATcId { tct_info = info } -> lb_closed info + ATyVar {} -> False -- In-scope type variables are not closed! _ -> pprPanic "is_closed_id" (ppr name) @@ -1904,6 +1909,23 @@ isClosedBndrGroup type_env binds -- These won't be in the local type env. -- Ditto class method etc from the current module +adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed +adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids + | TopLevel <- top_lvl + , all definitely_lifted ids = closed + | otherwise = IsGroupClosed NotTopLevel fv_env type_closed + where + definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id) + +sendToTopLevel :: IsGroupClosed -> TopLevelFlag +sendToTopLevel (IsGroupClosed top _ _) = top + +lHsBindFreeVars :: LHsBind GhcRn -> NameSet +lHsBindFreeVars (L _ (FunBind { fun_ext = fvs })) = fvs +lHsBindFreeVars (L _ (PatBind { pat_ext = fvs })) = fvs +lHsBindFreeVars _ = emptyNameSet + + {- Note [Always generalise top-level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is very confusing to apply NoGen to a top level binding. Consider (#20123): ===================================== compiler/GHC/Tc/Types/BasicTypes.hs ===================================== @@ -349,31 +349,33 @@ instance Outputable TcTyThing where -- Debugging only data IdBindingInfo -- See Note [Meaning of IdBindingInfo] = NotLetBound - | ClosedLet -- Can definitely be moved to top level - - | NonClosedLet - RhsNames -- Free vars of RHS of this Id's binding that are - -- neither Global nor ClosedLet - -- Used only to help with error-messages - -- in `checkClosedInStaticForm` - - ClosedTypeId -- True <=> This Id has a closed type - - -- Generalisation of some other binding (f x = e) is OK if - -- all free vars of `e` are ClosedTypeIds, or ClosedLet - --- | IsGroupClosed describes a group of mutually-recursive bindings + | LetBound + { lb_top :: TopLevelFlag + -- TopLevel <=> this binding may safely be moved to top level + -- E.g f x = let ys = reverse [1,2] + -- zs = reverse ys + -- in ... + -- Both ys and zs count as TopLevel + + , lb_fvs :: RhsNames + -- Free vars of the RHS that are NotLetBound, or LetBound NotTopLevel + -- Used to help with error messages in `checkClosedInStaticForm` + -- Domain = binders of this recursive group + + , lb_closed :: ClosedTypeId + -- True <=> this Id has a closed type + -- Generalisation of some other binding (f x = e) is OK if + -- all free vars of `e` have lb_clos=ClosedTypeId + } + +-- | IsGroupClosed describes a group of +-- mutually-recursive /renamed/ (but not yet typechecked) bindings data IsGroupClosed = IsGroupClosed - (NameEnv RhsNames) -- Free var info for the RHS of each binding in the group + TopLevelFlag -- TopLevel <=> all free vars are themselves TopLevel + (NameEnv RhsNames) -- Frees for the RHS of each binding in the group -- (includes free vars of RHS bound in the same group) - -- Used only to help with error-messages - -- in `checkClosedInStaticForm` - - ClosedTypeId -- True <=> all the free vars of the group are - -- imported or ClosedLet or - -- NonClosedLet with ClosedTypeId=True. - -- In particular, no tyvars, no NotLetBound + ClosedTypeId -- True <=> all the free vars of the group have closed types type RhsNames = NameSet -- Names of variables, mentioned on the RHS of -- a definition, that are not Global or ClosedLet @@ -520,9 +522,9 @@ in the type environment. instance Outputable IdBindingInfo where ppr NotLetBound = text "NotLetBound" - ppr ClosedLet = text "TopLevelLet" - ppr (NonClosedLet fvs closed_type) = - text "TopLevelLet" <+> ppr fvs <+> ppr closed_type + ppr (LetBound { lb_top = top_lvl, lb_fvs = fvs, lb_closed = cls }) + = text "LetBound" <> braces (sep [ ppr top_lvl, text "closed-type=" <+> ppr cls + , ppr fvs ]) -------------- pprTcTyThingCategory :: TcTyThing -> SDoc ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -675,12 +675,15 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a tcExtendRecIds pairs thing_inside = tc_extend_local_env NotTopLevel [ (name, ATcId { tct_id = let_id - , tct_info = NonClosedLet emptyNameSet False }) + , tct_info = LetBound { lb_top = NotTopLevel + , lb_fvs = emptyNameSet + , lb_closed = False } }) | (name, let_id) <- pairs ] $ thing_inside tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a -- Used for binding the Ids that have a complete user type signature +-- within a single recursive group. -- Does not extend the TcBinderStack tcExtendSigIds top_lvl sig_ids thing_inside = tc_extend_local_env top_lvl @@ -688,16 +691,19 @@ tcExtendSigIds top_lvl sig_ids thing_inside , tct_info = info }) | id <- sig_ids , let closed = isTypeClosedLetBndr id - info = NonClosedLet emptyNameSet closed ] + info = LetBound { lb_top = NotTopLevel + , lb_fvs = emptyNameSet + , lb_closed = closed } ] thing_inside tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed - -> [Scaled TcId] -> TcM a -> TcM a + -> [Scaled TcId] -> TcM a + -> TcM a -- Used for both top-level value bindings and nested let/where-bindings -- Used for a single NonRec or a single Rec -- Adds to the TcBinderStack too -tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) +tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_top fv_env _) ids thing_inside = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $ tc_extend_local_env top_lvl @@ -706,30 +712,15 @@ tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) | Scaled _ id <- ids ] $ foldr check_usage thing_inside scaled_names where - closed_let = all can_float_to_top ids - can_float_to_top (Scaled _ id) - = noFreeVarsOfType id_ty - && definitelyLiftedType id_ty - && case lookupNameEnv fvs (idName id) of - Nothing -> True - Just env -> isEmptyNameSet env - where - id_ty = idType id - mk_tct_info id - | closed_let = ClosedLet - | otherwise = NonClosedLet rhs_fvs type_closed - where - name = idName id - rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet - type_closed = isTypeClosedLetBndr id && - (fv_type_closed || hasCompleteSig sig_fn name) + = LetBound { lb_top = group_top + , lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet + , lb_closed = isTypeClosedLetBndr id } scaled_names = [Scaled p (idName id) | Scaled p id <- ids ] check_usage :: Scaled Name -> TcM a -> TcM a - check_usage (Scaled p id) thing_inside = do - tcCheckUsage id p thing_inside + check_usage (Scaled p id) thing_inside = tcCheckUsage id p thing_inside tcExtendIdEnv :: [TcId] -> TcM a -> TcM a -- For lambda-bound and case-bound Ids ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -679,13 +679,11 @@ zonkLocalBinds (EmptyLocalBinds x) zonkLocalBinds (HsValBinds _ (ValBinds {})) = panic "zonkLocalBinds" -- Not in typechecker output -zonkLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) - = do { new_binds <- traverse go binds - ; return (HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } +zonkLocalBinds (HsValBinds x (XValBindsLR (HsVBG binds sigs))) + = do { new_binds <- mapM go binds + ; return (HsValBinds x (XValBindsLR (HsVBG new_binds sigs))) } where - go (r,b) - = do { b' <- zonkRecMonoBinds b - ; return (r,b') } + go (r,b,s) = do { b' <- zonkRecMonoBinds b; return (r,b',s) } zonkLocalBinds (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- noBinders $ mapM (wrapLocZonkMA zonk_ip_bind) binds View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60381bd4ec11f75f06de0594d3e5dab2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60381bd4ec11f75f06de0594d3e5dab2... You're receiving this email because of your account on gitlab.haskell.org.