[Git][ghc/ghc][wip/mpickering-hannes] 9 commits: Don't use unsafeInterleaveIO when reading type symbol table
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Mar 27 16:33:09 UTC 2024
Matthew Pickering pushed to branch wip/mpickering-hannes at Glasgow Haskell Compiler / GHC
Commits:
c5678e4c by Matthew Pickering at 2024-03-27T16:32:48+00:00
Don't use unsafeInterleaveIO when reading type symbol table
- - - - -
1f0e5fd5 by Matthew Pickering at 2024-03-27T16:32:48+00:00
Don't retain whole 1mb buffer from shareIface
- - - - -
f3930158 by Matthew Pickering at 2024-03-27T16:32:48+00:00
Strictness around deserialising FullBinData
We want to make sure to leave an explicit "thunk" here, a FullBinData
constructor rather than another layer of indirection via another thunk.
- - - - -
191cd9e9 by Matthew Pickering at 2024-03-27T16:32:48+00:00
Force in_multi to avoid retaining entire hsc_env
- - - - -
927da7f1 by Fendor at 2024-03-27T16:32:48+00:00
Compact FlatBag array representation
`Array` contains three additional `Word`'s we do not need in `FlatBag`. Move
`FlatBag` to `SmallArray`.
Expand the API of SmallArray by `sizeofSmallArray` and add common
traversal functions, such as `mapSmallArray` and `foldMapSmallArray`.
Additionally, allow users to force the elements of a `SmallArray`
via `rnfSmallArray`.
- - - - -
20ffbe88 by Matthew Pickering at 2024-03-27T16:32:48+00:00
Share IfaceTypes in CgBreakInfo via shared buffer
- - - - -
12b4dbba by Matthew Pickering at 2024-03-27T16:32:48+00:00
Fix off by one error in seekBinNoExpand and seekBin
- - - - -
5f89c66a by Matthew Pickering at 2024-03-27T16:32:48+00:00
Add Binary instance for Word
- - - - -
6ed397bd by Matthew Pickering at 2024-03-27T16:32:48+00:00
Share common bitmaps
This avoid allocating lots of duplicate ByteStrings for the bytecode
bitmaps.
- - - - -
13 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Data/SmallArray.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Utils/Binary.hs
- ghc/GHCi/UI.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -226,12 +227,49 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
return ul_bco
+
+bitmap_0_0, bitmap_1_0, bitmap_2_0, bitmap_3_0, bitmap_4_0, bitmap_5_0, bitmap_6_0, bitmap_7_0, bitmap_8_0 :: UArray Int Word64
+
+bitmap_0_0 = Array.listArray (0,0) [0]
+bitmap_1_0 = Array.listArray (0,1) [ 1, 0 ]
+bitmap_2_0 = Array.listArray (0,1) [ 2, 0 ]
+bitmap_3_0 = Array.listArray (0,1) [ 3, 0 ]
+bitmap_4_0 = Array.listArray (0,1) [ 4, 0 ]
+bitmap_5_0 = Array.listArray (0,1) [ 5, 0 ]
+bitmap_6_0 = Array.listArray (0,1) [ 6, 0 ]
+bitmap_7_0 = Array.listArray (0,1) [ 7, 0 ]
+bitmap_8_0 = Array.listArray (0,1) [ 8, 0 ]
+
+{-# NOINLINE bitmap_0_0 #-}
+{-# NOINLINE bitmap_1_0 #-}
+{-# NOINLINE bitmap_2_0 #-}
+{-# NOINLINE bitmap_3_0 #-}
+{-# NOINLINE bitmap_4_0 #-}
+{-# NOINLINE bitmap_5_0 #-}
+{-# NOINLINE bitmap_6_0 #-}
+{-# NOINLINE bitmap_7_0 #-}
+{-# NOINLINE bitmap_8_0 #-}
+
+
mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
-- 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.
+mkBitmapArray 0 [] = bitmap_0_0
+mkBitmapArray 1 [fromStgWord -> 0] = bitmap_1_0
+mkBitmapArray 2 [fromStgWord -> 0] = bitmap_2_0
+mkBitmapArray 3 [fromStgWord -> 0] = bitmap_3_0
+mkBitmapArray 4 [fromStgWord -> 0] = bitmap_4_0
+mkBitmapArray 5 [fromStgWord -> 0] = bitmap_5_0
+mkBitmapArray 6 [fromStgWord -> 0] = bitmap_6_0
+mkBitmapArray 7 [fromStgWord -> 0] = bitmap_7_0
+mkBitmapArray 8 [fromStgWord -> 0] = bitmap_8_0
mkBitmapArray bsize bitmap
- = Array.listArray (0, length bitmap) $
+ = reallyMkBitmapArray bsize bitmap
+
+reallyMkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
+reallyMkBitmapArray bsize bitmap =
+ Array.listArray (0, length bitmap) $
fromIntegral bsize : map (fromInteger . fromStgWord) bitmap
-- instrs nonptrs ptrs
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -52,6 +52,7 @@ import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Base (ByteArray#)
+import GHC.Utils.Binary
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -229,6 +230,11 @@ data CgBreakInfo
, cgb_vars :: ![Maybe (IfaceIdBndr, Word)]
, cgb_resty :: !IfaceType
}
+
+instance Binary CgBreakInfo where
+ putNoStack_ bh (CgBreakInfo tv vs rty) =
+ put_ bh tv >> put_ bh vs >> put_ bh rty
+ get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh
-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
seqCgBreakInfo :: CgBreakInfo -> ()
=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE UnboxedTuples #-}
module GHC.Data.FlatBag
( FlatBag
, emptyFlatBag
@@ -16,7 +17,7 @@ import GHC.Data.SizedSeq (SizedSeq, ssElts, sizeSS)
import Control.DeepSeq
-import Data.Array
+import GHC.Data.SmallArray
-- | Store elements in a flattened representation.
--
@@ -39,20 +40,19 @@ data FlatBag a
= EmptyFlatBag
| UnitFlatBag !a
| TupleFlatBag !a !a
- | FlatBag {-# UNPACK #-} !(Array Word a)
- deriving (Show)
+ | FlatBag {-# UNPACK #-} !(SmallArray a)
instance Functor FlatBag where
fmap _ EmptyFlatBag = EmptyFlatBag
fmap f (UnitFlatBag a) = UnitFlatBag $ f a
fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b)
- fmap f (FlatBag e) = FlatBag $ fmap f e
+ fmap f (FlatBag e) = FlatBag $ mapSmallArray f e
instance Foldable FlatBag where
foldMap _ EmptyFlatBag = mempty
foldMap f (UnitFlatBag a) = f a
foldMap f (TupleFlatBag a b) = f a `mappend` f b
- foldMap f (FlatBag e) = foldMap f e
+ foldMap f (FlatBag arr) = foldMapSmallArray f arr
length = fromIntegral . sizeFlatBag
@@ -60,13 +60,13 @@ instance Traversable FlatBag where
traverse _ EmptyFlatBag = pure EmptyFlatBag
traverse f (UnitFlatBag a) = UnitFlatBag <$> f a
traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b
- traverse f (FlatBag e) = FlatBag <$> traverse f e
+ traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl)
instance NFData a => NFData (FlatBag a) where
rnf EmptyFlatBag = ()
rnf (UnitFlatBag a) = rnf a
rnf (TupleFlatBag a b) = rnf a `seq` rnf b
- rnf (FlatBag e) = rnf e
+ rnf (FlatBag arr) = rnfSmallArray arr
-- | Create an empty 'FlatBag'.
--
@@ -83,14 +83,15 @@ sizeFlatBag :: FlatBag a -> Word
sizeFlatBag EmptyFlatBag = 0
sizeFlatBag UnitFlatBag{} = 1
sizeFlatBag TupleFlatBag{} = 2
-sizeFlatBag (FlatBag e) = fromIntegral (length e)
+sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr
-- | Get all elements that are stored in the 'FlatBag'.
elemsFlatBag :: FlatBag a -> [a]
elemsFlatBag EmptyFlatBag = []
elemsFlatBag (UnitFlatBag a) = [a]
elemsFlatBag (TupleFlatBag a b) = [a, b]
-elemsFlatBag (FlatBag e) = elems e
+elemsFlatBag (FlatBag arr) =
+ [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]]
-- | Combine two 'FlatBag's.
--
@@ -100,6 +101,7 @@ elemsFlatBag (FlatBag e) = elems e
mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a
mappendFlatBag EmptyFlatBag b = b
mappendFlatBag a EmptyFlatBag = a
+mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b
mappendFlatBag a b =
fromList (sizeFlatBag a + sizeFlatBag b)
(elemsFlatBag a ++ elemsFlatBag b)
@@ -107,7 +109,7 @@ mappendFlatBag a b =
-- | Store the list in a flattened memory representation, avoiding the memory overhead
-- of a linked list.
--
--- The size 'n' needs to be at least the length of the list.
+-- The size 'n' needs to be smaller or equal to the length of the list.
-- If it is smaller than the length of the list, overflowing elements are
-- discarded. It is undefined behaviour to set 'n' to be bigger than the
-- length of the list.
@@ -117,7 +119,8 @@ fromList n elts =
[] -> EmptyFlatBag
[a] -> UnitFlatBag a
[a, b] -> TupleFlatBag a b
- xs -> FlatBag (listArray (0, n - 1) xs)
+ xs ->
+ FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs))
-- | Convert a 'SizedSeq' into its flattened representation.
-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification
=====================================
compiler/GHC/Data/SmallArray.hs
=====================================
@@ -11,13 +11,18 @@ module GHC.Data.SmallArray
, freezeSmallArray
, unsafeFreezeSmallArray
, indexSmallArray
+ , sizeofSmallArray
, listToArray
+ , mapSmallArray
+ , foldMapSmallArray
+ , rnfSmallArray
)
where
import GHC.Exts
import GHC.Prelude
import GHC.ST
+import Control.DeepSeq
data SmallArray a = SmallArray (SmallArray# a)
@@ -64,6 +69,14 @@ unsafeFreezeSmallArray (SmallMutableArray ma) s =
case unsafeFreezeSmallArray# ma s of
(# s', a #) -> (# s', SmallArray a #)
+-- | Get the size of a 'SmallArray'
+sizeofSmallArray
+ :: SmallArray a
+ -> Int
+{-# INLINE sizeofSmallArray #-}
+sizeofSmallArray (SmallArray sa#) =
+ case sizeofSmallArray# sa# of
+ s -> I# s
-- | Index a small-array (no bounds checking!)
indexSmallArray
@@ -71,9 +84,51 @@ indexSmallArray
-> Int -- ^ index
-> a
{-# INLINE indexSmallArray #-}
-indexSmallArray (SmallArray sa#) (I# i) = case indexSmallArray# sa# i of
- (# v #) -> v
+indexSmallArray (SmallArray sa#) (I# i) =
+ case indexSmallArray# sa# i of
+ (# v #) -> v
+-- | Map a function over the elements of a 'SmallArray'
+--
+mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b
+{-# INLINE mapSmallArray #-}
+mapSmallArray f sa = runST $ ST $ \s ->
+ let
+ n = sizeofSmallArray sa
+ go !i saMut# state#
+ | i < n =
+ let
+ a = indexSmallArray sa i
+ newState# = writeSmallArray saMut# i (f a) state#
+ in
+ go (i + 1) saMut# newState#
+ | otherwise = state#
+ in
+ case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of
+ (# s', mutArr #) ->
+ case go 0 mutArr s' of
+ s'' -> unsafeFreezeSmallArray mutArr s''
+
+-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice
+foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m
+{-# INLINE foldMapSmallArray #-}
+foldMapSmallArray f sa = go 0
+ where
+ n = sizeofSmallArray sa
+ go i
+ | i < n = f (indexSmallArray sa i) `mappend` go (i + 1)
+ | otherwise = mempty
+
+-- | Force the elements of the given 'SmallArray'
+--
+rnfSmallArray :: NFData a => SmallArray a -> ()
+{-# INLINE rnfSmallArray #-}
+rnfSmallArray sa = go 0
+ where
+ n = sizeofSmallArray sa
+ go !i
+ | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1)
+ | otherwise = ()
-- | Convert a list into an array.
listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -19,6 +19,8 @@ module GHC.Iface.Binary (
TraceBinIFace(..),
getWithUserData,
putWithUserData,
+ putWithTables',
+ getTables',
-- * Internal serialisation functions
getSymbolTable,
@@ -62,6 +64,7 @@ import qualified Data.Map as Map
import System.IO
import Data.List
import System.FilePath
+import System.IO.Unsafe
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
@@ -180,7 +183,7 @@ getWithUserData name_cache bh = do
-- (getDictFastString dict)
data ReadIfaceTable out = ReadIfaceTable
- { getTable :: HasCallStack => IORef BinHandle -> BinHandle -> IO out
+ { getTable :: HasCallStack => BinHandle -> IO out
}
data WriteIfaceTable = WriteIfaceTable
@@ -189,21 +192,22 @@ data WriteIfaceTable = WriteIfaceTable
getTables' :: HasCallStack => NameCache -> BinHandle -> IO BinHandle
getTables' name_cache bh = do
+ bhRef <- newIORef (error "used too soon")
+ ud <- unsafeInterleaveIO (readIORef bhRef)
fsCache <- initReadFsCachedBinary
nameCache <- initReadNameCachedBinary name_cache
-- ifaceCache <- initReadIfaceTyConTable
- ifaceTypeCache <- initReadIfaceTypeTable
- bhRef <- newIORef (error "used too soon")
+ ifaceTypeCache <- initReadIfaceTypeTable ud
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
- dict <- Binary.forwardGet bh (getTable fsCache bhRef bh)
+ dict <- Binary.forwardGet bh (getTable fsCache bh)
let
fsDecoder = mkReader $ getDictFastString dict
bh_fs = addDecoder (mkCache (Proxy @FastString) fsDecoder) bh
- symtab <- Binary.forwardGet bh_fs (getTable nameCache bhRef bh_fs)
+ symtab <- Binary.forwardGet bh_fs (getTable nameCache bh_fs)
let nameCache' = mkReader $ getSymtabName symtab
@@ -215,10 +219,10 @@ getTables' name_cache bh = do
-- bh_name2 = addDecoder (mkCache (Proxy :: Proxy IfaceTyCon) ifaceDecoder) bh_name
- ifaceSymTab2 <- Binary.forwardGet bh_name (getTable ifaceTypeCache bhRef bh_name)
+ ifaceSymTab2 <- Binary.forwardGet bh_name (getTable ifaceTypeCache bh_name)
let ifaceDecoder2 = mkReader $ getGenericSymtab ifaceSymTab2
let bh_type = addDecoder (mkCache (Proxy :: Proxy IfaceType) ifaceDecoder2) bh_name
- writeIORef bhRef bh_type
+ writeIORef bhRef (getUserData bh_type)
return bh_type
@@ -265,7 +269,7 @@ writeStackFormat fp report = do
-- This segment should be read using `getWithUserData`.
putWithUserData :: HasCallStack => Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData traceBinIface bh payload = do
- (name_count, fs_count, _b) <- putWithTables' bh (\bh' -> putNoStack bh' payload)
+ (name_count, fs_count, type_count, _b) <- putWithTables' bh (\bh' -> putNoStack bh' payload)
case traceBinIface of
QuietBinIFace -> return ()
@@ -279,7 +283,7 @@ initReadFsCachedBinary :: (HasCallStack) => IO (ReadIfaceTable (SymbolTable Fast
initReadFsCachedBinary = do
return $
ReadIfaceTable
- { getTable = \_ -> getDictionary
+ { getTable = getDictionary
}
initWriteFsTable :: (HasCallStack) => IO (WriteIfaceTable, CachedBinary FastString)
@@ -308,7 +312,7 @@ initReadNameCachedBinary :: (HasCallStack) => NameCache -> IO (ReadIfaceTable (S
initReadNameCachedBinary cache = do
return $
ReadIfaceTable
- { getTable = \_ bh -> getSymbolTable bh cache
+ { getTable = \bh -> getSymbolTable bh cache
}
initWriteNameTable :: (HasCallStack) => IO (WriteIfaceTable, CachedBinary Name)
@@ -338,14 +342,21 @@ initReadIfaceTyConTable :: HasCallStack => IO (ReadIfaceTable (SymbolTable Iface
initReadIfaceTyConTable = do
pure $
ReadIfaceTable
- { getTable = getGenericSymbolTable (\_ -> getIfaceTyCon)
+ { getTable = getGenericSymbolTable getIfaceTyCon
}
-initReadIfaceTypeTable :: HasCallStack => IO (ReadIfaceTable (SymbolTable IfaceType))
-initReadIfaceTypeTable = do
+readFromSymTab :: UserData -> BinHandle -> IO FullBinData
+readFromSymTab ud bh = do
+ p <- get @(Bin ()) bh -- a BinPtr
+ frozen_bh <- freezeBinHandle p (setUserData bh ud)
+ seekBinNoExpand bh p -- skip over the object for now
+ return frozen_bh
+
+initReadIfaceTypeTable :: HasCallStack => UserData -> IO (ReadIfaceTable (SymbolTable IfaceType))
+initReadIfaceTypeTable ud = do
pure $
ReadIfaceTable
- { getTable = getGenericSymbolTable (\optr bh -> IfaceSerialisedType <$> freezeBinHandle optr bh)
+ { getTable = getGenericSymbolTable (\bh -> IfaceSerialisedType <$!> readFromSymTab ud bh)
}
@@ -365,7 +376,7 @@ initWriteIfaceType = do
sym_tab <- initGenericSymbolTable
pure
( WriteIfaceTable
- { putTable = putGenericSymbolTable sym_tab putIfaceType
+ { putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)
}
, mkWriter $ putGenericSymTab sym_tab
)
@@ -417,7 +428,7 @@ initWriteIfaceType = do
-- return (name_count, fs_count, r)
-putWithTables' :: HasCallStack => BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)
+putWithTables' :: HasCallStack => BinHandle -> (BinHandle -> IO b) -> IO (Int,Int, Int, b)
putWithTables' bh' put_payload = do
(fsTbl, fsWriter) <- initWriteFsTable
(nameTbl, nameWriter) <- initWriteNameTable
@@ -432,14 +443,14 @@ putWithTables' bh' put_payload = do
]
let bh = setUserData bh' userData
- (fs_count,(name_count,(_, r))) <-
+ (fs_count,(name_count,(type_count, r))) <-
forwardPut bh (const (putTable fsTbl bh)) $ do
forwardPut bh (const (putTable nameTbl bh)) $ do
-- forwardPut bh (const (putTable ifaceTyConTbl bh)) $ do
forwardPut bh (const (putTable ifaceTypeTbl bh)) $ do
put_payload bh
- return (name_count, fs_count, r)
+ return (name_count, fs_count, type_count, r)
-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -96,6 +96,8 @@ import Data.List ( sortBy )
import Data.Ord
import Data.IORef
+import qualified Data.ByteString as BS
+
{-
************************************************************************
@@ -157,10 +159,11 @@ shareIface :: NameCache -> ModIface -> IO ModIface
shareIface nc mi = do
bh <- openBinMem (1024 * 1024)
-- Todo, not quite right (See ext fields etc)
- start <- tellBin @() bh
putWithUserData QuietBinIFace bh mi
- seekBin bh start
- res <- getWithUserData nc bh
+ -- Copy out just the part of the buffer which is used, otherwise each interface
+ -- retains a 1mb bytearray
+ bh' <- withBinBuffer bh (\bs -> unsafeUnpackBinBuffer (BS.copy bs))
+ res <- getWithUserData nc bh'
let resiface = res { mi_src_hash = mi_src_hash mi }
forceModIface resiface
return resiface
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -619,7 +619,7 @@ fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing
-}
data IfaceExpr
- = IfaceSerialisedExpr FullBinData
+ = IfaceSerialisedExpr !FullBinData
| IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceType IfaceType
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -161,7 +161,7 @@ type IfaceKind = IfaceType
-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'
-- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr"
data IfaceType
- = IfaceSerialisedType FullBinData
+ = IfaceSerialisedType !FullBinData
| IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
| IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceLitTy IfaceTyLit
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -92,6 +92,10 @@ import GHC.Stg.Syntax
import qualified Data.IntSet as IntSet
import GHC.CoreToIface
import Data.Array as Array
+import GHC.Utils.Binary
+import Data.IORef
+import System.IO.Unsafe
+import GHC.Iface.Binary
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -2190,6 +2194,7 @@ data BcM_State
-- Should be free()d when it is GCd
, modBreaks :: Maybe ModBreaks -- info about breakpoints
, breakInfo :: IntMap CgBreakInfo
+ , breakInfoBuffer :: (BinHandle, UserData) -- ^ A buffer which enables CgBreakInfo to be shared.
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
@@ -2202,8 +2207,32 @@ ioToBc io = BcM $ \st -> do
runBc :: HscEnv -> Module -> Maybe ModBreaks
-> BcM r
-> IO (BcM_State, r)
-runBc hsc_env this_mod modBreaks (BcM m)
- = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty)
+runBc hsc_env this_mod modBreaks (BcM m) = do
+ bh <- openBinMem 1024
+ start <- tellBin @() bh
+ user_data <- newIORef (error "used too soon")
+ read_ud <- unsafeInterleaveIO (readIORef user_data)
+ (fs, n, t, r) <- putWithTables' bh
+ (\bh' -> m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty (bh', read_ud)))
+ seekBinNoExpand bh start
+ bh_with_user <- getTables' (hsc_NC hsc_env) bh
+ writeIORef user_data (getUserData bh_with_user)
+ return r
+
+{-
+shareIface :: NameCache -> ModIface -> IO ModIface
+shareIface nc mi = do
+ bh <- openBinMem (1024 * 1024)
+ -- Todo, not quite right (See ext fields etc)
+ putWithUserData QuietBinIFace bh mi
+ -- Copy out just the part of the buffer which is used, otherwise each interface
+ -- retains a 1mb bytearray
+ bh' <- withBinBuffer bh (\bs -> unsafeUnpackBinBuffer (BS.copy bs))
+ res <- getWithUserData nc bh'
+ let resiface = res { mi_src_hash = mi_src_hash mi }
+ forceModIface resiface
+ return resiface
+ -}
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -2260,8 +2289,13 @@ getLabelsBc n
in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
-newBreakInfo ix info = BcM $ \st ->
- return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
+newBreakInfo ix info = BcM $ \st -> do
+ let (bh, read_ud) = breakInfoBuffer st
+ start <- tellBin @() bh
+ lazyPut bh info
+ seekBinNoExpand bh start
+ shared_info <- lazyGet (setUserData bh read_ud)
+ return (st{breakInfo = IntMap.insert ix shared_info (breakInfo st)}, ())
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \st -> return (st, thisModule st)
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -344,7 +344,7 @@ 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
@@ -352,7 +352,7 @@ seekBin h@(BinMem _ ix_r sz_r _ _) (BinPtr !p) = do
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
@@ -746,6 +746,10 @@ instance Binary Word64 where
putNoStack_ = putULEB128
get = getULEB128
+instance Binary Word where
+ putNoStack_ = putULEB128
+ get = getULEB128
+
-- -----------------------------------------------------------------------------
-- Primitive Int writes
@@ -1274,20 +1278,21 @@ putGenericSymbolTable gen_sym_tab serialiser bh = do
case vs of
[] -> return table_count
todo -> do
- mapM_ (\n -> lazyPut' serialiser bh n) (map snd vs)
+ mapM_ (\n -> serialiser bh n) (map snd vs)
loop table_count
snd <$>
(forwardPut bh (const $ readFastMutInt symtab_next >>= put_ bh) $
loop 0)
-getGenericSymbolTable :: forall a. (Bin () -> BinHandle -> IO a) -> IORef BinHandle -> BinHandle -> IO (SymbolTable a)
-getGenericSymbolTable deserialiser bhRef bh = do
+getGenericSymbolTable :: forall a. (BinHandle -> IO a) -> BinHandle -> IO (SymbolTable a)
+getGenericSymbolTable deserialiser bh = do
sz <- forwardGet bh (get bh) :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
-- Using lazyPut/lazyGet is quite space inefficient as each usage will allocate a large closure
-- (6 arguments-ish).
forM_ [0..(sz-1)] $ \i -> do
- f <- lazyGet' (Just bhRef) deserialiser bh
+-- f <- lazyGet' (Just bhRef) deserialiser bh
+ !f <- deserialiser bh
writeArray mut_arr i f
-- pprTraceM "gotten" (ppr sz)
unsafeFreeze mut_arr
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -558,7 +558,7 @@ 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
empty_cache <- liftIO newIfaceCache
startGHCi (runGHCi srcs maybe_exprs)
GHCiState{ progname = default_progname,
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -71,6 +71,7 @@ GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -72,6 +72,7 @@ GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.Pair
+GHC.Data.SmallArray
GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42ce32c800b6c22c150cde35e7db66da61fa0085...6ed397bde8d9d0a8214d8b90ac2d07b3d754d70c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42ce32c800b6c22c150cde35e7db66da61fa0085...6ed397bde8d9d0a8214d8b90ac2d07b3d754d70c
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/20240327/799badfb/attachment-0001.html>
More information about the ghc-commits
mailing list