[Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Tackling extra parser allocations stats fail
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Dec 17 09:57:25 UTC 2023
Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC
Commits:
70cc5ed9 by Alan Zimmerman at 2023-12-17T09:56:38+00:00
EPA: Tackling extra parser allocations stats fail
Step one: make all getCommentsFor results strict.
- - - - -
2 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1447,7 +1447,7 @@ ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }
{% do { hintExplicitForall $1
; tvbs <- fromSpecTyVarBndrs $2
; let loc = comb2 $1 $>
- ; cs <- getCommentsFor loc
+ ; !cs <- getCommentsFor loc
; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}
| type '=' ktype
{% mkTyFamInstEqn (comb2 $1 $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }
@@ -1584,7 +1584,7 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
| 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1
; tvbs <- fromSpecTyVarBndrs $2
; let loc = comb2 $1 $>
- ; cs <- getCommentsFor loc
+ ; !cs <- getCommentsFor loc
; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))
} }
| context '=>' type {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }
@@ -1825,7 +1825,7 @@ binds :: { Located (HsLocalBinds GhcPs) }
-- May have implicit parameters
-- No type declarations
: decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
- ; cs <- getCommentsFor (gl $1)
+ ; !cs <- getCommentsFor (gl $1)
; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }
| '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc
@@ -2553,7 +2553,7 @@ decl_no_th :: { LHsDecl GhcPs }
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
- ; cs <- getCommentsFor l
+ ; !cs <- getCommentsFor l
; return $! (sL (commentsA l cs) $ ValD noExtField r) } }
| PREFIX_PERCENT atype infixexp opt_sig rhs {% runPV (unECP $3) >>= \ $3 ->
do { let { l = comb2 $3 $> }
@@ -2564,7 +2564,7 @@ decl_no_th :: { LHsDecl GhcPs }
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
- ; cs <- getCommentsFor l
+ ; !cs <- getCommentsFor l
; return $! (sL (commentsA l cs) $ ValD noExtField r) } }
| pattern_synonym_decl { $1 }
@@ -4304,7 +4304,7 @@ n2l (L la a) = L (l2l la) a
acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)
acsFinal a = do
let (L l _) = a emptyComments Nothing
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
csf <- getFinalCommentsFor l
meof <- getEofPos
let ce = case meof of
@@ -4314,37 +4314,37 @@ acsFinal a = do
acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a)
acs l a = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
return (a l cs)
acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a)
acsA l a = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
return $ reLoc (a l cs)
ams1 :: MonadP m => Located a -> b -> m (LocatedA b)
ams1 (L l a) b = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return (L (EpAnn (spanAsAnchor l) noAnn cs) b)
amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a)
amsA' (L l a) = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return (L (EpAnn (spanAsAnchor l) noAnn cs) a)
amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)
amsA (L l a) bs = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
return (L (addAnnsA l bs cs) a)
amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)
amsAl (L l a) loc bs = do
- cs <- getCommentsFor loc
+ !cs <- getCommentsFor loc
return (L (addAnnsA l bs cs) a)
amsr :: MonadP m => Located a -> an -> m (LocatedAn an a)
amsr (L l a) an = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return (L (EpAnn (spanAsAnchor l) an cs) a)
-- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose
@@ -4463,7 +4463,7 @@ addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span))
addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)
addTrailingAnnL (L anns a) ta = do
- cs <- getCommentsFor (locA anns)
+ !cs <- getCommentsFor (locA anns)
let anns' = addTrailingAnnToL ta cs anns
return (L anns' a)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -392,7 +392,7 @@ mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
-- as spliced declaration. See #10945
mkSpliceDecl lexpr@(L loc expr)
| HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do
- cs <- getCommentsFor (locA loc)
+ !cs <- getCommentsFor (locA loc)
return $ L (addCommentsToEpAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)
| HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do
@@ -400,7 +400,7 @@ mkSpliceDecl lexpr@(L loc expr)
return $ L (addCommentsToEpAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)
| otherwise = do
- cs <- getCommentsFor (locA loc)
+ !cs <- getCommentsFor (locA loc)
return $ L (addCommentsToEpAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField
(L loc (HsUntypedSpliceExpr noAnn lexpr))
BareSplice)
@@ -412,7 +412,7 @@ mkRoleAnnotDecl :: SrcSpan
-> P (LRoleAnnotDecl GhcPs)
mkRoleAnnotDecl loc tycon roles anns
= do { roles' <- mapM parse_role roles
- ; cs <- getCommentsFor loc
+ ; !cs <- getCommentsFor loc
; return $ L (EpAnn (spanAsAnchor loc) noAnn cs)
$ RoleAnnotDecl anns tycon roles' }
where
@@ -1677,12 +1677,12 @@ instance DisambECP (HsCmd GhcPs) where
mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $
PsErrOverloadedRecordDotInvalid
mkHsLamPV l lam_variant (L lm m) anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg)
mkHsLetPV l tkLet bs tkIn e = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e)
type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
@@ -1691,11 +1691,11 @@ instance DisambECP (HsCmd GhcPs) where
mkHsOpAppPV l c1 op c2 = do
let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm (AnnList Nothing Nothing Nothing [] []) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2]
mkHsCasePV l c (L lm m) anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg)
@@ -1708,14 +1708,14 @@ instance DisambECP (HsCmd GhcPs) where
mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)
mkHsIfPV l c semi1 a semi2 b anns = do
checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)
mkHsDoPV l Nothing stmts anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo anns stmts)
mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
mkHsParPV l lpar c rpar = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)
mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)
mkHsLitPV (L l a) = cmdFail l (ppr a)
@@ -1762,29 +1762,29 @@ instance DisambECP (HsExpr GhcPs) where
return (L l (hsHoleExpr noAnn))
ecpFromExp' = return
mkHsProjUpdatePV l fields arg isPun anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns
mkHsLetPV l tkLet bs tkIn c = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c)
type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp [] e1 (reLoc op) e2
mkHsCasePV l e (L lm m) anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg)
mkHsLamPV l lam_variant (L lm m) anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)
checkLamMatchGroup l lam_variant mg
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg)
type FunArg (HsExpr GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l@(EpAnn anc an csIn) e1 e2 = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
checkExpBlockArguments e1
checkExpBlockArguments e2
return $ L (EpAnn anc an (csIn Semi.<> cs)) (HsApp noExtField e1 e2)
@@ -1793,42 +1793,42 @@ instance DisambECP (HsExpr GhcPs) where
return $ L l (HsAppType at e (mkHsWildCardBndrs t))
mkHsIfPV l c semi1 a semi2 b anns = do
checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)
mkHsDoPV l mod stmts anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo anns (DoExpr mod) stmts)
mkHsParPV l lpar e rpar = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)
mkHsVarPV v@(L l@(EpAnn anc _ _) _) = do
- cs <- getCommentsFor (getHasLoc l)
+ !cs <- getCommentsFor (getHasLoc l)
return $ L (EpAnn anc noAnn cs) (HsVar noExtField v)
mkHsLitPV (L l a) = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a)
mkHsOverLitPV (L (EpAnn l an csIn) a) = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a)
mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (hsHoleExpr noAnn)
mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig))
mkHsExplicitListPV l xs anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs)
mkHsSplicePV (L l a) = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a)
mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns
checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)
mkHsNegAppPV l a anns = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr)
mkHsSectionR_PV l op e = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e)
mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)
>> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
@@ -1861,7 +1861,7 @@ instance DisambECP (PatBuilder GhcPs) where
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 []
mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant)
@@ -1871,7 +1871,7 @@ instance DisambECP (PatBuilder GhcPs) where
superFunArg m = m
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
mkHsAppTypePV l p at t = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs
return $ L l (PatBuilderAppType p at (mkHsTyPat anns t))
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
@@ -1880,7 +1880,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
checkUnboxedLitPat lit
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a))
mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)
mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (PatBuilderPat (WildPat noExtField))
@@ -1889,41 +1889,41 @@ instance DisambECP (PatBuilder GhcPs) where
return $ L l (PatBuilderPat (SigPat anns p (mkHsPatSigType noAnn sig)))
mkHsExplicitListPV l xs anns = do
ps <- traverse checkLPat xs
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps)))
mkHsSplicePV (L l sp) = do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp))
mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do
let (fs, ps) = partitionEithers fbinds
if not (null ps)
then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
else do
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
r <- mkPatRec a (mk_rec_fields fs ddLoc) anns
checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)
mkHsNegAppPV l (L lp p) anns = do
lit <- case p of
PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)
_ -> patFail l $ PsErrInPat p PEIP_NegApp
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns))
mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))
mkHsViewPatPV l a b anns = do
p <- checkLPat b
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat anns a p))
mkHsAsPatPV l v at e = do
p <- checkLPat e
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (AsPat at v p))
mkHsLazyPatPV l e a = do
p <- checkLPat e
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p))
mkHsBangPatPV l e an = do
p <- checkLPat e
- cs <- getCommentsFor l
+ !cs <- getCommentsFor l
let pb = BangPat an p
hintBangPat l pb
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb)
@@ -2834,8 +2834,6 @@ data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec
-> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp warning anns (L l specname) subs = do
- -- cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments
- -- let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
@@ -3108,7 +3106,7 @@ mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)
-- Tuple
mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity)
where
toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs
@@ -3123,7 +3121,7 @@ mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) a
[AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] ->
AnnExplicitSum o barsp barsa c
_ -> panic "mkSumOrTupleExpr"
- cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (locA l)
return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e)
mkSumOrTupleExpr l Boxed a at Sum{} _ =
addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70cc5ed94e646da996a4375c942a72bc8a8f5d60
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70cc5ed94e646da996a4375c942a72bc8a8f5d60
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231217/72302941/attachment-0001.html>
More information about the ghc-commits
mailing list