Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

10 changed files:

Changes:

  • compiler/GHC/ByteCode/Linker.hs
    ... ... @@ -29,7 +29,7 @@ import GHC.Unit.Types
    29 29
    30 30 
     import GHC.Data.FastString
    31 31 
     import GHC.Data.Maybe
    32 
    -import GHC.Data.SizedSeq
    32 
    +import GHC.Data.SmallArray
    33 33
    34 34 
     import GHC.Linker.Types
    35 35
    ... ... @@ -43,7 +43,10 @@ import GHC.Types.Unique.DFM
    43 43
    44 44 
     -- Standard libraries
    45 45 
     import Control.Concurrent
    46 
    -import Data.Array.Unboxed
    46 
    +import Control.Monad
    47 
    +import Data.Array.Base
    48 
    +import Data.Array.IO.Internals
    49 
    +import Data.Functor
    47 50 
     import Foreign.Ptr
    48 51 
     import GHC.Exts
    49 52
    ... ... @@ -62,15 +65,18 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix
    62 65 
                (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
    63 66 
       -- fromIntegral Word -> Word64 should be a no op if Word is Word64
    64 67 
       -- otherwise it will result in a cast to longlong on 32bit systems.
    65 
    -  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0)
    66 
    -  ptrs <- mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0)
    67 
    -  let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
    68 
    +  litsMut <- unsafeNewArray_ (0, fromIntegral (sizeFlatBag lits0) - 1)
    69 
    +  foldM_ (\(!i) lit -> (unsafeWrite litsMut i =<< lookupLiteral interp pkgs_loaded bytecode_state lit) $> succ i) 0 lits0
    70 
    +  lits <- unsafeFreezeIOUArray litsMut
    71 
    +  ptrsMut <- newSmallArrayIO (fromIntegral (sizeFlatBag ptrs0)) undefined
    72 
    +  foldM_ (\(!i) ptr -> (writeSmallArrayIO ptrsMut i =<< resolvePtr interp pkgs_loaded bytecode_state bco_ix ptr) $> succ i) 0 ptrs0
    73 
    +  ptrs <- unsafeFreezeSmallArrayIO ptrsMut
    68 74 
       return $ ResolvedBCO { resolvedBCOIsLE   = isLittleEndian
    69 75 
                            , resolvedBCOArity  = arity
    70 76 
                            , resolvedBCOInstrs = insns
    71 77 
                            , resolvedBCOBitmap = bitmap
    72 
    -                       , resolvedBCOLits   = mkBCOByteArray lits'
    73 
    -                       , resolvedBCOPtrs   = addListToSS emptySS ptrs
    78 
    +                       , resolvedBCOLits   = mkBCOByteArray lits
    79 
    +                       , resolvedBCOPtrs   = ptrs
    74 80 
                            }
    75 81
    76 82 
     lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word

  • compiler/GHC/ByteCode/Serialize.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    1 2 
     {-# LANGUAGE MultiWayIf #-}
    2 3 
     {-# LANGUAGE RecordWildCards #-}
    3 4 
     -- Orphans are here since the Binary instances use an ad-hoc means of serialising
    ... ... @@ -20,7 +21,7 @@ module GHC.ByteCode.Serialize
    20 21 
     where
    21 22
    22 23 
     import Control.Monad
    23 
    -import Data.Binary qualified as Binary
    24 
    +import Data.ByteString.Short (ShortByteString(..))
    24 25 
     import Data.Foldable
    25 26 
     import Data.IORef
    26 27 
     import Data.Proxy
    ... ... @@ -320,19 +321,30 @@ instance Binary UnlinkedBCO where
    320 321 
         UnlinkedBCO
    321 322 
           <$> getViaBinName bh
    322 323 
           <*> get bh
    323 
    -      <*> (Binary.decode <$> get bh)
    324 
    -      <*> (Binary.decode <$> get bh)
    324 
    +      <*> get bh
    325 
    +      <*> get bh
    325 326 
           <*> get bh
    326 327 
           <*> get bh
    327 328
    328 329 
       put_ bh UnlinkedBCO {..} = do
    329 330 
         putViaBinName bh unlinkedBCOName
    330 331 
         put_ bh unlinkedBCOArity
    331 
    -    put_ bh $ Binary.encode unlinkedBCOInstrs
    332 
    -    put_ bh $ Binary.encode unlinkedBCOBitmap
    332 
    +    put_ bh unlinkedBCOInstrs
    333 
    +    put_ bh unlinkedBCOBitmap
    333 334 
         put_ bh unlinkedBCOLits
    334 335 
         put_ bh unlinkedBCOPtrs
    335 336
    337 
    +-- Also see Note [BCOByteArray serialization]. This instance is unlike
    338 
    +-- the `Binary` instances in `ghci`, which are for the `Binary` class
    339 
    +-- in `binary` and are used across host/target platforms; here this
    340 
    +-- instance is only used on the host for bytecode object serialization
    341 
    +-- and doesn't cross host/target boundary. Therefore it's safe to
    342 
    +-- serialize the underlying buffer directly.
    343 
    +instance Binary (BCOByteArray a) where
    344 
    +  put_ bh (BCOByteArray ba#) = put_ bh $ SBS ba#
    345 
    +
    346 
    +  get bh = (\(SBS ba#) -> BCOByteArray ba#) <$> get bh
    347 
    +
    336 348 
     instance Binary BCOPtr where
    337 349 
       get bh = do
    338 350 
         t <- getByte bh

  • compiler/GHC/Utils/Binary.hs
    ... ... @@ -132,6 +132,7 @@ import GHC.Data.FastMutInt
    132 132 
     import GHC.Utils.Fingerprint
    133 133 
     import GHC.Types.SrcLoc
    134 134 
     import GHC.Types.Unique
    135 
    +import GHC.Data.SmallArray
    135 136 
     import qualified GHC.Data.Strict as Strict
    136 137 
     import GHC.Utils.Outputable( JoinPointHood(..) )
    137 138 
     import GHCi.FFI
    ... ... @@ -975,6 +976,15 @@ instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
    975 976 
             xs <- get bh
    976 977 
             return $ listArray bounds xs
    977 978
    979 
    +instance Binary a => Binary (SmallArray a) where
    980 
    +    put_ bh sa = do
    981 
    +        put_ bh $ sizeofSmallArray sa
    982 
    +        mapSmallArrayM_ (put_ bh) sa
    983 
    +
    984 
    +    get bh = do
    985 
    +        n <- get bh
    986 
    +        replicateSmallArrayIO n $ get bh
    987 
    +
    978 988 
     instance (Binary a, Binary b) => Binary (a,b) where
    979 989 
         put_ bh (a,b) = do put_ bh a; put_ bh b
    980 990 
         get bh        = do a <- get bh

  • compiler/ghc.cabal.in
    ... ... @@ -461,7 +461,6 @@ Library
    461 461 
             GHC.Data.OrdList
    462 462 
             GHC.Data.OsPath
    463 463 
             GHC.Data.Pair
    464 
    -        GHC.Data.SmallArray
    465 464 
             GHC.Data.Stream
    466 465 
             GHC.Data.Strict
    467 466 
             GHC.Data.StringBuffer

  • compiler/GHC/Data/SmallArray.hs → libraries/ghc-boot/GHC/Data/SmallArray.hs
    1 1 
     {-# LANGUAGE MagicHash #-}
    2 2 
     {-# LANGUAGE UnboxedTuples #-}
    3 3 
     {-# LANGUAGE BlockArguments #-}
    4 
    +{-# LANGUAGE ImplicitPrelude #-}
    5 
    +{-# OPTIONS_GHC -Wno-name-shadowing #-}
    4 6
    5 7 
     -- | Small-array
    6 8 
     module GHC.Data.SmallArray
    ... ... @@ -13,8 +15,14 @@ module GHC.Data.SmallArray
    13 15 
       , indexSmallArray
    14 16 
       , sizeofSmallArray
    15 17 
       , listToArray
    18 
    +  , smallArrayFromList
    19 
    +  , smallArrayToList
    16 20 
       , mapSmallArray
    17 21 
       , foldMapSmallArray
    22 
    +  , replicateSmallArrayIO
    23 
    +  , mapSmallArrayIO
    24 
    +  , mapSmallArrayM_
    25 
    +  , imapSmallArrayM_
    18 26 
       , rnfSmallArray
    19 27
    20 28 
       -- * IO Operations
    ... ... @@ -26,12 +34,13 @@ module GHC.Data.SmallArray
    26 34 
     where
    27 35
    28 36 
     import GHC.Exts
    29 
    -import GHC.Prelude
    30 37 
     import GHC.IO
    31 38 
     import GHC.ST
    32 
    -import GHC.Utils.Binary
    33 39 
     import Control.DeepSeq
    40 
    +import Control.Monad
    41 
    +import Data.Binary
    34 42 
     import Data.Foldable
    43 
    +import Data.List (unfoldr)
    35 44
    36 45 
     data SmallArray a = SmallArray (SmallArray# a)
    37 46
    ... ... @@ -39,6 +48,17 @@ data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)
    39 48
    40 49 
     type SmallMutableArrayIO a = SmallMutableArray RealWorld a
    41 50
    51 
    +instance Binary a => Binary (SmallArray a) where
    52 
    +  put sa = put (sizeofSmallArray sa) *> foldMapSmallArray put sa
    53 
    +
    54 
    +  get = do
    55 
    +    n <- get
    56 
    +    smallArrayFromList <$> replicateM n get
    57 
    +
    58 
    +
    59 
    +instance Show a => Show (SmallArray a) where
    60 
    +  showsPrec p = showsPrec p . smallArrayToList
    61 
    +
    42 62 
     newSmallArray
    43 63 
       :: Int  -- ^ size
    44 64 
       -> a    -- ^ initial contents
    ... ... @@ -142,6 +162,45 @@ foldMapSmallArray f sa = go 0
    142 162 
           | i < n = f (indexSmallArray sa i) `mappend` go (i + 1)
    143 163 
           | otherwise = mempty
    144 164
    165 
    +-- | Execute the 'IO' action the given number of times and store the
    166 
    +-- results in a 'SmallArray'.
    167 
    +{-# INLINE replicateSmallArrayIO #-}
    168 
    +replicateSmallArrayIO :: Int -> IO a -> IO (SmallArray a)
    169 
    +replicateSmallArrayIO n m = do
    170 
    +  arr <- newSmallArrayIO n undefined
    171 
    +  let go i
    172 
    +        | i < n = do
    173 
    +            writeSmallArrayIO arr i =<< m
    174 
    +            go $ succ i
    175 
    +        | otherwise = pure ()
    176 
    +  go 0
    177 
    +  unsafeFreezeSmallArrayIO arr
    178 
    +
    179 
    +-- | Apply the 'IO' action to every element, producing a new
    180 
    +-- 'SmallArray'.
    181 
    +{-# INLINE mapSmallArrayIO #-}
    182 
    +mapSmallArrayIO :: (a -> IO b) -> SmallArray a -> IO (SmallArray b)
    183 
    +mapSmallArrayIO f sa = do
    184 
    +  ma <- newSmallArrayIO (sizeofSmallArray sa) undefined
    185 
    +  flip imapSmallArrayM_ sa $ \i v -> writeSmallArrayIO ma i =<< f v
    186 
    +  unsafeFreezeSmallArrayIO ma
    187 
    +
    188 
    +-- | Apply the monadic action to every element, ignoring the results.
    189 
    +{-# INLINE mapSmallArrayM_ #-}
    190 
    +mapSmallArrayM_ :: Applicative f => (a -> f b) -> SmallArray a -> f ()
    191 
    +mapSmallArrayM_ f = imapSmallArrayM_ (\_ v -> f v)
    192 
    +
    193 
    +-- | Apply the monadic action to every element and its index, ignoring
    194 
    +-- the results.
    195 
    +{-# INLINE imapSmallArrayM_ #-}
    196 
    +imapSmallArrayM_ :: Applicative f => (Int -> a -> f b) -> SmallArray a -> f ()
    197 
    +imapSmallArrayM_ f sa = go 0
    198 
    +  where
    199 
    +    n = sizeofSmallArray sa
    200 
    +    go i
    201 
    +      | i < n = f i (indexSmallArray sa i) *> go (succ i)
    202 
    +      | otherwise = pure ()
    203 
    +
    145 204 
     -- | Force the elements of the given 'SmallArray'
    146 205 
     --
    147 206 
     rnfSmallArray :: NFData a => SmallArray a -> ()
    ... ... @@ -169,16 +228,27 @@ listToArray (I# size) index_of value_of xs = runST $ ST \s ->
    169 228 
           s'' -> case unsafeFreezeSmallArray# ma s'' of
    170 229 
             (# s''', a #) -> (# s''', SmallArray a #)
    171 230
    172 
    -instance (Binary a) => Binary (SmallArray a) where
    173 
    -  get bh = do
    174 
    -    len <- get bh
    175 
    -    ma <- newSmallArrayIO len undefined
    176 
    -    for_ [0 .. len - 1] $ \i -> do
    177 
    -      a <- get bh
    178 
    -      writeSmallArrayIO ma i a
    179 
    -    unsafeFreezeSmallArrayIO ma
    180 
    -
    181 
    -  put_ bh sa = do
    182 
    -    let len = sizeofSmallArray sa
    183 
    -    put_ bh len
    184 
    -    for_ [0 .. len - 1] $ \i -> put_ bh $ sa `indexSmallArray` i
    231 
    +-- | Construct a 'SmallArray' from a list. This is different from
    232 
    +-- 'listToArray' since the list elements fill the 'SmallArray'
    233 
    +-- sequentially without recalculating the indices or remapping to
    234 
    +-- other element types.
    235 
    +{-# INLINE smallArrayFromList #-}
    236 
    +smallArrayFromList :: [a] -> SmallArray a
    237 
    +smallArrayFromList vs = runST $ ST $ \s0 ->
    238 
    +  case newSmallArray (length vs) undefined s0 of
    239 
    +    (# s1, ma #) ->
    240 
    +      case foldlM (\i v -> ST $ \s0 ->
    241 
    +        case writeSmallArray ma i v s0 of
    242 
    +          s1 -> (# s1, succ i #)) 0 vs of
    243 
    +            ST m -> case m s1 of
    244 
    +              (# s2, _ #) -> unsafeFreezeSmallArray ma s2
    245 
    +
    246 
    +-- | Construct a list from a 'SmallArray'.
    247 
    +{-# INLINE smallArrayToList #-}
    248 
    +smallArrayToList :: SmallArray a -> [a]
    249 
    +smallArrayToList sa = unfoldr go 0
    250 
    +  where
    251 
    +    n = sizeofSmallArray sa
    252 
    +    go i
    253 
    +      | i < n = Just (indexSmallArray sa i, succ i)
    254 
    +      | otherwise = Nothing

  • libraries/ghc-boot/ghc-boot.cabal.in
    ... ... @@ -45,7 +45,7 @@ Flag bootstrap
    45 45 
             Manual: True
    46 46
    47 47 
     Library
    48 
    -    default-language: Haskell2010
    48 
    +    default-language: GHC2024
    49 49 
         other-extensions: DeriveGeneric, RankNTypes, ScopedTypeVariables
    50 50 
         default-extensions: NoImplicitPrelude
    51 51
    ... ... @@ -53,6 +53,7 @@ Library
    53 53 
                 GHC.BaseDir
    54 54 
                 GHC.Data.ShortText
    55 55 
                 GHC.Data.SizedSeq
    56 
    +            GHC.Data.SmallArray
    56 57 
                 GHC.Utils.Encoding
    57 58 
                 GHC.Utils.Encoding.UTF8
    58 59 
                 GHC.LanguageExtensions

  • libraries/ghci/GHCi/CreateBCO.hs
    ... ... @@ -18,10 +18,9 @@ import Prelude -- See note [Why do we import Prelude here?]
    18 18 
     import GHCi.ResolvedBCO
    19 19 
     import GHCi.RemoteTypes
    20 20 
     import GHCi.BreakArray
    21 
    -import GHC.Data.SizedSeq
    21 
    +import GHC.Data.SmallArray
    22 22
    23 23 
     import System.IO (fixIO)
    24 
    -import Control.Monad
    25 24 
     import Data.Array.Base
    26 25 
     import Foreign hiding (newArray)
    27 26 
     import Unsafe.Coerce (unsafeCoerce)
    ... ... @@ -72,9 +71,6 @@ createBCO arr bco
    72 71 
     linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
    73 72 
     linkBCO' arr ResolvedBCO{..} = do
    74 73 
       let
    75 
    -      ptrs   = ssElts resolvedBCOPtrs
    76 
    -      n_ptrs = sizeSS resolvedBCOPtrs
    77 
    -
    78 74 
           !(I# arity#)  = resolvedBCOArity
    79 75
    80 76 
           !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
    ... ... @@ -83,7 +79,7 @@ linkBCO' arr ResolvedBCO{..} = do
    83 79 
           bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap)
    84 80 
           literals_barr = barr (getBCOByteArray resolvedBCOLits)
    85 81
    86 
    -  PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
    82 
    +  PtrsArr marr <- mkPtrsArray arr resolvedBCOPtrs
    87 83 
       IO $ \s ->
    88 84 
         case unsafeFreezeArray# marr s of { (# s, arr #) ->
    89 85 
         case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
    ... ... @@ -92,24 +88,25 @@ linkBCO' arr ResolvedBCO{..} = do
    92 88
    93 89
    94 90 
     -- we recursively link any sub-BCOs while making the ptrs array
    95 
    -mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
    96 
    -mkPtrsArray arr n_ptrs ptrs = do
    97 
    -  marr <- newPtrsArray (fromIntegral n_ptrs)
    91 
    +mkPtrsArray :: Array Int HValue -> SmallArray ResolvedBCOPtr -> IO PtrsArr
    92 
    +mkPtrsArray arr ptrs = do
    93 
    +  let n_ptrs = sizeofSmallArray ptrs
    94 
    +  marr <- newPtrsArray n_ptrs
    98 95 
       let
    99 
    -    fill (ResolvedBCORef n) i =
    96 
    +    fill i (ResolvedBCORef n) =
    100 97 
           writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
    101 
    -    fill (ResolvedBCOPtr r) i = do
    98 
    +    fill i (ResolvedBCOPtr r) = do
    102 99 
           hv <- localRef r
    103 100 
           writePtrsArrayHValue i hv marr
    104 
    -    fill (ResolvedBCOStaticPtr r) i = do
    101 
    +    fill i (ResolvedBCOStaticPtr r) = do
    105 102 
           writePtrsArrayPtr i (fromRemotePtr r)  marr
    106 
    -    fill (ResolvedBCOPtrBCO bco) i = do
    103 
    +    fill i (ResolvedBCOPtrBCO bco) = do
    107 104 
           bco <- linkBCO' arr bco
    108 105 
           writePtrsArrayBCO i bco marr
    109 
    -    fill (ResolvedBCOPtrBreakArray r) i = do
    106 
    +    fill i (ResolvedBCOPtrBreakArray r) = do
    110 107 
           BA mba <- localRef r
    111 108 
           writePtrsArrayMBA i mba marr
    112 
    -  zipWithM_ fill ptrs [0..]
    109 
    +  imapSmallArrayM_ fill ptrs
    113 110 
       return marr
    114 111
    115 112 
     data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)

  • libraries/ghci/GHCi/ResolvedBCO.hs
    ... ... @@ -12,7 +12,7 @@ module GHCi.ResolvedBCO
    12 12 
     #include "MachDeps.h"
    13 13
    14 14 
     import Prelude -- See note [Why do we import Prelude here?]
    15 
    -import GHC.Data.SizedSeq
    15 
    +import GHC.Data.SmallArray
    16 16 
     import GHCi.RemoteTypes
    17 17 
     import GHCi.BreakArray
    18 18
    ... ... @@ -51,13 +51,13 @@ isLittleEndian = True
    51 51 
     --
    52 52 
     data ResolvedBCO
    53 53 
        = ResolvedBCO {
    54 
    -        resolvedBCOIsLE   :: Bool,
    54 
    +        resolvedBCOIsLE   :: !Bool,
    55 55 
             resolvedBCOArity  :: {-# UNPACK #-} !Int,
    56 
    -        resolvedBCOInstrs :: BCOByteArray Word16,       -- ^ insns
    57 
    -        resolvedBCOBitmap :: BCOByteArray Word,         -- ^ bitmap
    58 
    -        resolvedBCOLits   :: BCOByteArray Word,
    56 
    +        resolvedBCOInstrs :: !(BCOByteArray Word16),       -- ^ insns
    57 
    +        resolvedBCOBitmap :: !(BCOByteArray Word),         -- ^ bitmap
    58 
    +        resolvedBCOLits   :: !(BCOByteArray Word),
    59 59 
               -- ^ non-ptrs - subword sized entries still take up a full (host) word
    60 
    -        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ^ ptrs
    60 
    +        resolvedBCOPtrs   :: !(SmallArray ResolvedBCOPtr)  -- ^ ptrs
    61 61 
        }
    62 62 
        deriving (Generic, Show)
    63 63

  • testsuite/tests/count-deps/CountDepsAst.stdout
    ... ... @@ -76,7 +76,6 @@ GHC.Data.Maybe
    76 76 
     GHC.Data.OrdList
    77 77 
     GHC.Data.OsPath
    78 78 
     GHC.Data.Pair
    79 
    -GHC.Data.SmallArray
    80 79 
     GHC.Data.Strict
    81 80 
     GHC.Data.StringBuffer
    82 81 
     GHC.Data.TrieMap

  • testsuite/tests/count-deps/CountDepsParser.stdout
    ... ... @@ -77,7 +77,6 @@ GHC.Data.Maybe
    77 77 
     GHC.Data.OrdList
    78 78 
     GHC.Data.OsPath
    79 79 
     GHC.Data.Pair
    80 
    -GHC.Data.SmallArray
    81 80 
     GHC.Data.Strict
    82 81 
     GHC.Data.StringBuffer
    83 82 
     GHC.Data.TrieMap

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