[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: testsuite: Introduce template-haskell-exports test
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Apr 4 11:36:56 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0fde229f by Ben Gamari at 2024-04-04T07:04:58-04:00
testsuite: Introduce template-haskell-exports test
- - - - -
0c4a9686 by Luite Stegeman at 2024-04-04T07:05:39-04:00
Update correct counter in bumpTickyAllocd
- - - - -
43914846 by Fendor at 2024-04-04T07:36:39-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.
- - - - -
4aa55923 by Matthew Pickering at 2024-04-04T07:36:43-04:00
Fix off by one error in seekBinNoExpand and seekBin
- - - - -
10 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/Utils/Binary.hs
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/ResolvedBCO.hs
- testsuite/tests/ghci/should_run/BinaryArray.hs
- testsuite/tests/interface-stability/all.T
- + testsuite/tests/interface-stability/template-haskell-exports.stdout
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 = instrsFromUArray $ Array.listArray (0 :: Int, fromIntegral n_insns - 1) asm_insns
+ !bitmap_arr = bitmapFromUArray $ mkBitmapArray bsize bitmap
ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -42,9 +42,11 @@ import GHC.Types.Name.Env
import Language.Haskell.Syntax.Module.Name
-- Standard libraries
+import Data.Array.Base (UArray(..))
import Data.Array.Unboxed
import Foreign.Ptr
import GHC.Exts
+import Data.Word (Word64)
{-
Linking interpretables into something we can run
@@ -60,10 +62,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) (ssElts lits0)
+ (lits :: [Word64]) <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)
ptrs <- mapM (resolvePtr interp le bco_ix) (ssElts ptrs0)
- return (ResolvedBCO isLittleEndian arity insns bitmap
- (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
+ let !(UArray _ _ _ lits') = listArray (0 :: Int, fromIntegral (sizeSS lits0)-1) lits
+ return (ResolvedBCO isLittleEndian arity
+ (BCOByteArray (getBCOInstrs insns))
+ (BCOByteArray (getBCOBitmap bitmap))
+ (BCOByteArray 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,8 @@
-- | Bytecode assembler types
module GHC.ByteCode.Types
( CompiledByteCode(..), seqCompiledByteCode
+ , BCOInstrs, getBCOInstrs, BCOBitmap, getBCOBitmap
+ , instrsFromUArray, bitmapFromUArray
, FFIInfo(..)
, RegBitmap(..)
, NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo
@@ -36,7 +40,6 @@ import Control.DeepSeq
import Foreign
import Data.Array
-import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
@@ -45,6 +48,9 @@ import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Base (ByteArray#)
+import Data.Array.Unboxed (UArray)
+import Data.Array.Base (UArray(..))
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -148,12 +154,26 @@ newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)
newtype AddrPtr = AddrPtr (RemotePtr ())
deriving (NFData)
+-- | 'BCOInstrs' is backed by an 'ByteArray#' and stores
+-- 'Word16' elements.
+newtype BCOInstrs = BCOInstrs { getBCOInstrs :: ByteArray# }
+
+-- | 'BCOBitmap' is backed by an 'ByteArray#' and stores
+-- 'Word64' elements.
+newtype BCOBitmap = BCOBitmap { getBCOBitmap :: ByteArray# }
+
+instrsFromUArray :: UArray Int Word16 -> BCOInstrs
+instrsFromUArray !(UArray _ _ _ barr) = BCOInstrs barr
+
+bitmapFromUArray :: UArray Int Word64 -> BCOBitmap
+bitmapFromUArray !(UArray _ _ _ barr) = BCOBitmap barr
+
data UnlinkedBCO
= UnlinkedBCO {
unlinkedBCOName :: !Name,
unlinkedBCOArity :: {-# UNPACK #-} !Int,
- unlinkedBCOInstrs :: !(UArray Int Word16), -- insns
- unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap
+ unlinkedBCOInstrs :: !BCOInstrs, -- insns
+ unlinkedBCOBitmap :: !BCOBitmap, -- bitmap
unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs
unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs
}
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -809,7 +809,7 @@ bumpTickyEntryCount lbl = do
bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd lbl bytes = do
platform <- getPlatform
- bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes
+ bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes
bumpTickyTagSkip :: CLabel -> FCode ()
bumpTickyTagSkip lbl = do
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -243,15 +243,18 @@ tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
seekBin :: BinHandle -> Bin a -> IO ()
seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
- if (p >= sz)
+ if (p > sz)
then do expandBin h p; writeFastMutInt ix_r p
else writeFastMutInt ix_r p
--- | SeekBin but without calling expandBin
+-- | 'seekBinNoExpand' moves the index pointer to the location pointed to
+-- by 'Bin a'.
+-- This operation may 'panic', if the pointer location is out of bounds of the
+-- buffer of 'BinHandle'.
seekBinNoExpand :: BinHandle -> Bin a -> IO ()
seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
- if (p >= sz)
+ if (p > sz)
then panic "seekBinNoExpand: seek out of range"
else writeFastMutInt ix_r p
=====================================
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,11 @@
{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
- BangPatterns, CPP #-}
+ BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts,
+ TypeApplications, ScopedTypeVariables, UnboxedTuples #-}
module GHCi.ResolvedBCO
( ResolvedBCO(..)
, ResolvedBCOPtr(..)
, isLittleEndian
+ , BCOByteArray(..)
) where
import Prelude -- See note [Why do we import Prelude here?]
@@ -11,11 +13,18 @@ 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 GHC.IO
#include "MachDeps.h"
@@ -32,19 +41,32 @@ 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 Word64, -- bitmap
+ resolvedBCOLits :: BCOByteArray Word64, -- 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#
+ }
+
+instance Show (BCOByteArray Word16) where
+ showsPrec _ _ = showString "BCOByteArray Word16"
+
+instance Show (BCOByteArray Word64) where
+ showsPrec _ _ = showString "BCOByteArray Word64"
+
-- | The Binary instance for ResolvedBCOs.
--
-- Note, that we do encode the endianness, however there is no support for mixed
@@ -54,12 +76,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 +101,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)
=====================================
testsuite/tests/interface-stability/all.T
=====================================
@@ -9,3 +9,4 @@ def check_package(pkg_name):
check_package('base')
check_package('ghc-experimental')
+check_package('template-haskell')
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
The diff for this file was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/329380e731bc3d455cc64f0c5a1f2463c39c11cb...4aa5592313aa35c977466c06c1ced79784419ff7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/329380e731bc3d455cc64f0c5a1f2463c39c11cb...4aa5592313aa35c977466c06c1ced79784419ff7
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/20240404/f393bce4/attachment-0001.html>
More information about the ghc-commits
mailing list