[Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Tackling extra parser allocations stats fail #2
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Dec 17 11:18:37 UTC 2023
Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC
Commits:
37ac8434 by Alan Zimmerman at 2023-12-17T11:18:15+00:00
EPA: Tackling extra parser allocations stats fail #2
Adding `seq` to various Parser.y helper functions
- - - - -
1 changed file:
- compiler/GHC/Parser.y
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4100,32 +4100,32 @@ sL0 = L noSrcSpan -- #define L0 L noSrcSpan
{-# INLINE sL1 #-}
sL1 :: HasLoc a => a -> b -> Located b
-sL1 x = sL (getHasLoc x) -- #define sL1 sL (getLoc $1)
+sL1 x = x `seq` sL (getHasLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1a #-}
sL1a :: (HasLoc a, HasAnnotation t) => a -> b -> GenLocated t b
-sL1a x = sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1)
+sL1a x = x `seq` sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1n #-}
sL1n :: HasLoc a => a -> b -> LocatedN b
-sL1n x = L (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1)
+sL1n x = x `seq` L (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sLL #-}
sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c
-sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
+sLL x y = x `seq` y `seq` sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLa #-}
sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c
-sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
+sLLa x y = x `seq` y `seq` sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLl #-}
sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c
-sLLl x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
+sLLl x y = x `seq` y `seq` sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLAsl #-}
sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c
sLLAsl [] = sL1
-sLLAsl (x:_) = sLL x
+sLLAsl (x:_) = x `seq` sLL x
{- Note [Adding location info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -4244,35 +4244,35 @@ in GHC.Parser.Annotation
-- |Construct an AddEpAnn from the annotation keyword and the location
-- of the keyword itself
mj :: AnnKeywordId -> Located e -> AddEpAnn
-mj a l = AddEpAnn a (srcSpan2e $ gl l)
+mj a l = a `seq` l `seq` AddEpAnn a (srcSpan2e $ gl l)
mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn
-mjN a l = AddEpAnn a (srcSpan2e $ glA l)
+mjN a l = a `seq` l `seq` AddEpAnn a (srcSpan2e $ glA l)
-- |Construct an AddEpAnn from the annotation keyword and the location
-- of the keyword itself, provided the span is not zero width
mz :: AnnKeywordId -> Located e -> [AddEpAnn]
-mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]
+mz a l = a `seq` l `seq` if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]
msemi :: Located e -> [TrailingAnn]
-msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]
+msemi l = l `seq` if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]
msemiA :: Located e -> [AddEpAnn]
-msemiA l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn AnnSemi (srcSpan2e $ gl l)]
+msemiA l = l `seq` if isZeroWidthSpan (gl l) then [] else [AddEpAnn AnnSemi (srcSpan2e $ gl l)]
msemim :: Located e -> Maybe EpaLocation
-msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)
+msemim l = l `seq` if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)
-- |Construct an AddEpAnn from the annotation keyword and the Located Token. If
-- the token has a unicode equivalent and this has been used, provide the
-- unicode variant of the annotation.
mu :: AnnKeywordId -> Located Token -> AddEpAnn
-mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l)
+mu a lt@(L l t) = a `seq` lt `seq` AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l)
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
-toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
+toUnicodeAnn a t = a `seq` t `seq` if isUnicode t then unicodeAnn a else a
toUnicode :: Located Token -> IsUnicodeSyntax
toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax
@@ -4286,19 +4286,19 @@ glA :: HasLoc a => a -> SrcSpan
glA = getHasLoc
glR :: HasLoc a => a -> Anchor
-glR la = EpaSpan (getHasLoc la)
+glR la = la `seq` EpaSpan (getHasLoc la)
glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor
-glEE x y = spanAsAnchor $ comb2 x y
+glEE x y = x `seq` y `seq` spanAsAnchor $ comb2 x y
glRM :: Located a -> Maybe Anchor
-glRM (L l _) = Just $ spanAsAnchor l
+glRM (L l _) = l `seq` Just $ spanAsAnchor l
glAA :: HasLoc a => a -> EpaLocation
glAA = srcSpan2e . getHasLoc
n2l :: LocatedN a -> LocatedA a
-n2l (L la a) = L (l2l la) a
+n2l (L la a) = la `seq` a `seq` L (l2l la) a
-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.
acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)
@@ -4314,12 +4314,12 @@ 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 (l `seq` 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 (l `seq` locA l)
return $ reLoc (a l cs)
ams1 :: MonadP m => Located a -> b -> m (LocatedA b)
@@ -4334,7 +4334,7 @@ amsA' (L l a) = do
amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)
amsA (L l a) bs = do
- !cs <- getCommentsFor (locA l)
+ !cs <- getCommentsFor (l `seq` locA l)
return (L (addAnnsA l bs cs) a)
amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)
@@ -4349,24 +4349,24 @@ amsr (L l a) an = do
-- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> AddEpAnn
-mo ll = mj AnnOpen ll
-mc ll = mj AnnClose ll
+mo ll = ll `seq` mj AnnOpen ll
+mc ll = ll `seq` mj AnnClose ll
moc,mcc :: Located Token -> AddEpAnn
-moc ll = mj AnnOpenC ll
-mcc ll = mj AnnCloseC ll
+moc ll = ll `seq` mj AnnOpenC ll
+mcc ll = ll `seq` mj AnnCloseC ll
mop,mcp :: Located Token -> AddEpAnn
-mop ll = mj AnnOpenP ll
-mcp ll = mj AnnCloseP ll
+mop ll = ll `seq` mj AnnOpenP ll
+mcp ll = ll `seq` mj AnnCloseP ll
moh,mch :: Located Token -> AddEpAnn
-moh ll = mj AnnOpenPH ll
-mch ll = mj AnnClosePH ll
+moh ll = ll `seq` mj AnnOpenPH ll
+mch ll = ll `seq` mj AnnClosePH ll
mos,mcs :: Located Token -> AddEpAnn
-mos ll = mj AnnOpenS ll
-mcs ll = mj AnnCloseS ll
+mos ll = ll `seq` mj AnnOpenS ll
+mcs ll = ll `seq` mj AnnCloseS ll
-- | Parse a Haskell module with Haddock comments. This is done in two steps:
--
@@ -4399,7 +4399,7 @@ commentsA loc cs = EpAnn (EpaSpan loc) noAnn cs
-- between top level declarations.
commentsPA :: (NoAnn ann) => LocatedAn ann a -> P (LocatedAn ann a)
commentsPA la@(L l a) = do
- cs <- getPriorCommentsFor (getLocA la)
+ !cs <- getPriorCommentsFor (getLocA la)
return (L (addCommentsToEpAnn l cs) a)
hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
@@ -4418,15 +4418,15 @@ listAsAnchorM (L l _:_) =
_ -> Nothing
epTok :: Located Token -> EpToken tok
-epTok (L l _) = EpTok (EpaSpan l)
+epTok (L l _) = l `seq` EpTok (EpaSpan l)
epUniTok :: Located Token -> EpUniToken tok utok
-epUniTok t@(L l _) = EpUniTok (EpaSpan l) u
+epUniTok t@(L l _) = t `seq` l `seq` EpUniTok (EpaSpan l) u
where
u = if isUnicode t then UnicodeSyntax else NormalSyntax
epExplicitBraces :: Located Token -> Located Token -> EpLayout
-epExplicitBraces t1 t2 = EpExplicitBraces (epTok t1) (epTok t2)
+epExplicitBraces t1 t2 = t1 `seq` t2 `seq` EpExplicitBraces (epTok t1) (epTok t2)
-- -------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37ac8434a4fef69f7678d54d97e9c79dd9d0b2fa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37ac8434a4fef69f7678d54d97e9c79dd9d0b2fa
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/dbc1b321/attachment-0001.html>
More information about the ghc-commits
mailing list