Commit b1386942 authored by Alan Zimmerman's avatar Alan Zimmerman
Browse files

TTG for HsBinds and Data instances Plan B

Summary:
- Add the balance of the TTG extensions for hsSyn/HsBinds

- Move all the (now orphan) data instances into hsSyn/HsInstances and
use TTG Data instances Plan B
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances#PLANB

Updates haddock submodule.

Illustrative numbers

Compiling HsInstances before using Plan B.

Max residency ~ 5G
<<ghc: 629,864,691,176 bytes, 5300 GCs,
       321075437/1087762592 avg/max bytes residency (23 samples),
       2953M in use, 0.000 INIT (0.000 elapsed),
       383.511 MUT (384.986 elapsed), 37.426 GC (37.444 elapsed) :ghc>>

Using Plan B

Max residency 1.1G

<<ghc: 78,832,782,968 bytes, 2884 GCs,
       222140352/386470152 avg/max bytes residency (34 samples),
       1062M in use, 0.001 INIT (0.001 elapsed),
       56.612 MUT (62.917 elapsed), 32.974 GC (32.923 elapsed) :ghc>>

Test Plan: ./validate

Reviewers: shayan-najd, goldfire, bgamari

Subscribers: goldfire, thomie, mpickering, carter

Differential Revision: https://phabricator.haskell.org/D4581
parent 5417c689
......@@ -351,6 +351,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
bindTick
......@@ -779,13 +780,14 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
addTickHsLocalBinds (HsValBinds x binds) =
liftM (HsValBinds x)
(addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds) =
liftM HsIPBinds
addTickHsLocalBinds (HsIPBinds x binds) =
liftM (HsIPBinds x)
(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x)
addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x)
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
......@@ -801,16 +803,18 @@ addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
addTickHsIPBinds (IPBinds dictbinds ipbinds) =
liftM2 IPBinds
(mapM (liftL (addTickIPBind)) ipbinds)
(return dictbinds)
(mapM (liftL (addTickIPBind)) ipbinds)
addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind (IPBind nm e) =
liftM2 IPBind
addTickIPBind (IPBind x nm e) =
liftM2 (IPBind x)
(return nm)
(addTickLHsExpr e)
addTickIPBind (XCIPBind x) = return (XCIPBind x)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
......
......@@ -163,7 +163,7 @@ dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
return (force_var, [core_binds]) }
dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_rhs_ty = ty
, pat_ext = NPatBindTc _ ty
, pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
; checkGuardMatches PatBindGuards grhss
......@@ -192,6 +192,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
-----------------------
......@@ -251,6 +252,7 @@ dsAbsBinds dflags tyvars dicts exports
; return (makeCorePair dflags global
(isDefaultMethod prags)
0 (core_wrap (Var local))) }
mk_bind (XABExport _) = panic "dsAbsBinds"
; main_binds <- mapM mk_bind exports
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
......@@ -295,6 +297,7 @@ dsAbsBinds dflags tyvars dicts exports
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
; return ((global', rhs) : fromOL spec_binds) }
mk_bind (XABExport _) = panic "dsAbsBinds"
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
......@@ -342,7 +345,8 @@ dsAbsBinds dflags tyvars dicts exports
mk_export local =
do global <- newSysLocalDs
(exprType (mkLams tyvars (mkLams dicts (Var local))))
return (ABE { abe_poly = global
return (ABE { abe_ext = noExt
, abe_poly = global
, abe_mono = local
, abe_wrap = WpHole
, abe_prags = SpecPrags [] })
......
......@@ -71,10 +71,11 @@ import Control.Monad
-}
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (L _ EmptyLocalBinds) body = return body
dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body
dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
dsLocalBinds (L _ (XHsLocalBindsLR _)) _ = panic "dsLocalBinds"
-------------------------
-- caller sets location
......@@ -85,16 +86,18 @@ dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds ip_binds ev_binds) body
dsIPBinds (IPBinds ev_binds ip_binds) body
= do { ds_binds <- dsTcEvBinds ev_binds
; let inner = mkCoreLets ds_binds body
-- The dict bindings may not be in
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
where
ds_ip_bind (L _ (IPBind ~(Right n) e)) body
ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
ds_ip_bind (L _ (XCIPBind _)) _ = panic "dsIPBinds"
dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
-------------------------
-- caller sets location
......@@ -201,7 +204,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun
; let rhs' = mkOptTickBox tick rhs
; return (bindNonRec fun rhs' body) }
dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
, pat_ext = NPatBindTc _ ty }) body
= -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body
do { rhs <- dsGuarded grhss ty
......
......@@ -193,11 +193,11 @@ hsSigTvBinders binds
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
| TypeSig _ sig <- signature
| TypeSig _ _ sig <- signature
= get_scoped_tvs_from_sig (hswc_body sig)
| ClassOpSig _ _ sig <- signature
| ClassOpSig _ _ _ sig <- signature
= get_scoped_tvs_from_sig sig
| PatSynSig _ sig <- signature
| PatSynSig _ _ sig <- signature
= get_scoped_tvs_from_sig sig
| otherwise
= []
......@@ -602,7 +602,7 @@ repSafety PlayInterruptible = rep2 interruptibleName []
repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity _ prec dir)))
repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLDName
......@@ -613,6 +613,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir)))
; dec <- rep2 rep_fn [prec', name']
; return (loc,dec) }
; mapM do_one names }
repFixD (L _ (XFixitySig _)) = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
......@@ -771,20 +772,21 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sigs = concatMapM rep_sig
rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
rep_sig (L loc (ClassOpSig is_deflt nms ty))
rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm tys ispec))
rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc
rep_sig (L _ (XSig _)) = panic "rep_sig"
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
......@@ -1445,13 +1447,13 @@ repSts other = notHandled "Exotic statement" (ppr other)
-----------------------------------------------------------
repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
repBinds EmptyLocalBinds
repBinds (EmptyLocalBinds _)
= do { core_list <- coreList decQTyConName []
; return ([], core_list) }
repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
repBinds b@(HsIPBinds {}) = notHandled "Implicit parameters" (ppr b)
repBinds (HsValBinds decs)
repBinds (HsValBinds _ decs)
= do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
-- No need to worry about detailed scopes within
-- the binding group, because we are talking Names
......@@ -1463,6 +1465,7 @@ repBinds (HsValBinds decs)
; core_list <- coreList decQTyConName
(de_loc (sort_by_loc prs))
; return (ss, core_list) }
repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are already in the meta-env
......@@ -1521,11 +1524,11 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
; return (srcLocSpan (getSrcLoc v), ans) }
rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
rep_bind (L loc (PatSynBind (PSB { psb_id = syn
, psb_fvs = _fvs
, psb_args = args
, psb_def = pat
, psb_dir = dir })))
rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
, psb_fvs = _fvs
, psb_args = args
, psb_def = pat
, psb_dir = dir })))
= do { syn' <- lookupLBinder syn
; dir' <- repPatSynDir dir
; ss <- mkGenArgSyms args
......@@ -1560,6 +1563,9 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind"
rep_bind (L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR"
repPatSynD :: Core TH.Name
-> Core TH.PatSynArgsQ
-> Core TH.PatSynDirQ
......@@ -1628,7 +1634,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
repLambda (L _ (Match { m_pats = ps
, m_grhss = GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds) } ))
, m_grhss = GRHSs [L _ (GRHS [] e)]
(L _ (EmptyLocalBinds _)) } ))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
......
......@@ -320,6 +320,7 @@ Library
HsLit
PlaceHolder
HsExtension
HsInstances
HsPat
HsSyn
HsTypes
......
......@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds)
; ds' <- cvtLocalDecs (text "a where clause") ds
; returnJustL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
, pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
, pat_ext = noExt
, pat_ticks = ([],[]) } }
cvtDec (TH.FunD nm cls)
......@@ -169,7 +169,7 @@ cvtDec (TH.FunD nm cls)
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
; returnJustL $ Hs.SigD (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.InfixD fx nm)
-- Fixity signatures are allowed for variables, constructors, and types
......@@ -177,7 +177,8 @@ cvtDec (TH.InfixD fx nm)
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameL nm
; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
; returnJustL (Hs.SigD (FixSig noExt
(FixitySig noExt [nm'] (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= cvtPragmaD prag
......@@ -358,15 +359,15 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
; returnJustL $ Hs.SigD $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
; args' <- cvtArgs args
; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat
; returnJustL $ Hs.ValD $ PatSynBind $
PSB nm' placeHolderType args' pat' dir' }
; returnJustL $ Hs.ValD $ PatSynBind noExt $
PSB noExt nm' placeHolderType args' pat' dir' }
where
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
......@@ -384,7 +385,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty
; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
; returnJustL $ Hs.SigD $ PatSynSig noExt [nm'] (mkLHsSigType ty') }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
......@@ -651,7 +652,7 @@ cvtPragmaD (InlineP nm inline rm phases)
, inl_rule = cvtRuleMatch rm
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ InlineSig nm' ip }
; returnJustL $ Hs.SigD $ InlineSig noExt nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm
......@@ -669,12 +670,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
; returnJustL $ Hs.SigD $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty
; returnJustL $ Hs.SigD $
SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
cvtPragmaD (RuleP nm bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
......@@ -711,7 +712,7 @@ cvtPragmaD (CompleteP cls mty)
= do { cls' <- noLoc <$> mapM cNameL cls
; mty' <- traverse tconNameL mty
; returnJustL $ Hs.SigD
$ CompleteMatchSig NoSourceText cls' mty' }
$ CompleteMatchSig noExt NoSourceText cls' mty' }
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
......@@ -747,13 +748,13 @@ cvtRuleBndr (TypedRuleVar n ty)
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs doc ds
| null ds
= return EmptyLocalBinds
= return (EmptyLocalBinds noExt)
| otherwise
= do { ds' <- cvtDecs ds
; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) }
; return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs)) }
cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
......
......@@ -74,7 +74,9 @@ type LHsLocalBinds id = Located (HsLocalBinds id)
-- Bindings in a 'let' expression
-- or a 'where' clause
data HsLocalBindsLR idL idR
= HsValBinds (HsValBindsLR idL idR)
= HsValBinds
(XHsValBinds idL idR)
(HsValBindsLR idL idR)
-- ^ Haskell Value Bindings
-- There should be no pattern synonyms in the HsValBindsLR
......@@ -82,15 +84,24 @@ data HsLocalBindsLR idL idR
-- The parser accepts them, however, leaving the
-- renamer to report them
| HsIPBinds (HsIPBinds idR)
| HsIPBinds
(XHsIPBinds idL idR)
(HsIPBinds idR)
-- ^ Haskell Implicit Parameter Bindings
| EmptyLocalBinds
| EmptyLocalBinds (XEmptyLocalBinds idL idR)
-- ^ Empty Local Bindings
| XHsLocalBindsLR
(XXHsLocalBindsLR idL idR)
type instance XHsValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder
type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR)
-- | Haskell Value Bindings
type HsValBinds id = HsValBindsLR id id
......@@ -116,8 +127,6 @@ data HsValBindsLR idL idR
| XValBindsLR
(XXValBindsLR idL idR)
deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR)
-- ---------------------------------------------------------------------
-- Deal with ValBindsOut
......@@ -126,7 +135,6 @@ data NHsValBindsLR idL
= NValBinds
[(RecFlag, LHsBinds idL)]
[LSig GhcRn]
deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL)
type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
......@@ -212,6 +220,11 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
FunBind {
fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains
-- the locally-bound
-- free variables of this defn.
-- See Note [Bind free vars]
fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
......@@ -230,12 +243,6 @@ data HsBindLR idL idR
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
-- the locally-bound
-- free variables of this defn.
-- See Note [Bind free vars]
fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
}
......@@ -253,10 +260,9 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
| PatBind {
pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars]
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR (LHsExpr idR),
pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
pat_ticks :: ([Tickish Id], [[Tickish Id]])
-- ^ Ticks to put on the rhs, if any, and ticks to put on
-- the bound variables.
......@@ -267,6 +273,7 @@ data HsBindLR idL idR
-- Dictionary binding and suchlike.
-- All VarBinds are introduced by the type checker
| VarBind {
var_ext :: XVarBind idL idR,
var_id :: IdP idL,
var_rhs :: LHsExpr idR, -- ^ Located only for consistency
var_inline :: Bool -- ^ True <=> inline this binding regardless
......@@ -275,6 +282,7 @@ data HsBindLR idL idR
-- | Abstraction Bindings
| AbsBinds { -- Binds abstraction; TRANSLATION
abs_ext :: XAbsBinds idL idR,
abs_tvs :: [TyVar],
abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
......@@ -295,7 +303,9 @@ data HsBindLR idL idR
}
-- | Patterns Synonym Binding
| PatSynBind (PatSynBind idL idR)
| PatSynBind
(XPatSynBind idL idR)
(PatSynBind idL idR)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
-- 'ApiAnnotation.AnnWhere'
......@@ -303,7 +313,26 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
| XHsBindsLR (XXHsBindsLR idL idR)
data NPatBindTc = NPatBindTc {
pat_fvs :: NameSet, -- ^ Free variables
pat_rhs_ty :: Type -- ^ Type of the GRHSs
} deriving Data
type instance XFunBind (GhcPass pL) GhcPs = PlaceHolder
type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables
type instance XPatBind GhcPs (GhcPass pR) = PlaceHolder
type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables
type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc
type instance XVarBind (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XAbsBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XPatSynBind (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
--
......@@ -319,13 +348,18 @@ deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
-- | Abtraction Bindings Export
data ABExport p
= ABE { abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
= ABE { abe_ext :: XABE p
, abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
, abe_mono :: IdP p
, abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
}
deriving instance (DataId p) => Data (ABExport p)
}
| XABExport (XXABExport p)
type instance XABE (GhcPass p) = PlaceHolder
type instance XXABExport (GhcPass p) = PlaceHolder
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
......@@ -336,14 +370,18 @@ deriving instance (DataId p) => Data (ABExport p)
-- | Pattern Synonym binding
data PatSynBind idL idR
= PSB { psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
= PSB { psb_ext :: XPSB idL idR,
psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars]
psb_args :: HsPatSynDetails (Located (IdP idR)),
-- ^ Formal parameter names
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
}
deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR)
}
| XPatSynBind (XXPatSynBind idL idR)
type instance XPSB (GhcPass idL) (GhcPass idR) = PlaceHolder
type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = PlaceHolder
{-
Note [AbsBinds]
......@@ -581,9 +619,10 @@ Specifically,
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
ppr (HsValBinds _ bs) = ppr bs
ppr (HsIPBinds _ bs) = ppr bs
ppr (EmptyLocalBinds _) = empty
ppr (XHsLocalBindsLR x) = ppr x
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
......@@ -640,17 +679,25 @@ pprDeclList :: [SDoc] -> SDoc -- Braces with a space
pprDeclList ds = pprDeeperList vcat ds
------------
emptyLocalBinds :: HsLocalBindsLR a b
emptyLocalBinds = EmptyLocalBinds
isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True
emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds = EmptyLocalBinds noExt
-- AZ:These functions do not seem to be used at all?
isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool
isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds
isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds
isEmptyLocalBindsTc (EmptyLocalBinds _) = True
isEmptyLocalBindsTc (XHsLocalBindsLR _) = True
isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds
isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds
isEmptyLocalBindsPR (EmptyLocalBinds _) = True
isEmptyLocalBindsPR (XHsLocalBindsLR _) = True
eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
eqEmptyLocalBinds EmptyLocalBinds = True
eqEmptyLocalBinds _ = False