[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Avoid UArray when indexing is not required
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Apr 8 17:07:10 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
88cb3e10 by Fendor at 2024-04-08T09:03:34-04:00
Avoid UArray when indexing is not required
`UnlinkedBCO`'s can occur many times in the heap. Each `UnlinkedBCO`
references two `UArray`'s but never indexes them. They are only needed
to encode the elements into a `ByteArray#`. The three words for
the lower bound, upper bound and number of elements are essentially
unused, thus we replace `UArray` with a wrapper around `ByteArray#`.
This saves us up to three words for each `UnlinkedBCO`.
Further, to avoid re-allocating these words for `ResolvedBCO`, we repeat
the procedure for `ResolvedBCO` and add custom `Binary` and `Show` instances.
For example, agda's repl session has around 360_000 UnlinkedBCO's,
so avoiding these three words is already saving us around 8MB residency.
- - - - -
f2cc1107 by Fendor at 2024-04-08T09:04:11-04:00
Never UNPACK `FastMutInt` for counting z-encoded `FastString`s
In `FastStringTable`, we count the number of z-encoded FastStrings
that exist in a GHC session.
We used to UNPACK the counters to not waste memory, but live retainer
analysis showed that we allocate a lot of `FastMutInt`s, retained by
`mkFastZString`.
We lazily compute the `FastZString`, only incrementing the counter when the `FastZString` is
forced.
The function `mkFastStringWith` calls `mkZFastString` and boxes the
`FastMutInt`, leading to the following core:
mkFastStringWith
= \ mk_fs _ ->
= case stringTable of
{ FastStringTable _ n_zencs segments# _ ->
...
case ((mk_fs (I# ...) (FastMutInt n_zencs))
`cast` <Co:2> :: ...)
...
Marking this field as `NOUNPACK` avoids this reboxing, eliminating the
allocation of a fresh `FastMutInt` on every `FastString` allocation.
- - - - -
f16c3f7d by Matthew Pickering at 2024-04-08T13:06:45-04:00
Force in_multi to avoid retaining entire hsc_env
- - - - -
f5d9ed32 by Fendor at 2024-04-08T13:06:45-04:00
Eliminate name thunk in declaration fingerprinting
Thunk analysis showed that we have about 100_000 thunks (in agda and
`-fwrite-simplified-core`) pointing to the name of the name decl.
Forcing this thunk fixes this issue.
The thunk created here is retained by the thunk created by forkM, it is
better to eagerly force this because the result (a `Name`) is already
retained indirectly via the `IfaceDecl`.
- - - - -
9688e341 by Alan Zimmerman at 2024-04-08T13:06:45-04:00
EPA: Use EpaLocation in WarningTxt
This allows us to use an EpDelta if needed when using makeDeltaAst.
- - - - -
91341c46 by Alan Zimmerman at 2024-04-08T13:06:45-04:00
EPA: Move DeltaPos and EpaLocation' into GHC.Types.SrcLoc
This allows us to use a NoCommentsLocation for the possibly trailing
comma location in a StringLiteral.
This in turn allows us to correctly roundtrip via makeDeltaAst.
- - - - -
17 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Types/SourceText.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/GHC/Unit/Module/Warnings.hs
- ghc/GHCi/UI.hs
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/ResolvedBCO.hs
- testsuite/tests/ghci/should_run/BinaryArray.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -213,8 +213,8 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
(text "bytecode instruction count mismatch")
let asm_insns = ssElts final_insns
- insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
- bitmap_arr = mkBitmapArray bsize bitmap
+ !insns_arr = mkBCOByteArray $ Array.listArray (0 :: Int, fromIntegral n_insns - 1) asm_insns
+ !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap
ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSizedSeq final_lits) (fromSizedSeq final_ptrs)
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
@@ -224,7 +224,7 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
return ul_bco
-mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
+mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
-- Here the return type must be an array of Words, not StgWords,
-- because the underlying ByteArray# will end up as a component
-- of a BCO object.
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -60,10 +60,13 @@ linkBCO interp le bco_ix
(UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
-- fromIntegral Word -> Word64 should be a no op if Word is Word64
-- otherwise it will result in a cast to longlong on 32bit systems.
- lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (elemsFlatBag lits0)
+ (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp le) (elemsFlatBag lits0)
ptrs <- mapM (resolvePtr interp le bco_ix) (elemsFlatBag ptrs0)
- return (ResolvedBCO isLittleEndian arity insns bitmap
- (listArray (0, fromIntegral (sizeFlatBag lits0)-1) lits)
+ let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
+ return (ResolvedBCO isLittleEndian arity
+ insns
+ bitmap
+ (mkBCOByteArray lits')
(addListToSS emptySS ptrs))
lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -1,6 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedNewtypes #-}
--
-- (c) The University of Glasgow 2002-2006
--
@@ -8,6 +10,7 @@
-- | Bytecode assembler types
module GHC.ByteCode.Types
( CompiledByteCode(..), seqCompiledByteCode
+ , BCOByteArray(..), mkBCOByteArray
, FFIInfo(..)
, RegBitmap(..)
, NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo
@@ -34,10 +37,10 @@ import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.FFI
import Control.DeepSeq
+import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray )
import Foreign
import Data.Array
-import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
@@ -153,8 +156,8 @@ data UnlinkedBCO
= UnlinkedBCO {
unlinkedBCOName :: !Name,
unlinkedBCOArity :: {-# UNPACK #-} !Int,
- unlinkedBCOInstrs :: !(UArray Int Word16), -- insns
- unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap
+ unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns
+ unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap
unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs
unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs
}
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -304,9 +304,18 @@ and updates to multiple buckets with low synchronization overhead.
See Note [Updating the FastString table] on how it's updated.
-}
data FastStringTable = FastStringTable
- {-# UNPACK #-} !FastMutInt -- the unique ID counter shared with all buckets
- {-# UNPACK #-} !FastMutInt -- number of computed z-encodings for all buckets
- (Array# (IORef FastStringTableSegment)) -- concurrent segments
+ {-# UNPACK #-} !FastMutInt
+ -- ^ The unique ID counter shared with all buckets
+ --
+ -- We unpack the 'FastMutInt' counter as it is always consumed strictly.
+ {-# NOUNPACK #-} !FastMutInt
+ -- ^ Number of computed z-encodings for all buckets.
+ --
+ -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk
+ -- in 'mkFastStringWith' and needs to be boxed any way.
+ -- If this is unpacked, then we box this single 'FastMutInt' once for each
+ -- allocated FastString.
+ (Array# (IORef FastStringTableSegment)) -- ^ concurrent segments
data FastStringTableSegment = FastStringTableSegment
{-# UNPACK #-} !(MVar ()) -- the lock for write in each segment
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -595,8 +595,8 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt mb_cat src strs -> WarningTxt (noLoc . fromWarningCategory <$> mb_cat) src (noLoc <$> map fromIfaceStringLiteralWithNames strs)
- IfDeprecatedTxt src strs -> DeprecatedTxt src (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -956,7 +956,9 @@ tc_iface_decl_fingerprint :: Bool -- Don't load pragmas into
tc_iface_decl_fingerprint ignore_prags (_version, decl)
= do { -- Populate the name cache with final versions of all
-- the names associated with the decl
- let main_name = ifName decl
+ let !main_name = ifName decl
+ -- Force this field access, as `main_name` thunk will otherwise
+ -- be retained in the thunk created by `forkM`.
-- Typecheck the thing, lazily
-- NB. Firstly, the laziness is there in case we never need the
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1964,9 +1964,9 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
(AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
| {- empty -} { Nothing }
-warning_category :: { Maybe (Located InWarningCategory) }
- : 'in' STRING { Just (sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2)
- (sL1 $2 $ mkWarningCategory (getSTRING $2))) }
+warning_category :: { Maybe (LocatedE InWarningCategory) }
+ : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2)
+ (reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) }
| {- empty -} { Nothing }
warnings :: { OrdList (LWarnDecl GhcPs) }
@@ -4131,8 +4131,8 @@ getSCC lt = do let s = getSTRING lt
then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC
else return s
-stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs)
-stringLiteralToHsDocWst = lexStringLiteral parseIdentifier
+stringLiteralToHsDocWst :: Located StringLiteral -> LocatedE (WithHsDocIdentifiers StringLiteral GhcPs)
+stringLiteralToHsDocWst sl = reLoc $ lexStringLiteral parseIdentifier sl
-- Utilities for combining source spans
comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan
@@ -4560,7 +4560,7 @@ addTrailingCommaN (L anns a) span = do
addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral
addTrailingCommaS (L l sl) span
- = L (widenSpan l [AddEpAnn AnnComma span]) (sl { sl_tc = Just (epaLocationRealSrcSpan span) })
+ = L (widenSpan l [AddEpAnn AnnComma span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) })
-- -------------------------------------
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -454,27 +454,8 @@ instance Outputable EpaComment where
-- annotation.
data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
--- | The anchor for an @'AnnKeywordId'@. The Parser inserts the
--- @'EpaSpan'@ variant, giving the exact location of the original item
--- in the parsed source. This can be replaced by the @'EpaDelta'@
--- version, to provide a position for the item relative to the end of
--- the previous item in the source. This is useful when editing an
--- AST prior to exact printing the changed one. The list of comments
--- in the @'EpaDelta'@ variant captures any comments between the prior
--- output and the thing being marked here, since we cannot otherwise
--- sort the relative order.
-
-data EpaLocation' a = EpaSpan !SrcSpan
- | EpaDelta !DeltaPos !a
- deriving (Data,Eq,Show)
-
type EpaLocation = EpaLocation' [LEpaComment]
-type NoCommentsLocation = EpaLocation' NoComments
-
-data NoComments = NoComments
- deriving (Data,Eq,Ord,Show)
-
epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation
epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss
epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments
@@ -492,34 +473,6 @@ data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation
instance Outputable a => Outputable (GenLocated TokenLocation a) where
ppr (L _ x) = ppr x
--- | Spacing between output items when exact printing. It captures
--- the spacing from the current print position on the page to the
--- position required for the thing about to be printed. This is
--- either on the same line in which case is is simply the number of
--- spaces to emit, or it is some number of lines down, with a given
--- column offset. The exact printing algorithm keeps track of the
--- column offset pertaining to the current anchor position, so the
--- `deltaColumn` is the additional spaces to add in this case. See
--- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for
--- details.
-data DeltaPos
- = SameLine { deltaColumn :: !Int }
- | DifferentLine
- { deltaLine :: !Int, -- ^ deltaLine should always be > 0
- deltaColumn :: !Int
- } deriving (Show,Eq,Ord,Data)
-
--- | Smart constructor for a 'DeltaPos'. It preserves the invariant
--- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.
-deltaPos :: Int -> Int -> DeltaPos
-deltaPos l c = case l of
- 0 -> SameLine c
- _ -> DifferentLine l c
-
-getDeltaLine :: DeltaPos -> Int
-getDeltaLine (SameLine _) = 0
-getDeltaLine (DifferentLine r _) = r
-
-- | Used in the parser only, extract the 'RealSrcSpan' from an
-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the
-- partial function is safe.
@@ -527,13 +480,6 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r
epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"
-instance Outputable NoComments where
- ppr NoComments = text "NoComments"
-
-instance (Outputable a) => Outputable (EpaLocation' a) where
- ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
- ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
-
instance Outputable AddEpAnn where
ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss
@@ -1419,10 +1365,6 @@ instance (Outputable a) => Outputable (EpAnn a) where
instance Outputable NoEpAnns where
ppr NoEpAnns = text "NoEpAnns"
-instance Outputable DeltaPos where
- ppr (SameLine c) = text "SameLine" <+> ppr c
- ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
-
instance Outputable (GenLocated NoCommentsLocation EpaComment) where
ppr (L l c) = text "L" <+> ppr l <+> ppr c
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -310,7 +310,7 @@ rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt (WarningTxt mb_cat st wst) = do
forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) ->
unless (validWarningCategory cat) $
- addErrAt loc (TcRnInvalidWarningCategory cat)
+ addErrAt (locA loc) (TcRnInvalidWarningCategory cat)
wst' <- traverse (traverse rnHsDoc) wst
pure (WarningTxt mb_cat st wst')
rnWarningTxt (DeprecatedTxt st wst) = do
=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -305,17 +305,13 @@ data StringLiteral = StringLiteral
{ sl_st :: SourceText, -- literal raw source.
-- See Note [Literal source text]
sl_fs :: FastString, -- literal string value
- sl_tc :: Maybe RealSrcSpan -- Location of
+ sl_tc :: Maybe NoCommentsLocation
+ -- Location of
-- possible
-- trailing comma
-- AZ: if we could have a LocatedA
-- StringLiteral we would not need sl_tc, but
-- that would cause import loops.
-
- -- AZ:2: sl_tc should be an EpaAnchor, to allow
- -- editing and reprinting the AST. Need a more
- -- robust solution.
-
} deriving Data
instance Eq StringLiteral where
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -109,6 +109,10 @@ module GHC.Types.SrcLoc (
mkSrcSpanPs,
combineRealSrcSpans,
psLocatedToLocated,
+
+ -- * Exact print locations
+ EpaLocation'(..), NoCommentsLocation, NoComments(..),
+ DeltaPos(..), deltaPos, getDeltaLine,
) where
import GHC.Prelude
@@ -894,3 +898,70 @@ psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)
mkSrcSpanPs :: PsSpan -> SrcSpan
mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)
+
+-- ---------------------------------------------------------------------
+-- The following section contains basic types related to exact printing.
+-- See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for
+-- details.
+-- This is only s subset, to prevent import loops. The balance are in
+-- GHC.Parser.Annotation
+-- ---------------------------------------------------------------------
+
+
+-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the
+-- @'EpaSpan'@ variant, giving the exact location of the original item
+-- in the parsed source. This can be replaced by the @'EpaDelta'@
+-- version, to provide a position for the item relative to the end of
+-- the previous item in the source. This is useful when editing an
+-- AST prior to exact printing the changed one. The list of comments
+-- in the @'EpaDelta'@ variant captures any comments between the prior
+-- output and the thing being marked here, since we cannot otherwise
+-- sort the relative order.
+
+data EpaLocation' a = EpaSpan !SrcSpan
+ | EpaDelta !DeltaPos !a
+ deriving (Data,Eq,Show)
+
+type NoCommentsLocation = EpaLocation' NoComments
+
+data NoComments = NoComments
+ deriving (Data,Eq,Ord,Show)
+
+-- | Spacing between output items when exact printing. It captures
+-- the spacing from the current print position on the page to the
+-- position required for the thing about to be printed. This is
+-- either on the same line in which case is is simply the number of
+-- spaces to emit, or it is some number of lines down, with a given
+-- column offset. The exact printing algorithm keeps track of the
+-- column offset pertaining to the current anchor position, so the
+-- `deltaColumn` is the additional spaces to add in this case. See
+-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for
+-- details.
+data DeltaPos
+ = SameLine { deltaColumn :: !Int }
+ | DifferentLine
+ { deltaLine :: !Int, -- ^ deltaLine should always be > 0
+ deltaColumn :: !Int
+ } deriving (Show,Eq,Ord,Data)
+
+-- | Smart constructor for a 'DeltaPos'. It preserves the invariant
+-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.
+deltaPos :: Int -> Int -> DeltaPos
+deltaPos l c = case l of
+ 0 -> SameLine c
+ _ -> DifferentLine l c
+
+getDeltaLine :: DeltaPos -> Int
+getDeltaLine (SameLine _) = 0
+getDeltaLine (DifferentLine r _) = r
+
+instance Outputable NoComments where
+ ppr NoComments = text "NoComments"
+
+instance (Outputable a) => Outputable (EpaLocation' a) where
+ ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
+ ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
+
+instance Outputable DeltaPos where
+ ppr (SameLine c) = text "SameLine" <+> ppr c
+ ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -121,11 +121,11 @@ data InWarningCategory
= InWarningCategory
{ iwc_in :: !(EpToken "in"),
iwc_st :: !SourceText,
- iwc_wc :: (Located WarningCategory)
+ iwc_wc :: (LocatedE WarningCategory)
} deriving Data
fromWarningCategory :: WarningCategory -> InWarningCategory
-fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLoc wc)
+fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)
-- See Note [Warning categories]
@@ -201,14 +201,14 @@ type LWarningTxt pass = XRec pass (WarningTxt pass)
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt pass
= WarningTxt
- (Maybe (Located InWarningCategory))
+ (Maybe (LocatedE InWarningCategory))
-- ^ Warning category attached to this WARNING pragma, if any;
-- see Note [Warning categories]
SourceText
- [Located (WithHsDocIdentifiers StringLiteral pass)]
+ [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
| DeprecatedTxt
SourceText
- [Located (WithHsDocIdentifiers StringLiteral pass)]
+ [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
deriving Generic
-- | To which warning category does this WARNING or DEPRECATED pragma belong?
@@ -218,7 +218,7 @@ warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _
warningTxtCategory _ = defaultWarningCategory
-- | The message that the WarningTxt was specified to output
-warningTxtMessage :: WarningTxt p -> [Located (WithHsDocIdentifiers StringLiteral p)]
+warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)]
warningTxtMessage (WarningTxt _ _ m) = m
warningTxtMessage (DeprecatedTxt _ m) = m
@@ -260,7 +260,7 @@ instance Outputable (WarningTxt pass) where
NoSourceText -> pp_ws ds
SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
-pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
+pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [l] = ppr $ unLoc l
pp_ws ws
= text "["
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -557,7 +557,8 @@ interactiveUI config srcs maybe_exprs = do
-- Set to True because Prelude is implicitly imported.
impDecl at ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}}
hsc_env <- GHC.getSession
- let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1
+ let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 1
+ -- We force this to make sure we don't retain the hsc_env when reloading
empty_cache <- liftIO newIfaceCache
startGHCi (runGHCi srcs maybe_exprs)
GHCiState{ progname = default_progname,
=====================================
libraries/ghci/GHCi/CreateBCO.hs
=====================================
@@ -68,9 +68,6 @@ createBCO arr bco
return (HValue final_bco) }
-toWordArray :: UArray Int Word64 -> UArray Int Word
-toWordArray = amap fromIntegral
-
linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
linkBCO' arr ResolvedBCO{..} = do
let
@@ -80,11 +77,10 @@ linkBCO' arr ResolvedBCO{..} = do
!(I# arity#) = resolvedBCOArity
!(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
-
- barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
- insns_barr = barr resolvedBCOInstrs
- bitmap_barr = barr (toWordArray resolvedBCOBitmap)
- literals_barr = barr (toWordArray resolvedBCOLits)
+ barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr#
+ insns_barr = barr (getBCOByteArray resolvedBCOInstrs)
+ bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap)
+ literals_barr = barr (getBCOByteArray resolvedBCOLits)
PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
IO $ \s ->
=====================================
libraries/ghci/GHCi/ResolvedBCO.hs
=====================================
@@ -1,9 +1,12 @@
{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
- BangPatterns, CPP #-}
+ BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts,
+ TypeApplications, ScopedTypeVariables, UnboxedTuples #-}
module GHCi.ResolvedBCO
( ResolvedBCO(..)
, ResolvedBCOPtr(..)
, isLittleEndian
+ , BCOByteArray(..)
+ , mkBCOByteArray
) where
import Prelude -- See note [Why do we import Prelude here?]
@@ -11,11 +14,19 @@ import GHC.Data.SizedSeq
import GHCi.RemoteTypes
import GHCi.BreakArray
-import Data.Array.Unboxed
import Data.Binary
+import Data.Binary.Put (putBuilder)
import GHC.Generics
-import GHCi.BinaryArray
+import Foreign.Ptr
+import Data.Array.Byte
+import qualified Data.Binary.Get.Internal as Binary
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Builder.Internal as BB
+import GHC.Exts
+import Data.Array.Base (UArray(..))
+
+import GHC.IO
#include "MachDeps.h"
@@ -32,19 +43,35 @@ isLittleEndian = True
-- | A 'ResolvedBCO' is one in which all the 'Name' references have been
-- resolved to actual addresses or 'RemoteHValues'.
--
--- Note, all arrays are zero-indexed (we assume this when
--- serializing/deserializing)
data ResolvedBCO
= ResolvedBCO {
resolvedBCOIsLE :: Bool,
resolvedBCOArity :: {-# UNPACK #-} !Int,
- resolvedBCOInstrs :: UArray Int Word16, -- insns
- resolvedBCOBitmap :: UArray Int Word64, -- bitmap
- resolvedBCOLits :: UArray Int Word64, -- non-ptrs
+ resolvedBCOInstrs :: BCOByteArray Word16, -- insns
+ resolvedBCOBitmap :: BCOByteArray Word, -- bitmap
+ resolvedBCOLits :: BCOByteArray Word, -- non-ptrs
resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs
}
deriving (Generic, Show)
+-- | Wrapper for a 'ByteArray#'.
+-- The phantom type tells what elements are stored in the 'ByteArray#'.
+-- Creating a 'ByteArray#' can be achieved using 'UArray''s API,
+-- where the underlying 'ByteArray#' can be unpacked.
+data BCOByteArray a
+ = BCOByteArray {
+ getBCOByteArray :: !ByteArray#
+ }
+
+mkBCOByteArray :: UArray Int a -> BCOByteArray a
+mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr
+
+instance Show (BCOByteArray Word16) where
+ showsPrec _ _ = showString "BCOByteArray Word16"
+
+instance Show (BCOByteArray Word) where
+ showsPrec _ _ = showString "BCOByteArray Word"
+
-- | The Binary instance for ResolvedBCOs.
--
-- Note, that we do encode the endianness, however there is no support for mixed
@@ -54,12 +81,16 @@ instance Binary ResolvedBCO where
put ResolvedBCO{..} = do
put resolvedBCOIsLE
put resolvedBCOArity
- putArray resolvedBCOInstrs
- putArray resolvedBCOBitmap
- putArray resolvedBCOLits
+ put resolvedBCOInstrs
+ put resolvedBCOBitmap
+ put resolvedBCOLits
put resolvedBCOPtrs
- get = ResolvedBCO
- <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get
+ get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
+
+instance Binary (BCOByteArray a) where
+ put = putBCOByteArray
+ get = decodeBCOByteArray
+
data ResolvedBCOPtr
= ResolvedBCORef {-# UNPACK #-} !Int
@@ -75,3 +106,65 @@ data ResolvedBCOPtr
deriving (Generic, Show)
instance Binary ResolvedBCOPtr
+
+-- --------------------------------------------------------
+-- Serialisers for 'BCOByteArray'
+-- --------------------------------------------------------
+
+putBCOByteArray :: BCOByteArray a -> Put
+putBCOByteArray (BCOByteArray bar) = do
+ put (I# (sizeofByteArray# bar))
+ putBuilder $ byteArrayBuilder bar
+
+decodeBCOByteArray :: Get (BCOByteArray a)
+decodeBCOByteArray = do
+ n <- get
+ getByteArray n
+
+byteArrayBuilder :: ByteArray# -> BB.Builder
+byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))
+ where
+ go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
+ go !inStart !inEnd k (BB.BufferRange outStart outEnd)
+ -- There is enough room in this output buffer to write all remaining array
+ -- contents
+ | inRemaining <= outRemaining = do
+ copyByteArrayToAddr arr# inStart outStart inRemaining
+ k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)
+ -- There is only enough space for a fraction of the remaining contents
+ | otherwise = do
+ copyByteArrayToAddr arr# inStart outStart outRemaining
+ let !inStart' = inStart + outRemaining
+ return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)
+ where
+ inRemaining = inEnd - inStart
+ outRemaining = outEnd `minusPtr` outStart
+
+ copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
+ copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =
+ IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of
+ s' -> (# s', () #)
+
+getByteArray :: Int -> Get (BCOByteArray a)
+getByteArray nbytes@(I# nbytes#) = do
+ let !(MutableByteArray arr#) = unsafeDupablePerformIO $
+ IO $ \s -> case newByteArray# nbytes# s of
+ (# s', mbar #) -> (# s', MutableByteArray mbar #)
+ let go 0 _ = return ()
+ go !remaining !off = do
+ Binary.readNWith n $ \ptr ->
+ copyAddrToByteArray ptr arr# off n
+ go (remaining - n) (off + n)
+ where n = min chunkSize remaining
+ go nbytes 0
+ return $! unsafeDupablePerformIO $
+ IO $ \s -> case unsafeFreezeByteArray# arr# s of
+ (# s', bar #) -> (# s', BCOByteArray bar #)
+ where
+ chunkSize = 10*1024
+
+ copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
+ -> Int -> Int -> IO ()
+ copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =
+ IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of
+ s' -> (# s', () #)
=====================================
testsuite/tests/ghci/should_run/BinaryArray.hs
=====================================
@@ -1,11 +1,15 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, MagicHash, ScopedTypeVariables #-}
import Data.Binary.Get
import Data.Binary.Put
+import Data.Binary (get, put)
+import Data.Array.Byte
import Data.Array.Unboxed as AU
import Data.Array.IO (IOUArray)
import Data.Array.MArray (MArray)
import Data.Array as A
+import Data.Array.Base as A
import GHCi.BinaryArray
+import GHCi.ResolvedBCO
import GHC.Word
roundtripTest :: (IArray UArray a, MArray IOUArray a IO, Eq a)
@@ -18,6 +22,17 @@ roundtripTest arr =
| otherwise -> putStrLn "failed to round-trip"
Left _ -> putStrLn "deserialization failed"
+roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a)
+ => UArray Int a -> IO ()
+roundtripTestByteArray (UArray _ _ _ arr#) =
+ let val = BCOByteArray arr# :: BCOByteArray a
+ ser = Data.Binary.Put.runPut $ put val
+ in case Data.Binary.Get.runGetOrFail (get :: Get (BCOByteArray a)) ser of
+ Right (_, _, BCOByteArray arr'# )
+ | ByteArray arr# == ByteArray arr'# -> return ()
+ | otherwise -> putStrLn "failed to round-trip"
+ Left _ -> putStrLn "deserialization failed"
+
main :: IO ()
main = do
roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Int)
@@ -27,3 +42,10 @@ main = do
roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32)
roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64)
roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char)
+ roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int)
+ roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word)
+ roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8)
+ roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16)
+ roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32)
+ roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64)
+ roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -711,6 +711,11 @@ printStringAtMLocL (EpAnn anc an cs) l s = do
printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation
printStringAtAA el str = printStringAtAAC CaptureComments el str
+printStringAtNC :: (Monad m, Monoid w) => NoCommentsLocation -> String -> EP w m NoCommentsLocation
+printStringAtNC el str = do
+ el' <- printStringAtAAC NoCaptureComments (noCommentsToEpaLocation el) str
+ return (epaToNoCommentsLocation el')
+
printStringAtAAL :: (Monad m, Monoid w)
=> a -> Lens a EpaLocation -> String -> EP w m a
printStringAtAAL an l str = do
@@ -2117,10 +2122,10 @@ instance ExactPrint StringLiteral where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact l@(StringLiteral src fs mcomma) = do
+ exact (StringLiteral src fs mcomma) = do
printSourceTextAA src (show (unpackFS fs))
- mapM_ (\r -> printStringAtRs r ",") mcomma
- return l
+ mcomma' <- mapM (\r -> printStringAtNC r ",") mcomma
+ return (StringLiteral src fs mcomma')
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d42a8a04e8d73b75110ad376149ac071987481dd...91341c467bc898ae151816bc89b82ca93d27101e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d42a8a04e8d73b75110ad376149ac071987481dd...91341c467bc898ae151816bc89b82ca93d27101e
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/20240408/20b34dd4/attachment-0001.html>
More information about the ghc-commits
mailing list