[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Prefer packed representation for CompiledByteCode
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Apr 9 10:31:56 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f8a90f17 by Fendor at 2024-04-09T06:31:41-04:00
Prefer packed representation for CompiledByteCode
As there are many 'CompiledByteCode' objects alive during a GHCi
session, representing its element in a more packed manner improves space
behaviour at a minimal cost.
When running GHCi on the agda codebase, we find around 380 live
'CompiledByteCode' objects. Packing their respective 'UnlinkedByteCode'
can save quite some pointers.
- - - - -
2db51264 by Alan Zimmerman at 2024-04-09T06:31:41-04:00
EPA: Capture all comments in a ClassDecl
Hopefully the final fix needed for #24533
- - - - -
8 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/StgToByteCode.hs
- testsuite/tests/printer/Test24533.hs
- testsuite/tests/printer/Test24533.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -34,6 +34,7 @@ import GHC.Utils.Panic
import GHC.Core.TyCon
import GHC.Data.FastString
+import GHC.Data.FlatBag
import GHC.Data.SizedSeq
import GHC.StgToCmm.Layout ( ArgRep(..) )
@@ -90,7 +91,7 @@ bcoFreeNames bco
assembleBCOs
:: Interp
-> Profile
- -> [ProtoBCO Name]
+ -> FlatBag (ProtoBCO Name)
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
@@ -129,7 +130,7 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
-- top-level string literal bindings] in GHC.StgToByteCode for some discussion
-- about why.
--
-mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
+mallocStrings :: Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
mallocStrings interp ulbcos = do
let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
ptrs <- interpCmd interp (MallocStrings bytestrings)
@@ -170,7 +171,7 @@ assembleOneBCO interp profile pbco = do
-- TODO: the profile should be bundled with the interpreter: the rts ways are
-- fixed for an interpreter
ubco <- assembleBCO (profilePlatform profile) pbco
- [ubco'] <- mallocStrings interp [ubco]
+ UnitFlatBag ubco' <- mallocStrings interp (UnitFlatBag ubco)
return ubco'
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -54,7 +54,7 @@ import Language.Haskell.Syntax.Module.Name (ModuleName)
-- Compiled Byte Code
data CompiledByteCode = CompiledByteCode
- { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings
+ { bc_bcos :: FlatBag UnlinkedBCO -- Bunch of interpretable bindings
, bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls
, bc_ffis :: [FFIInfo] -- ffi blocks we allocated
, bc_strs :: AddrEnv -- malloc'd top-level strings
@@ -66,7 +66,7 @@ newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
deriving (Show, NFData)
instance Outputable CompiledByteCode where
- ppr CompiledByteCode{..} = ppr bc_bcos
+ ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos
-- Not a real NFData instance, because ModBreaks contains some things
-- we can't rnf
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -1,6 +1,6 @@
{-# LANGUAGE UnboxedTuples #-}
module GHC.Data.FlatBag
- ( FlatBag
+ ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag)
, emptyFlatBag
, unitFlatBag
, sizeFlatBag
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -92,6 +92,7 @@ import Control.Monad
import qualified Data.Set as Set
import Data.Char (isSpace)
+import qualified Data.Foldable as Foldable
import Data.IORef
import Data.List (intercalate, isPrefixOf, nub, partition)
import Data.Maybe
@@ -923,7 +924,8 @@ linkSomeBCOs :: Interp
linkSomeBCOs interp le mods = foldr fun do_link mods []
where
- fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)
+ fun CompiledByteCode{..} inner accum =
+ inner (Foldable.toList bc_bcos : accum)
do_link [] = return []
do_link mods = do
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -942,11 +942,10 @@ checkTyVars pp_what equals_or_where tc tparms
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
- chkParens ops cps bvis (L l (HsParTy _ (L lt ty)))
+ chkParens ops cps bvis (L l (HsParTy _ (L lt ty)))
= let
(o,c) = mkParensEpAnn (realSrcSpan $ locA l)
- lcs = epAnnComments l
- lt' = setCommentsEpAnn lt lcs
+ (_,lt') = transferCommentsOnlyA l lt
in
chkParens (o:ops) (c:cps) bvis (L lt' ty)
chkParens ops cps bvis ty = chk ops cps bvis ty
@@ -1053,7 +1052,7 @@ checkTyClHdr :: Bool -- True <=> class header
checkTyClHdr is_cls ty
= goL ty [] [] [] Prefix
where
- goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix
+ goL (L l ty) acc ops cps fix = go l ty acc ops cps fix
-- workaround to define '*' despite StarIsType
go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
@@ -1071,11 +1070,11 @@ checkTyClHdr is_cls ty
rhs = HsValArg noExtField t2
go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
where
- (o,c) = mkParensEpAnn (realSrcSpan l)
+ (o,c) = mkParensEpAnn (realSrcSpan (locA l))
go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg noExtField t2:acc) ops cps fix
go _ (HsAppKindTy at ty ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
- = return (L (noAnnSrcSpan l) (nameRdrName tup_name)
+ = return (L (l2l l) (nameRdrName tup_name)
, map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
where
arity = length ts
@@ -1083,17 +1082,17 @@ checkTyClHdr is_cls ty
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
go l _ _ _ _ _
- = addFatalError $ mkPlainErrorMsgEnvelope l $
+ = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
(PsErrMalformedTyOrClDecl ty)
-- Combine the annotations from the HsParTy and HsStarTy into a
-- new one for the LocatedN RdrName
- newAnns :: SrcSpan -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN
- newAnns l (EpAnn ap (AnnListItem ta) csp) (AnnParen _ o c) =
+ newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN
+ newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (AnnParen _ o c) =
let
- lr = combineSrcSpans (RealSrcSpan (anchor ap) Strict.Nothing) l
+ lr = combineSrcSpans (locA l1) (locA l)
in
- EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) csp
+ EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) (csp0 Semi.<> csp)
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
+import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Name.Env (mkNameEnv)
@@ -119,14 +120,14 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
(BcM_State{..}, proto_bcos) <-
runBc hsc_env this_mod mb_modBreaks $ do
let flattened_binds = concatMap flattenBind (reverse lifted_binds)
- mapM schemeTopBind flattened_binds
+ FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds
when (notNull ffis)
(panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
putDumpFileMaybe logger Opt_D_dump_BCOs
"Proto-BCOs" FormatByteCode
- (vcat (intersperse (char ' ') (map ppr proto_bcos)))
+ (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
(case modBreaks of
=====================================
testsuite/tests/printer/Test24533.hs
=====================================
@@ -7,7 +7,9 @@ instance
) =>
Read (a, b)
-class Foo (a :: Type {- Weird -})
+{- Weird before -}
+class {- Weird0 -} Foo {- Weird1 -} ({- Weird2 -} a {- Weird3 -} :: {- Weird4 -} Type {- Weird5 -}) {- Weird6 -}
+{- Weird after -}
instance Eq Foo where
-- Weird
=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -13,8 +13,8 @@
[]
(Just
((,)
- { Test24533.hs:15:1 }
- { Test24533.hs:14:16-19 })))
+ { Test24533.hs:17:1 }
+ { Test24533.hs:16:16-19 })))
(EpaCommentsBalanced
[(L
(EpaSpan
@@ -276,22 +276,42 @@
(Nothing)))))
,(L
(EpAnn
- (EpaSpan { Test24533.hs:10:1-33 })
+ (EpaSpan { Test24533.hs:11:1-99 })
(AnnListItem
[])
(EpaComments
- []))
+ [(L
+ (EpaSpan
+ { Test24533.hs:10:1-18 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird before -}")
+ { Test24533.hs:8:13 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:7-18 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird0 -}")
+ { Test24533.hs:11:1-5 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:24-35 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird1 -}")
+ { Test24533.hs:11:20-22 }))]))
(TyClD
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { Test24533.hs:10:1-5 }))]
+ [(AddEpAnn AnnClass (EpaSpan { Test24533.hs:11:1-5 }))]
(EpNoLayout)
(NoAnnSortKey))
(Nothing)
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:7-9 })
+ (EpaSpan { Test24533.hs:11:20-22 })
(NameAnnTrailing
[])
(EpaComments
@@ -302,26 +322,47 @@
(NoExtField)
[(L
(EpAnn
- (EpaSpan { Test24533.hs:10:11-33 })
+ (EpaSpan { Test24533.hs:11:37-99 })
(AnnListItem
[])
(EpaComments
[(L
(EpaSpan
- { Test24533.hs:10:22-32 })
+ { Test24533.hs:11:38-49 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird2 -}")
+ { Test24533.hs:11:37 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:87-98 })
(EpaComment
(EpaBlockComment
- "{- Weird -}")
- { Test24533.hs:10:17-20 }))]))
+ "{- Weird5 -}")
+ { Test24533.hs:11:82-85 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:53-64 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird3 -}")
+ { Test24533.hs:11:51 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:69-80 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird4 -}")
+ { Test24533.hs:11:66-67 }))]))
(KindedTyVar
- [(AddEpAnn AnnOpenP (EpaSpan { Test24533.hs:10:11 }))
- ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.hs:10:33 }))
- ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.hs:10:14-15 }))]
+ [(AddEpAnn AnnOpenP (EpaSpan { Test24533.hs:11:37 }))
+ ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.hs:11:99 }))
+ ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.hs:11:66-67 }))]
(HsBndrRequired
(NoExtField))
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:12 })
+ (EpaSpan { Test24533.hs:11:51 })
(NameAnnTrailing
[])
(EpaComments
@@ -330,7 +371,7 @@
{OccName: a}))
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:17-20 })
+ (EpaSpan { Test24533.hs:11:82-85 })
(AnnListItem
[])
(EpaComments
@@ -340,7 +381,7 @@
(NotPromoted)
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:17-20 })
+ (EpaSpan { Test24533.hs:11:82-85 })
(NameAnnTrailing
[])
(EpaComments
@@ -357,17 +398,31 @@
[])))
,(L
(EpAnn
- (EpaSpan { Test24533.hs:(12,1)-(14,19) })
+ (EpaSpan { Test24533.hs:(14,1)-(16,19) })
(AnnListItem
[])
(EpaComments
[(L
(EpaSpan
- { Test24533.hs:13:3-10 })
+ { Test24533.hs:15:3-10 })
(EpaComment
(EpaLineComment
"-- Weird")
- { Test24533.hs:12:17-21 }))]))
+ { Test24533.hs:14:17-21 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:101-112 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird6 -}")
+ { Test24533.hs:11:99 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:12:1-17 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird after -}")
+ { Test24533.hs:11:101-112 }))]))
(InstD
(NoExtField)
(ClsInstD
@@ -375,12 +430,12 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:12:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { Test24533.hs:12:17-21 }))]
+ [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:14:1-8 }))
+ ,(AddEpAnn AnnWhere (EpaSpan { Test24533.hs:14:17-21 }))]
(NoAnnSortKey))
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-15 })
+ (EpaSpan { Test24533.hs:14:10-15 })
(AnnListItem
[])
(EpaComments
@@ -391,7 +446,7 @@
(NoExtField))
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-15 })
+ (EpaSpan { Test24533.hs:14:10-15 })
(AnnListItem
[])
(EpaComments
@@ -400,7 +455,7 @@
(NoExtField)
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-11 })
+ (EpaSpan { Test24533.hs:14:10-11 })
(AnnListItem
[])
(EpaComments
@@ -410,7 +465,7 @@
(NotPromoted)
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-11 })
+ (EpaSpan { Test24533.hs:14:10-11 })
(NameAnnTrailing
[])
(EpaComments
@@ -419,7 +474,7 @@
{OccName: Eq}))))
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:13-15 })
+ (EpaSpan { Test24533.hs:14:13-15 })
(AnnListItem
[])
(EpaComments
@@ -429,7 +484,7 @@
(NotPromoted)
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:13-15 })
+ (EpaSpan { Test24533.hs:14:13-15 })
(NameAnnTrailing
[])
(EpaComments
@@ -439,7 +494,7 @@
{Bag(LocatedA (HsBind GhcPs)):
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-19 })
+ (EpaSpan { Test24533.hs:16:3-19 })
(AnnListItem
[])
(EpaComments
@@ -448,7 +503,7 @@
(NoExtField)
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:7-8 })
+ (EpaSpan { Test24533.hs:16:7-8 })
(NameAnnTrailing
[])
(EpaComments
@@ -459,7 +514,7 @@
(FromSource)
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-19 })
+ (EpaSpan { Test24533.hs:16:3-19 })
(AnnList
(Nothing)
(Nothing)
@@ -470,7 +525,7 @@
[]))
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-19 })
+ (EpaSpan { Test24533.hs:16:3-19 })
(AnnListItem
[])
(EpaComments
@@ -480,7 +535,7 @@
(FunRhs
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:7-8 })
+ (EpaSpan { Test24533.hs:16:7-8 })
(NameAnnTrailing
[])
(EpaComments
@@ -491,7 +546,7 @@
(NoSrcStrict))
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-5 })
+ (EpaSpan { Test24533.hs:16:3-5 })
(AnnListItem
[])
(EpaComments
@@ -500,7 +555,7 @@
[]
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-5 })
+ (EpaSpan { Test24533.hs:16:3-5 })
(NameAnnTrailing
[])
(EpaComments
@@ -512,7 +567,7 @@
[])))
,(L
(EpAnn
- (EpaSpan { Test24533.hs:14:10-12 })
+ (EpaSpan { Test24533.hs:16:10-12 })
(AnnListItem
[])
(EpaComments
@@ -521,7 +576,7 @@
[]
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:10-12 })
+ (EpaSpan { Test24533.hs:16:10-12 })
(NameAnnTrailing
[])
(EpaComments
@@ -536,22 +591,22 @@
[])
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:14-19 })
+ (EpaSpan { Test24533.hs:16:14-19 })
(NoEpAnns)
(EpaComments
[]))
(GRHS
(EpAnn
- (EpaSpan { Test24533.hs:14:14-19 })
+ (EpaSpan { Test24533.hs:16:14-19 })
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { Test24533.hs:14:14 })))
+ (AddEpAnn AnnEqual (EpaSpan { Test24533.hs:16:14 })))
(EpaComments
[]))
[]
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:16-19 })
+ (EpaSpan { Test24533.hs:16:16-19 })
(AnnListItem
[])
(EpaComments
@@ -560,7 +615,7 @@
(NoExtField)
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:16-19 })
+ (EpaSpan { Test24533.hs:16:16-19 })
(NameAnnTrailing
[])
(EpaComments
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5bcbb4d9027438a77a0befd265a269be3b7c4c53...2db51264f9ae91845953563879b1935c408fc1cb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5bcbb4d9027438a77a0befd265a269be3b7c4c53...2db51264f9ae91845953563879b1935c408fc1cb
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/20240409/a65e1b8b/attachment-0001.html>
More information about the ghc-commits
mailing list