Matthew Pickering pushed to branch wip/mp/iface-patches-9.10 at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • compiler/GHC/ByteCode/Asm.hs
    ... ... @@ -34,6 +34,7 @@ import GHC.Utils.Panic
    34 34
    35 35 
     import GHC.Core.TyCon
    36 36 
     import GHC.Data.FastString
    37 
    +import GHC.Data.FlatBag
    37 38 
     import GHC.Data.SizedSeq
    38 39
    39 40 
     import GHC.StgToCmm.Layout     ( ArgRep(..) )
    ... ... @@ -71,9 +72,9 @@ bcoFreeNames bco
    71 72 
       where
    72 73 
         bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
    73 74 
             = unionManyUniqDSets (
    74 
    -             mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :
    75 
    -             mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
    76 
    -             map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
    75 
    +             mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] :
    76 
    +             mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] :
    77 
    +             map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ]
    77 78 
               )
    78 79
    79 80 
     -- -----------------------------------------------------------------------------
    ... ... @@ -90,7 +91,7 @@ bcoFreeNames bco
    90 91 
     assembleBCOs
    91 92 
       :: Interp
    92 93 
       -> Profile
    93 
    -  -> [ProtoBCO Name]
    94 
    +  -> FlatBag (ProtoBCO Name)
    94 95 
       -> [TyCon]
    95 96 
       -> AddrEnv
    96 97 
       -> Maybe ModBreaks
    ... ... @@ -129,7 +130,7 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
    129 130 
     -- top-level string literal bindings] in GHC.StgToByteCode for some discussion
    130 131 
     -- about why.
    131 132 
     --
    132 
    -mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
    133 
    +mallocStrings ::  Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
    133 134 
     mallocStrings interp ulbcos = do
    134 135 
       let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
    135 136 
       ptrs <- interpCmd interp (MallocStrings bytestrings)
    ... ... @@ -170,7 +171,7 @@ assembleOneBCO interp profile pbco = do
    170 171 
       -- TODO: the profile should be bundled with the interpreter: the rts ways are
    171 172 
       -- fixed for an interpreter
    172 173 
       ubco <- assembleBCO (profilePlatform profile) pbco
    173 
    -  [ubco'] <- mallocStrings interp [ubco]
    174 
    +  UnitFlatBag ubco' <- mallocStrings interp (UnitFlatBag ubco)
    174 175 
       return ubco'
    175 176
    176 177 
     assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
    ... ... @@ -213,9 +214,9 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
    213 214 
                  (text "bytecode instruction count mismatch")
    214 215
    215 216 
       let asm_insns = ssElts final_insns
    216 
    -      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
    217 
    -      bitmap_arr = mkBitmapArray bsize bitmap
    218 
    -      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
    217 
    +      !insns_arr =  mkBCOByteArray $ Array.listArray (0 :: Int, fromIntegral n_insns - 1) asm_insns
    218 
    +      !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap
    219 
    +      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSizedSeq final_lits) (fromSizedSeq final_ptrs)
    219 220
    220 221 
       -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
    221 222 
       -- objects, since they might get run too early.  Disable this until
    ... ... @@ -224,7 +225,7 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
    224 225
    225 226 
       return ul_bco
    226 227
    227 
    -mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
    228 
    +mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
    228 229 
     -- Here the return type must be an array of Words, not StgWords,
    229 230 
     -- because the underlying ByteArray# will end up as a component
    230 231 
     -- of a BCO object.

  • compiler/GHC/ByteCode/Linker.hs
    ... ... @@ -64,13 +64,13 @@ linkBCO interp pkgs_loaded le bco_ix
    64 64 
                (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
    65 65 
       -- fromIntegral Word -> Word64 should be a no op if Word is Word64
    66 66 
       -- otherwise it will result in a cast to longlong on 32bit systems.
    67 
    -  lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0)
    68 
    -  ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (ssElts ptrs0)
    69 
    -  let lits' = listArray (0 :: Int, fromIntegral (sizeSS lits0)-1) lits
    67 
    +  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0)
    68 
    +  ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)
    69 
    +  let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
    70 70 
       return (ResolvedBCO isLittleEndian arity
    71 71 
                   insns
    72 72 
                   bitmap
    73 
    -              lits'
    73 
    +              (mkBCOByteArray lits')
    74 74 
                   (addListToSS emptySS ptrs))
    75 75
    76 76 
     lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word

  • compiler/GHC/ByteCode/Types.hs
    1 1 
     {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    2 2 
     {-# LANGUAGE RecordWildCards            #-}
    3 3 
     {-# LANGUAGE TypeApplications           #-}
    4 
    +{-# LANGUAGE MagicHash                  #-}
    5 
    +{-# LANGUAGE UnliftedNewtypes           #-}
    4 6 
     --
    5 7 
     --  (c) The University of Glasgow 2002-2006
    6 8 
     --
    ... ... @@ -8,6 +10,7 @@
    8 10 
     -- | Bytecode assembler types
    9 11 
     module GHC.ByteCode.Types
    10 12 
       ( CompiledByteCode(..), seqCompiledByteCode
    13 
    +  , BCOByteArray(..), mkBCOByteArray
    11 14 
       , FFIInfo(..)
    12 15 
       , RegBitmap(..)
    13 16 
       , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo
    ... ... @@ -18,12 +21,13 @@ module GHC.ByteCode.Types
    18 21 
       , CgBreakInfo(..)
    19 22 
       , ModBreaks (..), BreakIndex, emptyModBreaks
    20 23 
       , CCostCentre
    24 
    +  , FlatBag, sizeFlatBag, fromSizedSeq, elemsFlatBag
    21 25 
       ) where
    22 26
    23 27 
     import GHC.Prelude
    24 28
    25 29 
     import GHC.Data.FastString
    26 
    -import GHC.Data.SizedSeq
    30 
    +import GHC.Data.FlatBag
    27 31 
     import GHC.Types.Name
    28 32 
     import GHC.Types.Name.Env
    29 33 
     import GHC.Utils.Outputable
    ... ... @@ -33,10 +37,10 @@ import GHCi.BreakArray
    33 37 
     import GHCi.RemoteTypes
    34 38 
     import GHCi.FFI
    35 39 
     import Control.DeepSeq
    40 
    +import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray )
    36 41
    37 42 
     import Foreign
    38 43 
     import Data.Array
    39 
    -import Data.Array.Base  ( UArray(..) )
    40 44 
     import Data.ByteString (ByteString)
    41 45 
     import Data.IntMap (IntMap)
    42 46 
     import qualified Data.IntMap as IntMap
    ... ... @@ -50,7 +54,7 @@ import Language.Haskell.Syntax.Module.Name (ModuleName)
    50 54 
     -- Compiled Byte Code
    51 55
    52 56 
     data CompiledByteCode = CompiledByteCode
    53 
    -  { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings
    57 
    +  { bc_bcos   :: FlatBag UnlinkedBCO -- Bunch of interpretable bindings
    54 58 
       , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls
    55 59 
       , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated
    56 60 
       , bc_strs   :: AddrEnv        -- malloc'd top-level strings
    ... ... @@ -62,7 +66,7 @@ newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
    62 66 
       deriving (Show, NFData)
    63 67
    64 68 
     instance Outputable CompiledByteCode where
    65 
    -  ppr CompiledByteCode{..} = ppr bc_bcos
    69 
    +  ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos
    66 70
    67 71 
     -- Not a real NFData instance, because ModBreaks contains some things
    68 72 
     -- we can't rnf
    ... ... @@ -152,10 +156,10 @@ data UnlinkedBCO
    152 156 
        = UnlinkedBCO {
    153 157 
             unlinkedBCOName   :: !Name,
    154 158 
             unlinkedBCOArity  :: {-# UNPACK #-} !Int,
    155 
    -        unlinkedBCOInstrs :: !(UArray Int Word16),      -- insns
    156 
    -        unlinkedBCOBitmap :: !(UArray Int Word64),      -- bitmap
    157 
    -        unlinkedBCOLits   :: !(SizedSeq BCONPtr),       -- non-ptrs
    158 
    -        unlinkedBCOPtrs   :: !(SizedSeq BCOPtr)         -- ptrs
    159 
    +        unlinkedBCOInstrs :: !(BCOByteArray Word16),      -- insns
    160 
    +        unlinkedBCOBitmap :: !(BCOByteArray Word),      -- bitmap
    161 
    +        unlinkedBCOLits   :: !(FlatBag BCONPtr),       -- non-ptrs
    162 
    +        unlinkedBCOPtrs   :: !(FlatBag BCOPtr)         -- ptrs
    159 163 
        }
    160 164
    161 165 
     instance NFData UnlinkedBCO where
    ... ... @@ -210,8 +214,8 @@ seqCgBreakInfo CgBreakInfo{..} =
    210 214 
     instance Outputable UnlinkedBCO where
    211 215 
        ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
    212 216 
           = sep [text "BCO", ppr nm, text "with",
    213 
    -             ppr (sizeSS lits), text "lits",
    214 
    -             ppr (sizeSS ptrs), text "ptrs" ]
    217 
    +             ppr (sizeFlatBag lits), text "lits",
    218 
    +             ppr (sizeFlatBag ptrs), text "ptrs" ]
    215 219
    216 220 
     instance Outputable CgBreakInfo where
    217 221 
        ppr info = text "CgBreakInfo" <+>

  • compiler/GHC/Data/FastString.hs
    ... ... @@ -307,9 +307,18 @@ and updates to multiple buckets with low synchronization overhead.
    307 307 
     See Note [Updating the FastString table] on how it's updated.
    308 308 
     -}
    309 309 
     data FastStringTable = FastStringTable
    310 
    -  {-# UNPACK #-} !FastMutInt -- the unique ID counter shared with all buckets
    311 
    -  {-# UNPACK #-} !FastMutInt -- number of computed z-encodings for all buckets
    312 
    -  (Array# (IORef FastStringTableSegment)) -- concurrent segments
    310 
    +  {-# UNPACK #-} !FastMutInt
    311 
    +  -- ^ The unique ID counter shared with all buckets
    312 
    +  --
    313 
    +  -- We unpack the 'FastMutInt' counter as it is always consumed strictly.
    314 
    +  {-# NOUNPACK #-} !FastMutInt
    315 
    +  -- ^ Number of computed z-encodings for all buckets.
    316 
    +  --
    317 
    +  -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk
    318 
    +  -- in 'mkFastStringWith' and needs to be boxed any way.
    319 
    +  -- If this is unpacked, then we box this single 'FastMutInt' once for each
    320 
    +  -- allocated FastString.
    321 
    +  (Array# (IORef FastStringTableSegment)) -- ^  concurrent segments
    313 322
    314 323 
     data FastStringTableSegment = FastStringTableSegment
    315 324 
       {-# UNPACK #-} !(MVar ())  -- the lock for write in each segment

  • compiler/GHC/Data/FlatBag.hs
    1 
    +{-# LANGUAGE UnboxedTuples #-}
    2 
    +module GHC.Data.FlatBag
    3 
    +  ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag)
    4 
    +  , emptyFlatBag
    5 
    +  , unitFlatBag
    6 
    +  , sizeFlatBag
    7 
    +  , elemsFlatBag
    8 
    +  , mappendFlatBag
    9 
    +  -- * Construction
    10 
    +  , fromList
    11 
    +  , fromSizedSeq
    12 
    +  ) where
    13 
    +
    14 
    +import GHC.Prelude
    15 
    +
    16 
    +import GHC.Data.SizedSeq (SizedSeq, ssElts, sizeSS)
    17 
    +
    18 
    +import Control.DeepSeq
    19 
    +
    20 
    +import GHC.Data.SmallArray
    21 
    +
    22 
    +-- | Store elements in a flattened representation.
    23 
    +--
    24 
    +-- A 'FlatBag' is a data structure that stores an ordered list of elements
    25 
    +-- in a flat structure, avoiding the overhead of a linked list.
    26 
    +-- Use this data structure, if the code requires the following properties:
    27 
    +--
    28 
    +-- * Elements are stored in a long-lived object, and benefit from a flattened
    29 
    +--   representation.
    30 
    +-- * The 'FlatBag' will be traversed but not extended or filtered.
    31 
    +-- * The number of elements should be known.
    32 
    +-- * Sharing of the empty case improves memory behaviour.
    33 
    +--
    34 
    +-- A 'FlagBag' aims to have as little overhead as possible to store its elements.
    35 
    +-- To achieve that, it distinguishes between the empty case, singleton, tuple
    36 
    +-- and general case.
    37 
    +-- Thus, we only pay for the additional three words of an 'Array' if we have at least
    38 
    +-- three elements.
    39 
    +data FlatBag a
    40 
    +  = EmptyFlatBag
    41 
    +  | UnitFlatBag !a
    42 
    +  | TupleFlatBag !a !a
    43 
    +  | FlatBag {-# UNPACK #-} !(SmallArray a)
    44 
    +
    45 
    +instance Functor FlatBag where
    46 
    +  fmap _ EmptyFlatBag = EmptyFlatBag
    47 
    +  fmap f (UnitFlatBag a) = UnitFlatBag $ f a
    48 
    +  fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b)
    49 
    +  fmap f (FlatBag e) = FlatBag $ mapSmallArray f e
    50 
    +
    51 
    +instance Foldable FlatBag where
    52 
    +  foldMap _ EmptyFlatBag = mempty
    53 
    +  foldMap f (UnitFlatBag a) = f a
    54 
    +  foldMap f (TupleFlatBag a b) = f a `mappend` f b
    55 
    +  foldMap f (FlatBag arr) = foldMapSmallArray f arr
    56 
    +
    57 
    +  length = fromIntegral . sizeFlatBag
    58 
    +
    59 
    +instance Traversable FlatBag where
    60 
    +  traverse _ EmptyFlatBag = pure EmptyFlatBag
    61 
    +  traverse f (UnitFlatBag a) = UnitFlatBag <$> f a
    62 
    +  traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b
    63 
    +  traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl)
    64 
    +
    65 
    +instance NFData a => NFData (FlatBag a) where
    66 
    +  rnf EmptyFlatBag = ()
    67 
    +  rnf (UnitFlatBag a) = rnf a
    68 
    +  rnf (TupleFlatBag a b) = rnf a `seq` rnf b
    69 
    +  rnf (FlatBag arr) = rnfSmallArray arr
    70 
    +
    71 
    +-- | Create an empty 'FlatBag'.
    72 
    +--
    73 
    +-- The empty 'FlatBag' is shared over all instances.
    74 
    +emptyFlatBag :: FlatBag a
    75 
    +emptyFlatBag = EmptyFlatBag
    76 
    +
    77 
    +-- | Create a singleton 'FlatBag'.
    78 
    +unitFlatBag :: a -> FlatBag a
    79 
    +unitFlatBag = UnitFlatBag
    80 
    +
    81 
    +-- | Calculate the size of
    82 
    +sizeFlatBag :: FlatBag a -> Word
    83 
    +sizeFlatBag EmptyFlatBag = 0
    84 
    +sizeFlatBag UnitFlatBag{} = 1
    85 
    +sizeFlatBag TupleFlatBag{} = 2
    86 
    +sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr
    87 
    +
    88 
    +-- | Get all elements that are stored in the 'FlatBag'.
    89 
    +elemsFlatBag :: FlatBag a -> [a]
    90 
    +elemsFlatBag EmptyFlatBag = []
    91 
    +elemsFlatBag (UnitFlatBag a) = [a]
    92 
    +elemsFlatBag (TupleFlatBag a b) = [a, b]
    93 
    +elemsFlatBag (FlatBag arr) =
    94 
    +  [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]]
    95 
    +
    96 
    +-- | Combine two 'FlatBag's.
    97 
    +--
    98 
    +-- The new 'FlatBag' contains all elements from both 'FlatBag's.
    99 
    +--
    100 
    +-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused.
    101 
    +mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a
    102 
    +mappendFlatBag EmptyFlatBag b = b
    103 
    +mappendFlatBag a EmptyFlatBag = a
    104 
    +mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b
    105 
    +mappendFlatBag a b =
    106 
    +  fromList (sizeFlatBag a + sizeFlatBag b)
    107 
    +           (elemsFlatBag a ++ elemsFlatBag b)
    108 
    +
    109 
    +-- | Store the list in a flattened memory representation, avoiding the memory overhead
    110 
    +-- of a linked list.
    111 
    +--
    112 
    +-- The size 'n' needs to be smaller or equal to the length of the list.
    113 
    +-- If it is smaller than the length of the list, overflowing elements are
    114 
    +-- discarded. It is undefined behaviour to set 'n' to be bigger than the
    115 
    +-- length of the list.
    116 
    +fromList :: Word -> [a] -> FlatBag a
    117 
    +fromList n elts =
    118 
    +  case elts of
    119 
    +    [] -> EmptyFlatBag
    120 
    +    [a] -> UnitFlatBag a
    121 
    +    [a, b] -> TupleFlatBag a b
    122 
    +    xs ->
    123 
    +      FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs))
    124 
    +
    125 
    +-- | Convert a 'SizedSeq' into its flattened representation.
    126 
    +-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification
    127 
    +-- is necessary.
    128 
    +fromSizedSeq :: SizedSeq a -> FlatBag a
    129 
    +fromSizedSeq s = fromList (sizeSS s) (ssElts s)

  • compiler/GHC/Data/SmallArray.hs
    ... ... @@ -11,13 +11,18 @@ module GHC.Data.SmallArray
    11 11 
       , freezeSmallArray
    12 12 
       , unsafeFreezeSmallArray
    13 13 
       , indexSmallArray
    14 
    +  , sizeofSmallArray
    14 15 
       , listToArray
    16 
    +  , mapSmallArray
    17 
    +  , foldMapSmallArray
    18 
    +  , rnfSmallArray
    15 19 
       )
    16 20 
     where
    17 21
    18 22 
     import GHC.Exts
    19 23 
     import GHC.Prelude
    20 24 
     import GHC.ST
    25 
    +import Control.DeepSeq
    21 26
    22 27 
     data SmallArray a = SmallArray (SmallArray# a)
    23 28
    ... ... @@ -64,6 +69,14 @@ unsafeFreezeSmallArray (SmallMutableArray ma) s =
    64 69 
       case unsafeFreezeSmallArray# ma s of
    65 70 
         (# s', a #) -> (# s', SmallArray a #)
    66 71
    72 
    +-- | Get the size of a 'SmallArray'
    73 
    +sizeofSmallArray
    74 
    +  :: SmallArray a
    75 
    +  -> Int
    76 
    +{-# INLINE sizeofSmallArray #-}
    77 
    +sizeofSmallArray (SmallArray sa#) =
    78 
    +  case sizeofSmallArray# sa# of
    79 
    +    s -> I# s
    67 80
    68 81 
     -- | Index a small-array (no bounds checking!)
    69 82 
     indexSmallArray
    ... ... @@ -71,9 +84,51 @@ indexSmallArray
    71 84 
       -> Int          -- ^ index
    72 85 
       -> a
    73 86 
     {-# INLINE indexSmallArray #-}
    74 
    -indexSmallArray (SmallArray sa#) (I# i) = case indexSmallArray# sa# i of
    75 
    -  (# v #) -> v
    87 
    +indexSmallArray (SmallArray sa#) (I# i) =
    88 
    +  case indexSmallArray# sa# i of
    89 
    +    (# v #) -> v
    76 90
    91 
    +-- | Map a function over the elements of a 'SmallArray'
    92 
    +--
    93 
    +mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b
    94 
    +{-# INLINE mapSmallArray #-}
    95 
    +mapSmallArray f sa = runST $ ST $ \s ->
    96 
    +  let
    97 
    +    n = sizeofSmallArray sa
    98 
    +    go !i saMut# state#
    99 
    +      | i < n =
    100 
    +        let
    101 
    +          a = indexSmallArray sa i
    102 
    +          newState# = writeSmallArray saMut# i (f a) state#
    103 
    +        in
    104 
    +          go (i + 1) saMut# newState#
    105 
    +      | otherwise = state#
    106 
    +  in
    107 
    +  case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of
    108 
    +    (# s', mutArr #) ->
    109 
    +      case go 0 mutArr s' of
    110 
    +        s'' -> unsafeFreezeSmallArray mutArr s''
    111 
    +
    112 
    +-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice
    113 
    +foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m
    114 
    +{-# INLINE foldMapSmallArray #-}
    115 
    +foldMapSmallArray f sa = go 0
    116 
    +  where
    117 
    +    n = sizeofSmallArray sa
    118 
    +    go i
    119 
    +      | i < n = f (indexSmallArray sa i) `mappend` go (i + 1)
    120 
    +      | otherwise = mempty
    121 
    +
    122 
    +-- | Force the elements of the given 'SmallArray'
    123 
    +--
    124 
    +rnfSmallArray :: NFData a => SmallArray a -> ()
    125 
    +{-# INLINE rnfSmallArray #-}
    126 
    +rnfSmallArray sa = go 0
    127 
    +  where
    128 
    +    n = sizeofSmallArray sa
    129 
    +    go !i
    130 
    +      | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1)
    131 
    +      | otherwise = ()
    77 132
    78 133 
     -- | Convert a list into an array.
    79 134 
     listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a

  • compiler/GHC/Iface/Type.hs
    ... ... @@ -419,12 +419,51 @@ data IfaceTyConInfo -- Used only to guide pretty-printing
    419 419 
                        , ifaceTyConSort       :: IfaceTyConSort }
    420 420 
         deriving (Eq, Ord)
    421 421
    422 
    --- This smart constructor allows sharing of the two most common
    423 
    --- cases. See #19194
    422 
    +-- | This smart constructor allows sharing of the two most common
    423 
    +-- cases. See Note [Sharing IfaceTyConInfo]
    424 424 
     mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo
    425 
    -mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = IfaceTyConInfo IsPromoted  IfaceNormalTyCon
    426 
    -mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon
    427 
    -mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom        sort
    425 
    +mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = promotedNormalTyConInfo
    426 
    +mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
    427 
    +mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom sort
    428 
    +
    429 
    +{-# NOINLINE promotedNormalTyConInfo #-}
    430 
    +-- | See Note [Sharing IfaceTyConInfo]
    431 
    +promotedNormalTyConInfo :: IfaceTyConInfo
    432 
    +promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon
    433 
    +
    434 
    +{-# NOINLINE notPromotedNormalTyConInfo #-}
    435 
    +-- | See Note [Sharing IfaceTyConInfo]
    436 
    +notPromotedNormalTyConInfo :: IfaceTyConInfo
    437 
    +notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
    438 
    +
    439 
    +{-
    440 
    +Note [Sharing IfaceTyConInfo]
    441 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    442 
    +'IfaceTyConInfo' occurs an awful lot in 'ModIface', see #19194 for an example.
    443 
    +But almost all of them are
    444 
    +
    445 
    +   IfaceTyConInfo IsPromoted IfaceNormalTyCon
    446 
    +   IfaceTyConInfo NotPromoted IfaceNormalTyCon.
    447 
    +
    448 
    +The smart constructor `mkIfaceTyConInfo` arranges to share these instances,
    449 
    +thus:
    450 
    +
    451 
    +  promotedNormalTyConInfo    = IfaceTyConInfo IsPromoted  IfaceNormalTyCon
    452 
    +  notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
    453 
    +
    454 
    +  mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = promotedNormalTyConInfo
    455 
    +  mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
    456 
    +  mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom sort
    457 
    +
    458 
    +But ALAS, the (nested) CPR transform can lose this sharing, completely
    459 
    +negating the effect of `mkIfaceTyConInfo`: see #24530 and #19326.
    460 
    +
    461 
    +Sticking-plaster solution: add a NOINLINE pragma to those top-level constants.
    462 
    +When we fix the CPR bug we can remove the NOINLINE pragmas.
    463 
    +
    464 
    +This one change leads to an 15% reduction in residency for GHC when embedding
    465 
    +'mi_extra_decls': see !12222.
    466 
    +-}
    428 467
    429 468 
     data IfaceMCoercion
    430 469 
       = IfaceMRefl

  • compiler/GHC/Linker/Loader.hs
    ... ... @@ -94,6 +94,7 @@ import Control.Monad
    94 94 
     import qualified Data.Set as Set
    95 95 
     import Data.Char (isSpace)
    96 96 
     import Data.Foldable (for_)
    97 
    +import qualified Data.Foldable as Foldable
    97 98 
     import Data.IORef
    98 99 
     import Data.List (intercalate, isPrefixOf, nub, partition, sortOn)
    99 100 
     import Data.Maybe
    ... ... @@ -947,7 +948,8 @@ linkSomeBCOs :: Interp
    947 948
    948 949 
     linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
    949 950 
      where
    950 
    -  fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)
    951 
    +  fun CompiledByteCode{..} inner accum =
    952 
    +    inner (Foldable.toList bc_bcos : accum)
    951 953
    952 954 
       do_link [] = return []
    953 955 
       do_link mods = do

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -63,6 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
    63 63 
     import GHC.StgToCmm.Layout
    64 64 
     import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
    65 65 
     import GHC.Data.Bitmap
    66 
    +import GHC.Data.FlatBag as FlatBag
    66 67 
     import GHC.Data.OrdList
    67 68 
     import GHC.Data.Maybe
    68 69 
     import GHC.Types.Name.Env (mkNameEnv)
    ... ... @@ -119,14 +120,14 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
    119 120 
             (BcM_State{..}, proto_bcos) <-
    120 121 
                runBc hsc_env this_mod mb_modBreaks $ do
    121 122 
                  let flattened_binds = concatMap flattenBind (reverse lifted_binds)
    122 
    -             mapM schemeTopBind flattened_binds
    123 
    +             FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds
    123 124
    124 125 
             when (notNull ffis)
    125 126 
                  (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
    126 127
    127 128 
             putDumpFileMaybe logger Opt_D_dump_BCOs
    128 129 
                "Proto-BCOs" FormatByteCode
    129 
    -           (vcat (intersperse (char ' ') (map ppr proto_bcos)))
    130 
    +           (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
    130 131
    131 132 
             cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
    132 133 
               (case modBreaks of

  • compiler/ghc.cabal.in
    ... ... @@ -415,6 +415,7 @@ Library
    415 415 
             GHC.Data.FastString
    416 416 
             GHC.Data.FastString.Env
    417 417 
             GHC.Data.FiniteMap
    418 
    +        GHC.Data.FlatBag
    418 419 
             GHC.Data.Graph.Base
    419 420 
             GHC.Data.Graph.Color
    420 421 
             GHC.Data.Graph.Collapse

  • libraries/ghci/GHCi/CreateBCO.hs
    ... ... @@ -68,9 +68,6 @@ createBCO arr bco
    68 68 
                       return (HValue final_bco) }
    69 69
    70 70
    71 
    -toWordArray :: UArray Int Word64 -> UArray Int Word
    72 
    -toWordArray = amap fromIntegral
    73 
    -
    74 71 
     linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
    75 72 
     linkBCO' arr ResolvedBCO{..} = do
    76 73 
       let
    ... ... @@ -80,11 +77,10 @@ linkBCO' arr ResolvedBCO{..} = do
    80 77 
           !(I# arity#)  = resolvedBCOArity
    81 78
    82 79 
           !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
    83 
    -
    84 
    -      barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
    85 
    -      insns_barr = barr resolvedBCOInstrs
    86 
    -      bitmap_barr = barr (toWordArray resolvedBCOBitmap)
    87 
    -      literals_barr = barr (toWordArray resolvedBCOLits)
    80 
    +      barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr#
    81 
    +      insns_barr = barr (getBCOByteArray resolvedBCOInstrs)
    82 
    +      bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap)
    83 
    +      literals_barr = barr (getBCOByteArray resolvedBCOLits)
    88 84
    89 85 
       PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
    90 86 
       IO $ \s ->

  • libraries/ghci/GHCi/ResolvedBCO.hs
    1 1 
     {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
    2 
    -    BangPatterns, CPP #-}
    2 
    +    BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts,
    3 
    +    TypeApplications, ScopedTypeVariables, UnboxedTuples #-}
    3 4 
     module GHCi.ResolvedBCO
    4 5 
       ( ResolvedBCO(..)
    5 6 
       , ResolvedBCOPtr(..)
    6 7 
       , isLittleEndian
    8 
    +  , BCOByteArray(..)
    9 
    +  , mkBCOByteArray
    7 10 
       ) where
    8 11
    9 12 
     import Prelude -- See note [Why do we import Prelude here?]
    ... ... @@ -11,11 +14,19 @@ import GHC.Data.SizedSeq
    11 14 
     import GHCi.RemoteTypes
    12 15 
     import GHCi.BreakArray
    13 16
    14 
    -import Data.Array.Unboxed
    15 17 
     import Data.Binary
    18 
    +import Data.Binary.Put (putBuilder)
    16 19 
     import GHC.Generics
    17 
    -import GHCi.BinaryArray
    18 20
    21 
    +import Foreign.Ptr
    22 
    +import Data.Array.Byte
    23 
    +import qualified Data.Binary.Get.Internal as Binary
    24 
    +import qualified Data.ByteString.Builder as BB
    25 
    +import qualified Data.ByteString.Builder.Internal as BB
    26 
    +import GHC.Exts
    27 
    +import Data.Array.Base (UArray(..))
    28 
    +
    29 
    +import GHC.IO
    19 30
    20 31 
     #include "MachDeps.h"
    21 32
    ... ... @@ -32,19 +43,35 @@ isLittleEndian = True
    32 43 
     -- | A 'ResolvedBCO' is one in which all the 'Name' references have been
    33 44 
     -- resolved to actual addresses or 'RemoteHValues'.
    34 45 
     --
    35 
    --- Note, all arrays are zero-indexed (we assume this when
    36 
    --- serializing/deserializing)
    37 46 
     data ResolvedBCO
    38 47 
        = ResolvedBCO {
    39 48 
             resolvedBCOIsLE   :: Bool,
    40 49 
             resolvedBCOArity  :: {-# UNPACK #-} !Int,
    41 
    -        resolvedBCOInstrs :: UArray Int Word16,         -- insns
    42 
    -        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap
    43 
    -        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs
    50 
    +        resolvedBCOInstrs :: BCOByteArray Word16,       -- insns
    51 
    +        resolvedBCOBitmap :: BCOByteArray Word,         -- bitmap
    52 
    +        resolvedBCOLits   :: BCOByteArray Word,         -- non-ptrs
    44 53 
             resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs
    45 54 
        }
    46 55 
        deriving (Generic, Show)
    47 56
    57 
    +-- | Wrapper for a 'ByteArray#'.
    58 
    +-- The phantom type tells what elements are stored in the 'ByteArray#'.
    59 
    +-- Creating a 'ByteArray#' can be achieved using 'UArray''s API,
    60 
    +-- where the underlying 'ByteArray#' can be unpacked.
    61 
    +data BCOByteArray a
    62 
    +  = BCOByteArray {
    63 
    +        getBCOByteArray :: !ByteArray#
    64 
    +  }
    65 
    +
    66 
    +mkBCOByteArray :: UArray Int a -> BCOByteArray a
    67 
    +mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr
    68 
    +
    69 
    +instance Show (BCOByteArray Word16) where
    70 
    +  showsPrec _ _ = showString "BCOByteArray Word16"
    71 
    +
    72 
    +instance Show (BCOByteArray Word) where
    73 
    +  showsPrec _ _ = showString "BCOByteArray Word"
    74 
    +
    48 75 
     -- | The Binary instance for ResolvedBCOs.
    49 76 
     --
    50 77 
     -- Note, that we do encode the endianness, however there is no support for mixed
    ... ... @@ -54,12 +81,16 @@ instance Binary ResolvedBCO where
    54 81 
       put ResolvedBCO{..} = do
    55 82 
         put resolvedBCOIsLE
    56 83 
         put resolvedBCOArity
    57 
    -    putArray resolvedBCOInstrs
    58 
    -    putArray resolvedBCOBitmap
    59 
    -    putArray resolvedBCOLits
    84 
    +    put resolvedBCOInstrs
    85 
    +    put resolvedBCOBitmap
    86 
    +    put resolvedBCOLits
    60 87 
         put resolvedBCOPtrs
    61 
    -  get = ResolvedBCO
    62 
    -        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get
    88 
    +  get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
    89 
    +
    90 
    +instance Binary (BCOByteArray a) where
    91 
    +  put = putBCOByteArray
    92 
    +  get = decodeBCOByteArray
    93 
    +
    63 94
    64 95 
     data ResolvedBCOPtr
    65 96 
       = ResolvedBCORef {-# UNPACK #-} !Int
    ... ... @@ -75,3 +106,65 @@ data ResolvedBCOPtr
    75 106 
       deriving (Generic, Show)
    76 107
    77 108 
     instance Binary ResolvedBCOPtr
    109 
    +
    110 
    +-- --------------------------------------------------------
    111 
    +-- Serialisers for 'BCOByteArray'
    112 
    +-- --------------------------------------------------------
    113 
    +
    114 
    +putBCOByteArray :: BCOByteArray a -> Put
    115 
    +putBCOByteArray (BCOByteArray bar) = do
    116 
    +  put (I# (sizeofByteArray# bar))
    117 
    +  putBuilder $ byteArrayBuilder bar
    118 
    +
    119 
    +decodeBCOByteArray :: Get (BCOByteArray a)
    120 
    +decodeBCOByteArray = do
    121 
    +  n <- get
    122 
    +  getByteArray n
    123 
    +
    124 
    +byteArrayBuilder :: ByteArray# -> BB.Builder
    125 
    +byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))
    126 
    +  where
    127 
    +    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
    128 
    +    go !inStart !inEnd k (BB.BufferRange outStart outEnd)
    129 
    +      -- There is enough room in this output buffer to write all remaining array
    130 
    +      -- contents
    131 
    +      | inRemaining <= outRemaining = do
    132 
    +          copyByteArrayToAddr arr# inStart outStart inRemaining
    133 
    +          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)
    134 
    +      -- There is only enough space for a fraction of the remaining contents
    135 
    +      | otherwise = do
    136 
    +          copyByteArrayToAddr arr# inStart outStart outRemaining
    137 
    +          let !inStart' = inStart + outRemaining
    138 
    +          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)
    139 
    +      where
    140 
    +        inRemaining  = inEnd - inStart
    141 
    +        outRemaining = outEnd `minusPtr` outStart
    142 
    +
    143 
    +    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
    144 
    +    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =
    145 
    +        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of
    146 
    +                     s' -> (# s', () #)
    147 
    +
    148 
    +getByteArray :: Int -> Get (BCOByteArray a)
    149 
    +getByteArray nbytes@(I# nbytes#) = do
    150 
    +    let !(MutableByteArray arr#) = unsafeDupablePerformIO $
    151 
    +          IO $ \s -> case newByteArray# nbytes# s of
    152 
    +                (# s', mbar #) -> (# s', MutableByteArray mbar #)
    153 
    +    let go 0 _ = return ()
    154 
    +        go !remaining !off = do
    155 
    +            Binary.readNWith n $ \ptr ->
    156 
    +              copyAddrToByteArray ptr arr# off n
    157 
    +            go (remaining - n) (off + n)
    158 
    +          where n = min chunkSize remaining
    159 
    +    go nbytes 0
    160 
    +    return $! unsafeDupablePerformIO $
    161 
    +      IO $ \s -> case unsafeFreezeByteArray# arr# s of
    162 
    +          (# s', bar #) -> (# s', BCOByteArray bar #)
    163 
    +  where
    164 
    +    chunkSize = 10*1024
    165 
    +
    166 
    +    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
    167 
    +                        -> Int -> Int -> IO ()
    168 
    +    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =
    169 
    +        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of
    170 
    +                     s' -> (# s', () #)

  • testsuite/tests/count-deps/CountDepsAst.stdout
    ... ... @@ -63,6 +63,7 @@ GHC.Data.FastMutInt
    63 63 
     GHC.Data.FastString
    64 64 
     GHC.Data.FastString.Env
    65 65 
     GHC.Data.FiniteMap
    66 
    +GHC.Data.FlatBag
    66 67 
     GHC.Data.Graph.Directed
    67 68 
     GHC.Data.Graph.UnVar
    68 69 
     GHC.Data.List.Infinite
    ... ... @@ -70,6 +71,7 @@ GHC.Data.List.SetOps
    70 71 
     GHC.Data.Maybe
    71 72 
     GHC.Data.OrdList
    72 73 
     GHC.Data.Pair
    74 
    +GHC.Data.SmallArray
    73 75 
     GHC.Data.Strict
    74 76 
     GHC.Data.StringBuffer
    75 77 
     GHC.Data.TrieMap

  • testsuite/tests/count-deps/CountDepsParser.stdout
    ... ... @@ -64,6 +64,7 @@ GHC.Data.FastMutInt
    64 64 
     GHC.Data.FastString
    65 65 
     GHC.Data.FastString.Env
    66 66 
     GHC.Data.FiniteMap
    67 
    +GHC.Data.FlatBag
    67 68 
     GHC.Data.Graph.Directed
    68 69 
     GHC.Data.Graph.UnVar
    69 70 
     GHC.Data.List.Infinite
    ... ... @@ -71,6 +72,7 @@ GHC.Data.List.SetOps
    71 72 
     GHC.Data.Maybe
    72 73 
     GHC.Data.OrdList
    73 74 
     GHC.Data.Pair
    75 
    +GHC.Data.SmallArray
    74 76 
     GHC.Data.Strict
    75 77 
     GHC.Data.StringBuffer
    76 78 
     GHC.Data.TrieMap

  • testsuite/tests/ghci/should_run/BinaryArray.hs
    1 
    -{-# LANGUAGE FlexibleContexts #-}
    1 
    +{-# LANGUAGE FlexibleContexts, MagicHash, ScopedTypeVariables #-}
    2 2 
     import Data.Binary.Get
    3 3 
     import Data.Binary.Put
    4 
    +import Data.Binary (get, put)
    5 
    +import Data.Array.Byte
    4 6 
     import Data.Array.Unboxed as AU
    5 7 
     import Data.Array.IO (IOUArray)
    6 8 
     import Data.Array.MArray (MArray)
    7 9 
     import Data.Array as A
    10 
    +import Data.Array.Base as A
    8 11 
     import GHCi.BinaryArray
    12 
    +import GHCi.ResolvedBCO
    9 13 
     import GHC.Word
    10 14
    11 15 
     roundtripTest :: (IArray UArray a, MArray IOUArray a IO, Eq a)
    ... ... @@ -18,6 +22,17 @@ roundtripTest arr =
    18 22 
                | otherwise    -> putStrLn "failed to round-trip"
    19 23 
              Left _           -> putStrLn "deserialization failed"
    20 24
    25 
    +roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a)
    26 
    +              => UArray Int a -> IO ()
    27 
    +roundtripTestByteArray (UArray _ _ _ arr#) =
    28 
    +    let val  = BCOByteArray arr# :: BCOByteArray a
    29 
    +        ser  = Data.Binary.Put.runPut $ put val
    30 
    +    in case Data.Binary.Get.runGetOrFail (get :: Get (BCOByteArray a)) ser of
    31 
    +         Right (_, _, BCOByteArray arr'# )
    32 
    +           | ByteArray arr# == ByteArray arr'#  -> return ()
    33 
    +           | otherwise                          -> putStrLn "failed to round-trip"
    34 
    +         Left _                                 -> putStrLn "deserialization failed"
    35 
    +
    21 36 
     main :: IO ()
    22 37 
     main = do
    23 38 
         roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Int)
    ... ... @@ -27,3 +42,10 @@ main = do
    27 42 
         roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32)
    28 43 
         roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64)
    29 44 
         roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char)
    45 
    +    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int)
    46 
    +    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word)
    47 
    +    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8)
    48 
    +    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16)
    49 
    +    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32)
    50 
    +    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64)
    51 
    +    roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char)

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help