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
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:
| ... | ... | @@ -54,7 +54,7 @@ import GHC.Types.Name |
| 54 | 54 | |
| 55 | 55 | import GHC.Utils.Outputable
|
| 56 | 56 | import GHC.Utils.Panic
|
| 57 | -import GHC.Utils.Misc ((<||>))
|
|
| 57 | +import GHC.Utils.Misc
|
|
| 58 | 58 | |
| 59 | 59 | import Data.Function
|
| 60 | 60 | import Data.List (sortBy)
|
| ... | ... | @@ -80,12 +80,16 @@ type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen |
| 80 | 80 | |
| 81 | 81 | -- ---------------------------------------------------------------------
|
| 82 | 82 | type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag
|
| 83 | -type instance XXValBindsLR (GhcPass pL) pR = NHsValBindsLR pL
|
|
| 84 | 83 | |
| 85 | -data NHsValBindsLR (p :: Pass) where
|
|
| 86 | - NvbPs :: NHsValBindsLR 'Parsed
|
|
| 87 | - NvbRn :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> NHsValBindsLR 'Renamed
|
|
| 88 | - NvbTc :: [(RecFlag, LHsBinds GhcRn, Bool)] -> [LSig GhcRn] -> NHsValBindsLR 'Typechecked
|
|
| 84 | +type instance XXValBindsLR (GhcPass pL) _ = HsValBindGroups pL
|
|
| 85 | + |
|
| 86 | +data HsValBindGroups p -- Divided into strongly connected components
|
|
| 87 | + = HsVBG [HsValBindGroup (GhcPass p)] [LSig GhcRn]
|
|
| 88 | + |
|
| 89 | +type family HsValBindGroup p
|
|
| 90 | +type instance HsValBindGroup GhcPs = ()
|
|
| 91 | +type instance HsValBindGroup GhcRn = (RecFlag, LHsBinds GhcRn)
|
|
| 92 | +type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, TopLevelFlag)
|
|
| 89 | 93 | |
| 90 | 94 | -- ---------------------------------------------------------------------
|
| 91 | 95 | |
| ... | ... | @@ -449,18 +453,17 @@ instance (OutputableBndrId pl, OutputableBndrId pr) |
| 449 | 453 | ppr (ValBinds _ binds sigs)
|
| 450 | 454 | = pprDeclList (pprLHsBindsForUser binds sigs)
|
| 451 | 455 | |
| 452 | - ppr (XValBindsLR nvbs)
|
|
| 453 | - = case nvbs of
|
|
| 454 | - NvbPs -> empty
|
|
| 455 | - NvbRn prs sigs -> ppr_vb prs sigs
|
|
| 456 | - NvbTc triples sigs -> ppr_vb [(a,b) | (a,b,_)<-triples] sigs
|
|
| 457 | - -- Discard closed-flag for now
|
|
| 456 | + ppr (XValBindsLR (HsVBG bs sigs))
|
|
| 457 | + = getPprDebug $ \case
|
|
| 458 | + False -> pprDeclList (pprLHsBindsForUser (concat (map snd prs)) sigs)
|
|
| 459 | + True -> -- Print with sccs showing
|
|
| 460 | + vcat (map ppr sigs) $$ vcat (map ppr_scc prs)
|
|
| 458 | 461 | where
|
| 459 | - ppr_vb prs sigs
|
|
| 460 | - = getPprDebug $ \case
|
|
| 461 | - False -> pprDeclList (pprLHsBindsForUser (concat (map snd prs)) sigs)
|
|
| 462 | - True -> -- Print with sccs showing
|
|
| 463 | - vcat (map ppr sigs) $$ vcat (map ppr_scc prs)
|
|
| 462 | + prs :: [(RecFlag, LHsBinds (GhcPass pl))]
|
|
| 463 | + prs = case ghcPass @pl of
|
|
| 464 | + GhcPs -> []
|
|
| 465 | + GhcRn -> bs
|
|
| 466 | + GhcTc -> [(a,b)|(a,b,_)<-bs] -- Discard closed-flag for now
|
|
| 464 | 467 | |
| 465 | 468 | ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
|
| 466 | 469 | pp_rec Recursive = text "rec"
|
| ... | ... | @@ -513,14 +516,12 @@ eqEmptyLocalBinds _ = False |
| 513 | 516 | |
| 514 | 517 | isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
|
| 515 | 518 | isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
|
| 516 | -isEmptyValBinds (XValBindsLR NvbPs) = True
|
|
| 517 | -isEmptyValBinds (XValBindsLR (NvbRn ds sigs)) = null ds && null sigs
|
|
| 518 | -isEmptyValBinds (XValBindsLR (NvbTc ds sigs)) = null ds && null sigs
|
|
| 519 | +isEmptyValBinds (XValBindsLR (HsVBG ds sigs)) = null ds && null sigs
|
|
| 519 | 520 | |
| 520 | 521 | emptyValBindsIn :: HsValBindsLR (GhcPass a) (GhcPass b)
|
| 521 | 522 | emptyValBindsIn = ValBinds NoAnnSortKey [] []
|
| 522 | 523 | emptyValBindsRn :: HsValBindsLR GhcRn GhcRn
|
| 523 | -emptyValBindsRn = XValBindsLR (NvbRn [] [])
|
|
| 524 | +emptyValBindsRn = XValBindsLR (HsVBG [] [])
|
|
| 524 | 525 | |
| 525 | 526 | emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR
|
| 526 | 527 | emptyLHsBinds = []
|
| ... | ... | @@ -528,19 +529,21 @@ emptyLHsBinds = [] |
| 528 | 529 | isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool
|
| 529 | 530 | isEmptyLHsBinds = null
|
| 530 | 531 | |
| 532 | +hsValBindGroupsBinds :: forall p. IsPass p
|
|
| 533 | + => [HsValBindGroup (GhcPass p)] -> [LHsBind (GhcPass p)]
|
|
| 534 | +hsValBindGroupsBinds binds
|
|
| 535 | + = case ghcPass @p of
|
|
| 536 | + GhcPs -> []
|
|
| 537 | + GhcRn -> concatMap snd binds
|
|
| 538 | + GhcTc -> concatMap sndOf3 binds
|
|
| 539 | + |
|
| 531 | 540 | ------------
|
| 532 | 541 | plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
|
| 533 | 542 | -> HsValBinds(GhcPass a)
|
| 534 | 543 | plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
|
| 535 | 544 | = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2)
|
| 536 | -plusHsValBinds (XValBindsLR nvbs1) (XValBindsLR nvbs2)
|
|
| 537 | - = XValBindsLR (nvbs1 `plus` nvbs2)
|
|
| 538 | - where
|
|
| 539 | - plus :: NHsValBindsLR p -> NHsValBindsLR p -> NHsValBindsLR p
|
|
| 540 | - NvbPs `plus` NvbPs = NvbPs
|
|
| 541 | - (NvbRn ds1 sigs1) `plus` (NvbRn ds2 sigs2) = NvbRn (ds1 ++ ds2) (sigs1 ++ sigs2)
|
|
| 542 | - (NvbTc ds1 sigs1) `plus` (NvbTc ds2 sigs2) = NvbTc (ds1 ++ ds2) (sigs1 ++ sigs2)
|
|
| 543 | - |
|
| 545 | +plusHsValBinds (XValBindsLR (HsVBG ds1 ss1)) (XValBindsLR (HsVBG ds2 ss2))
|
|
| 546 | + = XValBindsLR (HsVBG (ds1++ds2) (ss1++ss2))
|
|
| 544 | 547 | plusHsValBinds _ _
|
| 545 | 548 | = panic "HsBinds.plusHsValBinds"
|
| 546 | 549 |
| 1 | 1 | {-# LANGUAGE TypeFamilies #-}
|
| 2 | +{-# LANGUAGE DataKinds #-}
|
|
| 2 | 3 | {-# LANGUAGE StandaloneDeriving #-}
|
| 3 | 4 | {-# LANGUAGE DeriveDataTypeable #-}
|
| 4 | 5 | {-# LANGUAGE FlexibleContexts #-}
|
| ... | ... | @@ -56,9 +57,9 @@ deriving instance Data (HsValBindsLR GhcRn GhcRn) |
| 56 | 57 | deriving instance Data (HsValBindsLR GhcTc GhcTc)
|
| 57 | 58 | |
| 58 | 59 | -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL)
|
| 59 | -deriving instance Data (NHsValBindsLR 'Parsed)
|
|
| 60 | -deriving instance Data (NHsValBindsLR 'Renamed)
|
|
| 61 | -deriving instance Data (NHsValBindsLR 'Typechecked)
|
|
| 60 | +deriving instance Data (HsValBindGroups 'Parsed)
|
|
| 61 | +deriving instance Data (HsValBindGroups 'Renamed)
|
|
| 62 | +deriving instance Data (HsValBindGroups 'Typechecked)
|
|
| 62 | 63 | |
| 63 | 64 | -- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR)
|
| 64 | 65 | deriving instance Data (HsBindLR GhcPs GhcPs)
|
| ... | ... | @@ -886,24 +886,23 @@ isInfixFunBind (FunBind { fun_matches = MG _ matches }) |
| 886 | 886 | isInfixFunBind _ = False
|
| 887 | 887 | |
| 888 | 888 | -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds
|
| 889 | -spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan
|
|
| 890 | -spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan
|
|
| 889 | +spanHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> SrcSpan
|
|
| 890 | +spanHsLocaLBinds (EmptyLocalBinds _)
|
|
| 891 | + = noSrcSpan
|
|
| 892 | +spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
|
|
| 893 | + = get_bind_spans bs []
|
|
| 891 | 894 | spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
|
| 892 | - = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
|
|
| 893 | - where
|
|
| 894 | - bsSpans :: [SrcSpan]
|
|
| 895 | - bsSpans = map getLocA bs
|
|
| 896 | - sigsSpans :: [SrcSpan]
|
|
| 897 | - sigsSpans = map getLocA sigs
|
|
| 898 | -spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
|
|
| 899 | - = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
|
|
| 895 | + = get_bind_spans bs sigs
|
|
| 896 | +spanHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG bs ss)))
|
|
| 897 | + = get_bind_spans (hsValBindGroupsBinds @p bs) ss
|
|
| 898 | + |
|
| 899 | +get_bind_spans :: (HasLoc l) => [GenLocated l a] -> [GenLocated l b] -> SrcSpan
|
|
| 900 | +get_bind_spans binds sigs
|
|
| 901 | + = foldr combineSrcSpans noSrcSpan (bs_spans ++ sigs_spans)
|
|
| 900 | 902 | where
|
| 901 | - bsSpans :: [SrcSpan]
|
|
| 902 | - bsSpans = map getLocA $ concatMap snd bs
|
|
| 903 | - sigsSpans :: [SrcSpan]
|
|
| 904 | - sigsSpans = map getLocA sigs
|
|
| 905 | -spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
|
|
| 906 | - = foldr combineSrcSpans noSrcSpan (map getLocA bs)
|
|
| 903 | + bs_spans, sigs_spans :: [SrcSpan]
|
|
| 904 | + bs_spans = map getLocA binds
|
|
| 905 | + sigs_spans = map getLocA sigs
|
|
| 907 | 906 | |
| 908 | 907 | ------------
|
| 909 | 908 | -- | Convenience function using 'mkFunBind'.
|
| ... | ... | @@ -1075,7 +1074,7 @@ isBangedHsBind (PatBind {pat_lhs = pat}) |
| 1075 | 1074 | isBangedHsBind _
|
| 1076 | 1075 | = False
|
| 1077 | 1076 | |
| 1078 | -collectLocalBinders :: CollectPass (GhcPass idL)
|
|
| 1077 | +collectLocalBinders :: (IsPass idL, CollectPass (GhcPass idL))
|
|
| 1079 | 1078 | => CollectFlag (GhcPass idL)
|
| 1080 | 1079 | -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
|
| 1081 | 1080 | -> [IdP (GhcPass idL)]
|
| ... | ... | @@ -1085,14 +1084,14 @@ collectLocalBinders flag = \case |
| 1085 | 1084 | HsIPBinds {} -> []
|
| 1086 | 1085 | EmptyLocalBinds _ -> []
|
| 1087 | 1086 | |
| 1088 | -collectHsIdBinders :: CollectPass (GhcPass idL)
|
|
| 1087 | +collectHsIdBinders :: (IsPass idL, CollectPass (GhcPass idL))
|
|
| 1089 | 1088 | => CollectFlag (GhcPass idL)
|
| 1090 | 1089 | -> HsValBindsLR (GhcPass idL) (GhcPass idR)
|
| 1091 | 1090 | -> [IdP (GhcPass idL)]
|
| 1092 | 1091 | -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
|
| 1093 | 1092 | collectHsIdBinders flag = collect_hs_val_binders True flag
|
| 1094 | 1093 | |
| 1095 | -collectHsValBinders :: CollectPass (GhcPass idL)
|
|
| 1094 | +collectHsValBinders :: (IsPass idL, CollectPass (GhcPass idL))
|
|
| 1096 | 1095 | => CollectFlag (GhcPass idL)
|
| 1097 | 1096 | -> HsValBindsLR (GhcPass idL) idR
|
| 1098 | 1097 | -> [IdP (GhcPass idL)]
|
| ... | ... | @@ -1118,21 +1117,14 @@ collectHsBindListBinders :: forall p idR. CollectPass p |
| 1118 | 1117 | -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
|
| 1119 | 1118 | collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []
|
| 1120 | 1119 | |
| 1121 | -collect_hs_val_binders :: CollectPass (GhcPass idL)
|
|
| 1120 | +collect_hs_val_binders :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL))
|
|
| 1122 | 1121 | => Bool
|
| 1123 | 1122 | -> CollectFlag (GhcPass idL)
|
| 1124 | 1123 | -> HsValBindsLR (GhcPass idL) idR
|
| 1125 | 1124 | -> [IdP (GhcPass idL)]
|
| 1126 | 1125 | collect_hs_val_binders ps flag = \case
|
| 1127 | - ValBinds _ binds _ -> collect_binds ps flag binds []
|
|
| 1128 | - XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds
|
|
| 1129 | - |
|
| 1130 | -collect_out_binds :: forall p. CollectPass p
|
|
| 1131 | - => Bool
|
|
| 1132 | - -> CollectFlag p
|
|
| 1133 | - -> [(RecFlag, LHsBinds p)]
|
|
| 1134 | - -> [IdP p]
|
|
| 1135 | -collect_out_binds ps flag = foldr (collect_binds ps flag . snd) []
|
|
| 1126 | + ValBinds _ binds _ -> collect_binds ps flag binds []
|
|
| 1127 | + XValBindsLR (HsVBG grps _) -> collect_binds ps flag (hsValBindGroupsBinds @idL grps) []
|
|
| 1136 | 1128 | |
| 1137 | 1129 | collect_binds :: forall p idR. CollectPass p
|
| 1138 | 1130 | => Bool
|
| ... | ... | @@ -1529,8 +1521,8 @@ hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p) |
| 1529 | 1521 | -- ^ Collects record pattern-synonym selectors only; the pattern synonym
|
| 1530 | 1522 | -- names are collected by 'collectHsValBinders'.
|
| 1531 | 1523 | hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
|
| 1532 | -hsPatSynSelectors (XValBindsLR (NValBinds binds _))
|
|
| 1533 | - = foldr addPatSynSelector [] . concat $ map snd binds
|
|
| 1524 | +hsPatSynSelectors (XValBindsLR (HsVBG grps _))
|
|
| 1525 | + = foldr addPatSynSelector [] $ hsValBindGroupsBinds grps
|
|
| 1534 | 1526 | |
| 1535 | 1527 | addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p]
|
| 1536 | 1528 | addPatSynSelector bind sels
|
| ... | ... | @@ -1538,11 +1530,10 @@ addPatSynSelector bind sels |
| 1538 | 1530 | = map recordPatSynField as ++ sels
|
| 1539 | 1531 | | otherwise = sels
|
| 1540 | 1532 | |
| 1541 | -getPatSynBinds :: forall id. UnXRec id
|
|
| 1542 | - => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
|
|
| 1533 | +getPatSynBinds :: [(RecFlag, LHsBinds GhcRn)] -> [PatSynBind GhcRn GhcRn]
|
|
| 1543 | 1534 | getPatSynBinds binds
|
| 1544 | 1535 | = [ psb | (_, lbinds) <- binds
|
| 1545 | - , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ]
|
|
| 1536 | + , L _ (PatSynBind _ psb) <- lbinds ]
|
|
| 1546 | 1537 | |
| 1547 | 1538 | -------------------
|
| 1548 | 1539 | hsLInstDeclBinders :: (IsPass p, OutputableBndrId p)
|
| ... | ... | @@ -1813,8 +1804,8 @@ lStmtsImplicits = hs_lstmts |
| 1813 | 1804 | |
| 1814 | 1805 | hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)
|
| 1815 | 1806 | -> [(SrcSpan, [ImplicitFieldBinders])]
|
| 1816 | -hsValBindsImplicits (XValBindsLR (NvbRn binds _))
|
|
| 1817 | - = concatMap (lhsBindsImplicits . snd) binds
|
|
| 1807 | +hsValBindsImplicits (XValBindsLR (HsVBG grps _))
|
|
| 1808 | + = lhsBindsImplicits (hsValBindGroupsBinds grps)
|
|
| 1818 | 1809 | hsValBindsImplicits (ValBinds _ binds _)
|
| 1819 | 1810 | = lhsBindsImplicits binds
|
| 1820 | 1811 |
| ... | ... | @@ -525,12 +525,12 @@ ungroup (HsGroup {..}) = |
| 525 | 525 | mkDecls (ValD noExtField) (valbinds hs_valds)
|
| 526 | 526 | where
|
| 527 | 527 | typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
|
| 528 | - typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
|
|
| 528 | + typesigs (XValBindsLR (HsVBG _ sig)) = filter (isUserSig . unLoc) sig
|
|
| 529 | 529 | typesigs ValBinds{} = error "expected XValBindsLR"
|
| 530 | 530 | |
| 531 | 531 | valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
|
| 532 | - valbinds (XValBindsLR (NValBinds binds _)) =
|
|
| 533 | - concat . snd . unzip $ binds
|
|
| 532 | + valbinds (XValBindsLR (HsVBG grps _)) =
|
|
| 533 | + concat . snd . unzip $ grps
|
|
| 534 | 534 | valbinds ValBinds{} = error "expected XValBindsLR"
|
| 535 | 535 | |
| 536 | 536 | -- | Collect docs and attach them to the right declarations.
|
| ... | ... | @@ -380,8 +380,8 @@ sequenceGrdDagMapM f as = sequenceGrdDags <$> traverse f as |
| 380 | 380 | -- recursion, pattern bindings etc.
|
| 381 | 381 | -- See Note [Long-distance information for HsLocalBinds].
|
| 382 | 382 | desugarLocalBinds :: HsLocalBinds GhcTc -> DsM GrdDag
|
| 383 | -desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
|
|
| 384 | - sequenceGrdDagMapM (sequenceGrdDagMapM go) (map snd binds)
|
|
| 383 | +desugarLocalBinds (HsValBinds _ (XValBindsLR (HsVBG grps _))) =
|
|
| 384 | + sequenceGrdDagMapM go (hsValBindGroupsBinds grps)
|
|
| 385 | 385 | where
|
| 386 | 386 | go :: LHsBind GhcTc -> DsM GrdDag
|
| 387 | 387 | go (L _ FunBind{fun_id = L _ x, fun_matches = mg})
|
| 1 | -{-# LANGUAGE NondecreasingIndentation #-}
|
|
| 1 | +{-# LANGUAGE NondecreasingIndentation, DataKinds #-}
|
|
| 2 | 2 | |
| 3 | 3 | {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
|
| 4 | 4 | |
| ... | ... | @@ -850,15 +850,12 @@ addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) |
| 850 | 850 | |
| 851 | 851 | addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
|
| 852 | 852 | -> TM (HsValBindsLR GhcTc (GhcPass b))
|
| 853 | -addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
|
|
| 854 | - b <- liftM2 NValBinds
|
|
| 855 | - (mapM (\ (rec,binds') ->
|
|
| 856 | - liftM2 (,)
|
|
| 857 | - (return rec)
|
|
| 858 | - (addTickLHsBinds binds'))
|
|
| 859 | - binds)
|
|
| 860 | - (return sigs)
|
|
| 861 | - return $ XValBindsLR b
|
|
| 853 | +addTickHsValBinds (XValBindsLR (HsVBG grps sigs)) = do
|
|
| 854 | + grps' <- mapM (\ (rec,binds,static) ->
|
|
| 855 | + do { binds' <- addTickLHsBinds binds
|
|
| 856 | + ; return (rec,binds',static) })
|
|
| 857 | + grps
|
|
| 858 | + return $ XValBindsLR (HsVBG grps' sigs)
|
|
| 862 | 859 | addTickHsValBinds _ = panic "addTickHsValBinds"
|
| 863 | 860 | |
| 864 | 861 | addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
|
| ... | ... | @@ -1422,7 +1419,8 @@ instance CollectFldBinders (HsLocalBinds GhcTc) where |
| 1422 | 1419 | collectFldBinds EmptyLocalBinds{} = emptyVarEnv
|
| 1423 | 1420 | instance CollectFldBinders (HsValBinds GhcTc) where
|
| 1424 | 1421 | collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds
|
| 1425 | - collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds)
|
|
| 1422 | + collectFldBinds (XValBindsLR (HsVBG grps _))
|
|
| 1423 | + = collectFldBinds (hsValBindGroupsBinds @'Typechecked grps)
|
|
| 1426 | 1424 | instance CollectFldBinders (HsBind GhcTc) where
|
| 1427 | 1425 | collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs
|
| 1428 | 1426 | collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) =
|
| ... | ... | @@ -430,7 +430,7 @@ getRealSpan :: SrcSpan -> Maybe Span |
| 430 | 430 | getRealSpan (RealSrcSpan sp _) = Just sp
|
| 431 | 431 | getRealSpan _ = Nothing
|
| 432 | 432 | |
| 433 | -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)
|
|
| 433 | +grhss_span :: (IsPass p, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns)
|
|
| 434 | 434 | => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan
|
| 435 | 435 | grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (NE.map getLocA xs)
|
| 436 | 436 | |
| ... | ... | @@ -1437,7 +1437,7 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where |
| 1437 | 1437 | valBinds
|
| 1438 | 1438 | ]
|
| 1439 | 1439 | |
| 1440 | -scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope
|
|
| 1440 | +scopeHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> Scope
|
|
| 1441 | 1441 | scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
|
| 1442 | 1442 | = foldr combineScopes NoScope (bsScope ++ sigsScope)
|
| 1443 | 1443 | where
|
| ... | ... | @@ -1445,11 +1445,11 @@ scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) |
| 1445 | 1445 | bsScope = map (mkScope . getLoc) bs
|
| 1446 | 1446 | sigsScope :: [Scope]
|
| 1447 | 1447 | sigsScope = map (mkScope . getLocA) sigs
|
| 1448 | -scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
|
|
| 1448 | +scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG grps sigs)))
|
|
| 1449 | 1449 | = foldr combineScopes NoScope (bsScope ++ sigsScope)
|
| 1450 | 1450 | where
|
| 1451 | 1451 | bsScope :: [Scope]
|
| 1452 | - bsScope = map (mkScope . getLoc) $ concatMap snd bs
|
|
| 1452 | + bsScope = map (mkScope . getLoc) (hsValBindGroupsBinds @p grps)
|
|
| 1453 | 1453 | sigsScope :: [Scope]
|
| 1454 | 1454 | sigsScope = map (mkScope . getLocA) sigs
|
| 1455 | 1455 | |
| ... | ... | @@ -1473,9 +1473,9 @@ instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) whe |
| 1473 | 1473 | ]
|
| 1474 | 1474 | XValBindsLR x -> [ toHie $ RS sc x ]
|
| 1475 | 1475 | |
| 1476 | -instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where
|
|
| 1477 | - toHie (RS sc (NValBinds binds sigs)) = concatM $
|
|
| 1478 | - [ toHie (concatMap (map (BC RegularBind sc) . snd) binds)
|
|
| 1476 | +instance HiePass p => ToHie (RScoped (HsValBindGroups p)) where
|
|
| 1477 | + toHie (RS sc (HsVBG binds sigs)) = concatM $
|
|
| 1478 | + [ toHie (map (BC RegularBind sc) (hsValBindGroupsBinds @p binds))
|
|
| 1479 | 1479 | , toHie $ fmap (SC (SI BindSig Nothing)) sigs
|
| 1480 | 1480 | ]
|
| 1481 | 1481 |
| ... | ... | @@ -225,7 +225,7 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs |
| 225 | 225 | -- Return a single HsBindGroup with empty binds and renamed signatures
|
| 226 | 226 | rnTopBindsBoot bound_names (ValBinds _ _ sigs)
|
| 227 | 227 | = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
|
| 228 | - ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
|
|
| 228 | + ; return (XValBindsLR (HsVBG [] sigs'), usesOnly fvs) }
|
|
| 229 | 229 | rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
|
| 230 | 230 | |
| 231 | 231 | {-
|
| ... | ... | @@ -356,7 +356,7 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs) |
| 356 | 356 | -- so that the binders are removed from
|
| 357 | 357 | -- the uses in the sigs
|
| 358 | 358 | |
| 359 | - ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } }
|
|
| 359 | + ; return (XValBindsLR (HsVBG anal_binds sigs'), valbind'_dus) } }
|
|
| 360 | 360 | |
| 361 | 361 | rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
|
| 362 | 362 |
| ... | ... | @@ -182,7 +182,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, |
| 182 | 182 | -- (F) Rename Value declarations right-hand sides
|
| 183 | 183 | traceRn "Start rnmono" empty ;
|
| 184 | 184 | let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
|
| 185 | - (rn_val_decls@(XValBindsLR (NValBinds _ sigs')), bind_dus) <- if is_boot
|
|
| 185 | + (rn_val_decls@(XValBindsLR (HsVBG _ sigs')), bind_dus) <- if is_boot
|
|
| 186 | 186 | -- For an hs-boot, use tc_bndrs (which collects how we're renamed
|
| 187 | 187 | -- signatures), since val_bndr_set is empty (there are no x = ...
|
| 188 | 188 | -- bindings in an hs-boot.)
|
| ... | ... | @@ -59,7 +59,7 @@ import GHC.Core.Multiplicity |
| 59 | 59 | import GHC.Core.FamInstEnv( normaliseType )
|
| 60 | 60 | import GHC.Core.Class ( Class )
|
| 61 | 61 | import GHC.Core.Coercion( mkSymCo )
|
| 62 | -import GHC.Core.Type (mkStrLitTy, mkCastTy)
|
|
| 62 | +import GHC.Core.Type (mkStrLitTy, mkCastTy, definitelyLiftedType)
|
|
| 63 | 63 | import GHC.Core.TyCo.Ppr( pprTyVars )
|
| 64 | 64 | import GHC.Core.TyCo.Tidy( tidyOpenTypeX )
|
| 65 | 65 | |
| ... | ... | @@ -83,7 +83,6 @@ import GHC.Types.Basic |
| 83 | 83 | import GHC.Utils.Outputable as Outputable
|
| 84 | 84 | import GHC.Utils.Panic
|
| 85 | 85 | import GHC.Builtin.Names( ipClassName )
|
| 86 | -import GHC.Types.Unique.FM
|
|
| 87 | 86 | import GHC.Types.Unique.Set
|
| 88 | 87 | import qualified GHC.LanguageExtensions as LangExt
|
| 89 | 88 | |
| ... | ... | @@ -198,7 +197,7 @@ tcTopBinds binds sigs |
| 198 | 197 | |
| 199 | 198 | ; let { tcg_env' = tcg_env { tcg_imp_specs
|
| 200 | 199 | = specs ++ tcg_imp_specs tcg_env }
|
| 201 | - `addTypecheckedBinds` map snd binds' }
|
|
| 200 | + `addTypecheckedBinds` map sndOf3 binds' }
|
|
| 202 | 201 | |
| 203 | 202 | ; return (tcg_env', tcl_env) }
|
| 204 | 203 | -- The top level bindings are flattened into a giant
|
| ... | ... | @@ -229,9 +228,9 @@ tcLocalBinds (EmptyLocalBinds x) thing_inside |
| 229 | 228 | = do { thing <- thing_inside
|
| 230 | 229 | ; return (EmptyLocalBinds x, thing) }
|
| 231 | 230 | |
| 232 | -tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
|
|
| 233 | - = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
|
|
| 234 | - ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
|
|
| 231 | +tcLocalBinds (HsValBinds x (XValBindsLR (HsVBG grps sigs))) thing_inside
|
|
| 232 | + = do { (grps', thing) <- tcValBinds NotTopLevel grps sigs thing_inside
|
|
| 233 | + ; return (HsValBinds x (XValBindsLR (HsVBG grps' sigs)), thing) }
|
|
| 235 | 234 | tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
|
| 236 | 235 | |
| 237 | 236 | tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
|
| ... | ... | @@ -261,9 +260,9 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside |
| 261 | 260 | tcValBinds :: TopLevelFlag
|
| 262 | 261 | -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
|
| 263 | 262 | -> TcM thing
|
| 264 | - -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
|
|
| 263 | + -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
|
|
| 265 | 264 | |
| 266 | -tcValBinds top_lvl binds sigs thing_inside
|
|
| 265 | +tcValBinds top_lvl grps sigs thing_inside
|
|
| 267 | 266 | = do { -- Typecheck the signatures
|
| 268 | 267 | -- It's easier to do so now, once for all the SCCs together
|
| 269 | 268 | -- because a single signature f,g :: <type>
|
| ... | ... | @@ -281,24 +280,24 @@ tcValBinds top_lvl binds sigs thing_inside |
| 281 | 280 | -- only unrestricted variables.
|
| 282 | 281 | ; tcExtendSigIds top_lvl poly_ids $
|
| 283 | 282 | do { (binds', (extra_binds', thing))
|
| 284 | - <- tcBindGroups top_lvl sig_fn prag_fn binds $
|
|
| 283 | + <- tcBindGroups top_lvl sig_fn prag_fn grps $
|
|
| 285 | 284 | do { thing <- thing_inside
|
| 286 | 285 | -- See Note [Pattern synonym builders don't yield dependencies]
|
| 287 | 286 | -- in GHC.Rename.Bind
|
| 288 | 287 | ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns
|
| 289 | - ; let extra_binds = [ (NonRecursive, builder)
|
|
| 288 | + ; let extra_binds = [ (NonRecursive, builder, TopLevel)
|
|
| 290 | 289 | | builder <- patsyn_builders ]
|
| 291 | 290 | ; return (extra_binds, thing) }
|
| 292 | 291 | ; return (binds' ++ extra_binds', thing) }}
|
| 293 | 292 | where
|
| 294 | - patsyns = getPatSynBinds binds
|
|
| 295 | - prag_fn = mkPragEnv sigs (concatMap snd binds)
|
|
| 293 | + patsyns = getPatSynBinds grps
|
|
| 294 | + prag_fn = mkPragEnv sigs (hsValBindGroupsBinds grps)
|
|
| 296 | 295 | |
| 297 | 296 | ------------------------
|
| 298 | 297 | |
| 299 | 298 | tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
|
| 300 | 299 | -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
|
| 301 | - -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
|
|
| 300 | + -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
|
|
| 302 | 301 | -- Typecheck a whole lot of value bindings,
|
| 303 | 302 | -- one strongly-connected component at a time
|
| 304 | 303 | -- Here a "strongly connected component" has the straightforward
|
| ... | ... | @@ -310,9 +309,8 @@ tcBindGroups _ _ _ [] thing_inside |
| 310 | 309 | ; return ([], thing) }
|
| 311 | 310 | |
| 312 | 311 | tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
|
| 313 | - = do { -- See Note [Closed binder groups]
|
|
| 314 | - ; (group', (groups', thing))
|
|
| 315 | - <- tc_group top_lvl sig_fn prag_fn group closed $
|
|
| 312 | + = do { (group', (groups', thing))
|
|
| 313 | + <- tc_group top_lvl sig_fn prag_fn group $
|
|
| 316 | 314 | tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
|
| 317 | 315 | ; return (group' : groups', thing) }
|
| 318 | 316 | |
| ... | ... | @@ -336,30 +334,54 @@ before we sub-divide it based on what type signatures it has. |
| 336 | 334 | tc_group :: forall thing.
|
| 337 | 335 | TopLevelFlag -> TcSigFun -> TcPragEnv
|
| 338 | 336 | -> (RecFlag, LHsBinds GhcRn) -> TcM thing
|
| 339 | - -> TcM ((RecFlag, LHsBinds GhcTc, Bool), thing)
|
|
| 340 | - |
|
| 337 | + -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
|
|
| 341 | 338 | -- Typecheck one strongly-connected component of the original program.
|
| 339 | +tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside
|
|
| 340 | + = case rec_flag of
|
|
| 341 | + NonRecursive -> tc_nonrec_group top_lvl sig_fn prag_fn binds thing_inside
|
|
| 342 | + Recursive -> tc_rec_group top_lvl sig_fn prag_fn binds thing_inside
|
|
| 343 | + |
|
| 344 | +---------------------
|
|
| 345 | +tc_nonrec_group :: forall thing.
|
|
| 346 | + TopLevelFlag -> TcSigFun -> TcPragEnv
|
|
| 347 | + -> LHsBinds GhcRn -> TcM thing
|
|
| 348 | + -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
|
|
| 349 | +tc_nonrec_group top_lvl sig_fn prag_fn [lbind] thing_inside
|
|
| 350 | + | L loc (PatSynBind _ psb) <- lbind
|
|
| 351 | + = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn
|
|
| 352 | + ; thing <- setGblEnv tcg_env thing_inside
|
|
| 353 | + ; return ((NonRecursive, aux_binds, TopLevel), thing) }
|
|
| 342 | 354 | |
| 343 | -tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
|
|
| 344 | - -- A single non-recursive binding
|
|
| 355 | + | otherwise
|
|
| 356 | + = -- A single non-recursive binding
|
|
| 345 | 357 | -- We want to keep non-recursive things non-recursive
|
| 346 | 358 | -- so that we desugar unlifted bindings correctly
|
| 347 | - = do { type_env <- getLclTypeEnv
|
|
| 348 | - ; let closed = isClosedBndrGroup type_env binds
|
|
| 349 | - bind = case binds of
|
|
| 350 | - [bind] -> bind
|
|
| 351 | - [] -> panic "tc_group: empty list of binds"
|
|
| 352 | - _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
|
|
| 353 | - ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
|
|
| 354 | - thing_inside
|
|
| 355 | - ; return ( (NonRecursive, bind'), thing) }
|
|
| 356 | - |
|
| 357 | -tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
|
|
| 358 | - = -- To maximise polymorphism, we do a new
|
|
| 359 | - -- strongly-connected-component analysis, this time omitting
|
|
| 360 | - -- any references to variables with type signatures.
|
|
| 361 | - -- (This used to be optional, but isn't now.)
|
|
| 362 | - -- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
|
|
| 359 | + do { type_env <- getLclTypeEnv
|
|
| 360 | + ; let closed = isClosedBndrGroup type_env [lbind]
|
|
| 361 | + ; (bind', ids) <- tcPolyBinds top_lvl sig_fn prag_fn
|
|
| 362 | + NonRecursive NonRecursive
|
|
| 363 | + closed
|
|
| 364 | + [lbind]
|
|
| 365 | + |
|
| 366 | + ; let final_closed = adjustClosedForUnlifted closed ids
|
|
| 367 | + |
|
| 368 | + ; thing <- tcExtendLetEnv top_lvl sig_fn final_closed ids thing_inside
|
|
| 369 | + ; return ( (NonRecursive, bind', sendToTopLevel final_closed), thing ) }
|
|
| 370 | + |
|
| 371 | +tc_nonrec_group _ _ _ binds _ -- Non-rec groups should always be a singleton
|
|
| 372 | + = pprPanic "tc_nonrec_group" (ppr binds)
|
|
| 373 | + |
|
| 374 | +---------------------
|
|
| 375 | +tc_rec_group :: forall thing.
|
|
| 376 | + TopLevelFlag -> TcSigFun -> TcPragEnv
|
|
| 377 | + -> LHsBinds GhcRn -> TcM thing
|
|
| 378 | + -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
|
|
| 379 | +tc_rec_group top_lvl sig_fn prag_fn binds thing_inside
|
|
| 380 | + = -- For a recursive group, to maximise polymorphism, we do a new
|
|
| 381 | + -- strongly-connected-component analysis, this time omitting
|
|
| 382 | + -- any references to variables with type signatures.
|
|
| 383 | + -- (This used to be optional, but isn't now.)
|
|
| 384 | + -- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
|
|
| 363 | 385 | do { traceTc "tc_group rec" (pprLHsBinds binds)
|
| 364 | 386 | ; type_env <- getLclTypeEnv
|
| 365 | 387 | ; let closed = isClosedBndrGroup type_env binds
|
| ... | ... | @@ -371,7 +393,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside |
| 371 | 393 | -- Typecheck the SCCs in turn
|
| 372 | 394 | ; (binds1, thing) <- go closed sccs
|
| 373 | 395 | |
| 374 | - ; return ((Recursive, binds1), thing) }
|
|
| 396 | + ; return ((Recursive, binds1, sendToTopLevel closed), thing) }
|
|
| 375 | 397 | -- Rec them all together
|
| 376 | 398 | where
|
| 377 | 399 | mbFirstPatSyn = find (isPatSyn . unLoc) binds
|
| ... | ... | @@ -383,7 +405,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside |
| 383 | 405 | |
| 384 | 406 | go :: IsGroupClosed -> [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
|
| 385 | 407 | go closed (scc:sccs)
|
| 386 | - = do { (binds1, ids1) <- tc_scc scc
|
|
| 408 | + = do { (binds1, ids1) <- tc_scc closed scc
|
|
| 387 | 409 | -- recursive bindings must be unrestricted
|
| 388 | 410 | -- (the ids added to the environment here are
|
| 389 | 411 | -- the name of the recursive definitions)
|
| ... | ... | @@ -392,11 +414,11 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside |
| 392 | 414 | ; return (binds1 ++ binds2, thing) }
|
| 393 | 415 | go _ [] = do { thing <- thing_inside; return ([], thing) }
|
| 394 | 416 | |
| 395 | - tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
|
|
| 396 | - tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
|
|
| 417 | + tc_scc closed (AcyclicSCC bind) = tc_sub_group NonRecursive closed [bind]
|
|
| 418 | + tc_scc closed (CyclicSCC binds) = tc_sub_group Recursive closed binds
|
|
| 397 | 419 | |
| 398 | - tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn
|
|
| 399 | - Recursive rec_tc closed binds
|
|
| 420 | + tc_sub_group rec_tc closed binds
|
|
| 421 | + = tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds
|
|
| 400 | 422 | |
| 401 | 423 | recursivePatSynErr
|
| 402 | 424 | :: SrcSpan -- ^ The location of the first pattern synonym binding
|
| ... | ... | @@ -406,25 +428,6 @@ recursivePatSynErr |
| 406 | 428 | recursivePatSynErr loc binds
|
| 407 | 429 | = failAt loc $ TcRnRecursivePatternSynonym binds
|
| 408 | 430 | |
| 409 | -tc_single :: forall thing.
|
|
| 410 | - TopLevelFlag -> TcSigFun -> TcPragEnv
|
|
| 411 | - -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
|
|
| 412 | - -> TcM (LHsBinds GhcTc, thing)
|
|
| 413 | -tc_single _top_lvl sig_fn prag_fn
|
|
| 414 | - (L loc (PatSynBind _ psb))
|
|
| 415 | - _ thing_inside
|
|
| 416 | - = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn
|
|
| 417 | - ; thing <- setGblEnv tcg_env thing_inside
|
|
| 418 | - ; return (aux_binds, thing)
|
|
| 419 | - }
|
|
| 420 | - |
|
| 421 | -tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
|
|
| 422 | - = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
|
|
| 423 | - NonRecursive NonRecursive
|
|
| 424 | - closed
|
|
| 425 | - [lbind]
|
|
| 426 | - ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
|
|
| 427 | - ; return (binds1, thing) }
|
|
| 428 | 431 | |
| 429 | 432 | ------------------------
|
| 430 | 433 | type BKey = Int -- Just number off the bindings
|
| ... | ... | @@ -432,18 +435,15 @@ type BKey = Int -- Just number off the bindings |
| 432 | 435 | mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
|
| 433 | 436 | -- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
|
| 434 | 437 | mkEdges sig_fn binds
|
| 435 | - = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
|
|
| 436 | - Just key <- [lookupNameEnv key_map n], no_sig n ]
|
|
| 438 | + = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (lHsBindFreeVars bind)
|
|
| 439 | + , Just key <- [lookupNameEnv key_map n]
|
|
| 440 | + , no_sig n ]
|
|
| 437 | 441 | | (bind, key) <- keyd_binds
|
| 438 | 442 | ]
|
| 439 | 443 | -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
|
| 440 | 444 | -- is still deterministic even if the edges are in nondeterministic order
|
| 441 | 445 | -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
|
| 442 | 446 | where
|
| 443 | - bind_fvs (FunBind { fun_ext = fvs }) = fvs
|
|
| 444 | - bind_fvs (PatBind { pat_ext = fvs }) = fvs
|
|
| 445 | - bind_fvs _ = emptyNameSet
|
|
| 446 | - |
|
| 447 | 447 | no_sig :: Name -> Bool
|
| 448 | 448 | no_sig n = not (hasCompleteSig sig_fn n)
|
| 449 | 449 | |
| ... | ... | @@ -1818,7 +1818,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds |
| 1818 | 1818 | | has_mult_anns_and_pats = False
|
| 1819 | 1819 | -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear]
|
| 1820 | 1820 | |
| 1821 | - | IsGroupClosed _ True <- closed
|
|
| 1821 | + | IsGroupClosed _ _ True <- closed
|
|
| 1822 | 1822 | , not (null binders) = True
|
| 1823 | 1823 | -- The 'True' means that all of the group's
|
| 1824 | 1824 | -- free vars have ClosedTypeId=True; so we can ignore
|
| ... | ... | @@ -1855,46 +1855,51 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds |
| 1855 | 1855 | |
| 1856 | 1856 | isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed
|
| 1857 | 1857 | isClosedBndrGroup type_env binds
|
| 1858 | - = IsGroupClosed fv_env type_closed
|
|
| 1858 | + = IsGroupClosed is_top fv_env type_closed
|
|
| 1859 | 1859 | where
|
| 1860 | - type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
|
|
| 1861 | - |
|
| 1862 | 1860 | fv_env :: NameEnv NameSet
|
| 1863 | - fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
|
|
| 1864 | - |
|
| 1865 | - bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
|
|
| 1866 | - bindFvs (FunBind { fun_id = L _ f
|
|
| 1867 | - , fun_ext = fvs })
|
|
| 1868 | - = let open_fvs = get_open_fvs fvs
|
|
| 1869 | - in [(f, open_fvs)]
|
|
| 1870 | - bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
|
|
| 1871 | - = let open_fvs = get_open_fvs fvs
|
|
| 1872 | - in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat]
|
|
| 1873 | - bindFvs _
|
|
| 1874 | - = []
|
|
| 1875 | - |
|
| 1876 | - get_open_fvs fvs = filterNameSet (not . is_closed) fvs
|
|
| 1877 | - |
|
| 1878 | - is_closed :: Name -> ClosedTypeId
|
|
| 1879 | - is_closed name
|
|
| 1861 | + fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ]
|
|
| 1862 | + |
|
| 1863 | + bind_fvs :: [([Name],NameSet)]
|
|
| 1864 | + bind_fvs = map (get_bind_fvs . unLoc) binds
|
|
| 1865 | + |
|
| 1866 | + get_bind_fvs :: HsBindLR GhcRn GhcRn -> ([Name], NameSet)
|
|
| 1867 | + get_bind_fvs (FunBind { fun_id = L _ f, fun_ext = fvs })
|
|
| 1868 | + = ([f],fvs)
|
|
| 1869 | + get_bind_fvs (PatBind { pat_lhs = pat, pat_ext = fvs })
|
|
| 1870 | + = (collectPatBinders CollNoDictBinders pat, fvs)
|
|
| 1871 | + get_bind_fvs _ = ([], emptyNameSet)
|
|
| 1872 | + |
|
| 1873 | + all_bndrs = concatMap fst bind_fvs
|
|
| 1874 | + all_fvs = foldr (unionNameSet . snd) emptyNameSet bind_fvs
|
|
| 1875 | + `delListFromNameSet` all_bndrs
|
|
| 1876 | + -- all_fvs does not include the binders of this group
|
|
| 1877 | + |
|
| 1878 | + is_top | nameSetAll id_is_top all_fvs = TopLevel
|
|
| 1879 | + | otherwise = NotTopLevel
|
|
| 1880 | + |
|
| 1881 | + id_is_top :: Name -> Bool
|
|
| 1882 | + id_is_top name
|
|
| 1880 | 1883 | | Just thing <- lookupNameEnv type_env name
|
| 1881 | 1884 | = case thing of
|
| 1882 | - AGlobal {} -> True
|
|
| 1883 | - ATcId { tct_info = ClosedLet } -> True
|
|
| 1884 | - _ -> False
|
|
| 1885 | + AGlobal {} -> True
|
|
| 1886 | + ATcId { tct_info = LetBound { lb_top = top } } -> isTopLevel top
|
|
| 1887 | + _ -> False
|
|
| 1885 | 1888 | |
| 1886 | - | otherwise
|
|
| 1887 | - = True -- The free-var set for a top level binding mentions
|
|
| 1889 | + | otherwise -- Imported Ids
|
|
| 1890 | + = True
|
|
| 1888 | 1891 | |
| 1892 | + ---------------------
|
|
| 1893 | + type_closed :: ClosedTypeId
|
|
| 1894 | + type_closed = nameSetAll is_closed_type_id all_fvs
|
|
| 1889 | 1895 | |
| 1890 | 1896 | is_closed_type_id :: Name -> Bool
|
| 1891 | - -- We're already removed Global and ClosedLet Ids
|
|
| 1892 | 1897 | is_closed_type_id name
|
| 1893 | 1898 | | Just thing <- lookupNameEnv type_env name
|
| 1894 | 1899 | = case thing of
|
| 1895 | - ATcId { tct_info = NonClosedLet _ cl } -> cl
|
|
| 1896 | - ATcId { tct_info = NotLetBound } -> False
|
|
| 1897 | - ATyVar {} -> False
|
|
| 1900 | + AGlobal {} -> True
|
|
| 1901 | + ATcId { tct_info = info } -> lb_closed info
|
|
| 1902 | + ATyVar {} -> False
|
|
| 1898 | 1903 | -- In-scope type variables are not closed!
|
| 1899 | 1904 | _ -> pprPanic "is_closed_id" (ppr name)
|
| 1900 | 1905 | |
| ... | ... | @@ -1904,6 +1909,23 @@ isClosedBndrGroup type_env binds |
| 1904 | 1909 | -- These won't be in the local type env.
|
| 1905 | 1910 | -- Ditto class method etc from the current module
|
| 1906 | 1911 | |
| 1912 | +adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed
|
|
| 1913 | +adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids
|
|
| 1914 | + | TopLevel <- top_lvl
|
|
| 1915 | + , all definitely_lifted ids = closed
|
|
| 1916 | + | otherwise = IsGroupClosed NotTopLevel fv_env type_closed
|
|
| 1917 | + where
|
|
| 1918 | + definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id)
|
|
| 1919 | + |
|
| 1920 | +sendToTopLevel :: IsGroupClosed -> TopLevelFlag
|
|
| 1921 | +sendToTopLevel (IsGroupClosed top _ _) = top
|
|
| 1922 | + |
|
| 1923 | +lHsBindFreeVars :: LHsBind GhcRn -> NameSet
|
|
| 1924 | +lHsBindFreeVars (L _ (FunBind { fun_ext = fvs })) = fvs
|
|
| 1925 | +lHsBindFreeVars (L _ (PatBind { pat_ext = fvs })) = fvs
|
|
| 1926 | +lHsBindFreeVars _ = emptyNameSet
|
|
| 1927 | + |
|
| 1928 | + |
|
| 1907 | 1929 | {- Note [Always generalise top-level bindings]
|
| 1908 | 1930 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| 1909 | 1931 | It is very confusing to apply NoGen to a top level binding. Consider (#20123):
|
| ... | ... | @@ -349,31 +349,33 @@ instance Outputable TcTyThing where -- Debugging only |
| 349 | 349 | data IdBindingInfo -- See Note [Meaning of IdBindingInfo]
|
| 350 | 350 | = NotLetBound
|
| 351 | 351 | |
| 352 | - | ClosedLet -- Can definitely be moved to top level
|
|
| 353 | - |
|
| 354 | - | NonClosedLet
|
|
| 355 | - RhsNames -- Free vars of RHS of this Id's binding that are
|
|
| 356 | - -- neither Global nor ClosedLet
|
|
| 357 | - -- Used only to help with error-messages
|
|
| 358 | - -- in `checkClosedInStaticForm`
|
|
| 359 | - |
|
| 360 | - ClosedTypeId -- True <=> This Id has a closed type
|
|
| 361 | - |
|
| 362 | - -- Generalisation of some other binding (f x = e) is OK if
|
|
| 363 | - -- all free vars of `e` are ClosedTypeIds, or ClosedLet
|
|
| 364 | - |
|
| 365 | --- | IsGroupClosed describes a group of mutually-recursive bindings
|
|
| 352 | + | LetBound
|
|
| 353 | + { lb_top :: TopLevelFlag
|
|
| 354 | + -- TopLevel <=> this binding may safely be moved to top level
|
|
| 355 | + -- E.g f x = let ys = reverse [1,2]
|
|
| 356 | + -- zs = reverse ys
|
|
| 357 | + -- in ...
|
|
| 358 | + -- Both ys and zs count as TopLevel
|
|
| 359 | + |
|
| 360 | + , lb_fvs :: RhsNames
|
|
| 361 | + -- Free vars of the RHS that are NotLetBound, or LetBound NotTopLevel
|
|
| 362 | + -- Used to help with error messages in `checkClosedInStaticForm`
|
|
| 363 | + -- Domain = binders of this recursive group
|
|
| 364 | + |
|
| 365 | + , lb_closed :: ClosedTypeId
|
|
| 366 | + -- True <=> this Id has a closed type
|
|
| 367 | + -- Generalisation of some other binding (f x = e) is OK if
|
|
| 368 | + -- all free vars of `e` have lb_clos=ClosedTypeId
|
|
| 369 | + }
|
|
| 370 | + |
|
| 371 | +-- | IsGroupClosed describes a group of
|
|
| 372 | +-- mutually-recursive /renamed/ (but not yet typechecked) bindings
|
|
| 366 | 373 | data IsGroupClosed
|
| 367 | 374 | = IsGroupClosed
|
| 368 | - (NameEnv RhsNames) -- Free var info for the RHS of each binding in the group
|
|
| 375 | + TopLevelFlag -- TopLevel <=> all free vars are themselves TopLevel
|
|
| 376 | + (NameEnv RhsNames) -- Frees for the RHS of each binding in the group
|
|
| 369 | 377 | -- (includes free vars of RHS bound in the same group)
|
| 370 | - -- Used only to help with error-messages
|
|
| 371 | - -- in `checkClosedInStaticForm`
|
|
| 372 | - |
|
| 373 | - ClosedTypeId -- True <=> all the free vars of the group are
|
|
| 374 | - -- imported or ClosedLet or
|
|
| 375 | - -- NonClosedLet with ClosedTypeId=True.
|
|
| 376 | - -- In particular, no tyvars, no NotLetBound
|
|
| 378 | + ClosedTypeId -- True <=> all the free vars of the group have closed types
|
|
| 377 | 379 | |
| 378 | 380 | type RhsNames = NameSet -- Names of variables, mentioned on the RHS of
|
| 379 | 381 | -- a definition, that are not Global or ClosedLet
|
| ... | ... | @@ -520,9 +522,9 @@ in the type environment. |
| 520 | 522 | |
| 521 | 523 | instance Outputable IdBindingInfo where
|
| 522 | 524 | ppr NotLetBound = text "NotLetBound"
|
| 523 | - ppr ClosedLet = text "TopLevelLet"
|
|
| 524 | - ppr (NonClosedLet fvs closed_type) =
|
|
| 525 | - text "TopLevelLet" <+> ppr fvs <+> ppr closed_type
|
|
| 525 | + ppr (LetBound { lb_top = top_lvl, lb_fvs = fvs, lb_closed = cls })
|
|
| 526 | + = text "LetBound" <> braces (sep [ ppr top_lvl, text "closed-type=" <+> ppr cls
|
|
| 527 | + , ppr fvs ])
|
|
| 526 | 528 | |
| 527 | 529 | --------------
|
| 528 | 530 | pprTcTyThingCategory :: TcTyThing -> SDoc
|
| ... | ... | @@ -675,12 +675,15 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a |
| 675 | 675 | tcExtendRecIds pairs thing_inside
|
| 676 | 676 | = tc_extend_local_env NotTopLevel
|
| 677 | 677 | [ (name, ATcId { tct_id = let_id
|
| 678 | - , tct_info = NonClosedLet emptyNameSet False })
|
|
| 678 | + , tct_info = LetBound { lb_top = NotTopLevel
|
|
| 679 | + , lb_fvs = emptyNameSet
|
|
| 680 | + , lb_closed = False } })
|
|
| 679 | 681 | | (name, let_id) <- pairs ] $
|
| 680 | 682 | thing_inside
|
| 681 | 683 | |
| 682 | 684 | tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
|
| 683 | 685 | -- Used for binding the Ids that have a complete user type signature
|
| 686 | +-- within a single recursive group.
|
|
| 684 | 687 | -- Does not extend the TcBinderStack
|
| 685 | 688 | tcExtendSigIds top_lvl sig_ids thing_inside
|
| 686 | 689 | = tc_extend_local_env top_lvl
|
| ... | ... | @@ -688,16 +691,19 @@ tcExtendSigIds top_lvl sig_ids thing_inside |
| 688 | 691 | , tct_info = info })
|
| 689 | 692 | | id <- sig_ids
|
| 690 | 693 | , let closed = isTypeClosedLetBndr id
|
| 691 | - info = NonClosedLet emptyNameSet closed ]
|
|
| 694 | + info = LetBound { lb_top = NotTopLevel
|
|
| 695 | + , lb_fvs = emptyNameSet
|
|
| 696 | + , lb_closed = closed } ]
|
|
| 692 | 697 | thing_inside
|
| 693 | 698 | |
| 694 | 699 | |
| 695 | 700 | tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
|
| 696 | - -> [Scaled TcId] -> TcM a -> TcM a
|
|
| 701 | + -> [Scaled TcId] -> TcM a
|
|
| 702 | + -> TcM a
|
|
| 697 | 703 | -- Used for both top-level value bindings and nested let/where-bindings
|
| 698 | 704 | -- Used for a single NonRec or a single Rec
|
| 699 | 705 | -- Adds to the TcBinderStack too
|
| 700 | -tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
|
|
| 706 | +tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_top fv_env _)
|
|
| 701 | 707 | ids thing_inside
|
| 702 | 708 | = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $
|
| 703 | 709 | tc_extend_local_env top_lvl
|
| ... | ... | @@ -706,30 +712,15 @@ tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) |
| 706 | 712 | | Scaled _ id <- ids ] $
|
| 707 | 713 | foldr check_usage thing_inside scaled_names
|
| 708 | 714 | where
|
| 709 | - closed_let = all can_float_to_top ids
|
|
| 710 | - can_float_to_top (Scaled _ id)
|
|
| 711 | - = noFreeVarsOfType id_ty
|
|
| 712 | - && definitelyLiftedType id_ty
|
|
| 713 | - && case lookupNameEnv fvs (idName id) of
|
|
| 714 | - Nothing -> True
|
|
| 715 | - Just env -> isEmptyNameSet env
|
|
| 716 | - where
|
|
| 717 | - id_ty = idType id
|
|
| 718 | - |
|
| 719 | 715 | mk_tct_info id
|
| 720 | - | closed_let = ClosedLet
|
|
| 721 | - | otherwise = NonClosedLet rhs_fvs type_closed
|
|
| 722 | - where
|
|
| 723 | - name = idName id
|
|
| 724 | - rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
|
|
| 725 | - type_closed = isTypeClosedLetBndr id &&
|
|
| 726 | - (fv_type_closed || hasCompleteSig sig_fn name)
|
|
| 716 | + = LetBound { lb_top = group_top
|
|
| 717 | + , lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet
|
|
| 718 | + , lb_closed = isTypeClosedLetBndr id }
|
|
| 727 | 719 | |
| 728 | 720 | scaled_names = [Scaled p (idName id) | Scaled p id <- ids ]
|
| 729 | 721 | |
| 730 | 722 | check_usage :: Scaled Name -> TcM a -> TcM a
|
| 731 | - check_usage (Scaled p id) thing_inside = do
|
|
| 732 | - tcCheckUsage id p thing_inside
|
|
| 723 | + check_usage (Scaled p id) thing_inside = tcCheckUsage id p thing_inside
|
|
| 733 | 724 | |
| 734 | 725 | tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
|
| 735 | 726 | -- For lambda-bound and case-bound Ids
|
| ... | ... | @@ -679,13 +679,11 @@ zonkLocalBinds (EmptyLocalBinds x) |
| 679 | 679 | zonkLocalBinds (HsValBinds _ (ValBinds {}))
|
| 680 | 680 | = panic "zonkLocalBinds" -- Not in typechecker output
|
| 681 | 681 | |
| 682 | -zonkLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
|
|
| 683 | - = do { new_binds <- traverse go binds
|
|
| 684 | - ; return (HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
|
|
| 682 | +zonkLocalBinds (HsValBinds x (XValBindsLR (HsVBG binds sigs)))
|
|
| 683 | + = do { new_binds <- mapM go binds
|
|
| 684 | + ; return (HsValBinds x (XValBindsLR (HsVBG new_binds sigs))) }
|
|
| 685 | 685 | where
|
| 686 | - go (r,b)
|
|
| 687 | - = do { b' <- zonkRecMonoBinds b
|
|
| 688 | - ; return (r,b') }
|
|
| 686 | + go (r,b,s) = do { b' <- zonkRecMonoBinds b; return (r,b',s) }
|
|
| 689 | 687 | |
| 690 | 688 | zonkLocalBinds (HsIPBinds x (IPBinds dict_binds binds )) = do
|
| 691 | 689 | new_binds <- noBinders $ mapM (wrapLocZonkMA zonk_ip_bind) binds
|