Erik de Castro Lopo pushed to branch wip/fix-9809 at Glasgow Haskell Compiler / GHC

Commits:

29 changed files:

Changes:

  • changelog.d/T28002
    1 
    +section: compiler
    2 
    +issues: #28002
    3 
    +mrs: !16841
    4 
    +synopsis:
    5 
    +  Use ``ShortByteString`` in the ``Serialized`` type instead of ``[Word8]``
    6 
    +description:
    7 
    +  ``GHC.Serialized.Serialized`` now uses ``ByteString`` to store serialized data.
    8 
    +  This makes in-memory representation more compact.

  • changelog.d/T28002-api
    1 
    +section: ghc-lib
    2 
    +issues: #28002
    3 
    +mrs: !16841
    4 
    +synopsis:
    5 
    +  Use ``ShortByteString`` in the ``Serialized`` type instead of ``[Word8]``
    6 
    +description:
    7 
    +  Breaking change: All functions that previously handled annotations in ``[Word8]``
    8 
    +  form now use ``ShortByteString``. The following definitions have modified types:
    9 
    +  * ``GHC.findGlobalAnns``
    10 
    +  * ``GHC.Tc.Gen.Splice.getAnnotationsByTypeRep``
    11 
    +  * ``GHC.Core.Opt.Monad.getAnnotations``
    12 
    +  * ``GHC.Core.Opt.Monad.getFirstAnnotations``
    13 
    +  * ``GHC.Types.Annotations.deserializeAnns``
    14 
    +  * ``GHC.Types.Annotations.findAnns``
    15 
    +  * ``GHC.Types.Annotations.findAnnsByTypeRep``
    16 
    +  * ``GHC.Serialized.Serialized``
    17 
    +  * ``GHC.Serialized.toSerialized``
    18 
    +  * ``GHC.Serialized.fromSerialized``
    19 
    +  * ``GHC.Serialized.serializeWithData``
    20 
    +  * ``GHC.Serialized.deserializeWithData``
    21 
    +  * ``GHCi.Message.ReifyAnnotations``

  • changelog.d/T9809-timer-manager-contention
    1 
    +section: ghc-internal
    2 
    +synopsis: Fix excessive GC, memory use and timer latency when many threads
    3 
    +  register timeouts at once with ``threadDelay``, ``registerDelay`` or
    4 
    +  ``System.Timeout.timeout``.
    5 
    +issues: #9809
    6 
    +mrs: !16863
    7 
    +description: {
    8 
    +    Threads registering timeouts now publish only fully evaluated updates to
    9 
    +    the timer manager's timeout queue, using a compare-and-swap loop, instead
    10 
    +    of building chains of unevaluated updates that other threads then had to
    11 
    +    evaluate or block on.
    12 
    +}

  • changelog.d/ncg-x86-subword-popcnt
    1 
    +section: compiler
    2 
    +synopsis: The x86 native code generator now emits shorter code for 8-bit and
    3 
    +  16-bit ``popCount`` when :ghc-flag:`-msse4.2` is enabled.
    4 
    +mrs: !16640
    5 
    +issues: #24813

  • compiler/GHC.hs
    ... ... @@ -453,12 +453,12 @@ import qualified GHC.Unit.Home.Graph as HUG
    453 453 
     import Control.Applicative ((<|>))
    454 454 
     import Control.Monad
    455 455 
     import Control.Monad.Catch as MC
    456 
    +import Data.ByteString.Short (ShortByteString)
    456 457 
     import Data.Foldable
    457 458 
     import Data.Function ((&))
    458 459 
     import Data.IORef
    459 460 
     import Data.List (isPrefixOf)
    460 461 
     import Data.Typeable    ( Typeable )
    461 
    -import Data.Word        ( Word8 )
    462 462
    463 463 
     import qualified Data.Map.Strict as Map
    464 464 
     import Data.Set (Set)
    ... ... @@ -1526,7 +1526,7 @@ lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
    1526 1526 
     lookupGlobalName name = withSession $ \hsc_env -> do
    1527 1527 
        liftIO $ lookupType hsc_env name
    1528 1528
    1529 
    -findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
    1529 
    +findGlobalAnns :: (GhcMonad m, Typeable a) => (ShortByteString -> a) -> AnnTarget Name -> m [a]
    1530 1530 
     findGlobalAnns deserialize target = withSession $ \hsc_env -> do
    1531 1531 
         ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
    1532 1532 
         return (findAnns deserialize ann_env target)

  • compiler/GHC/CmmToAsm/X86/CodeGen.hs
    ... ... @@ -6739,20 +6739,23 @@ genPopCnt bid width dst src = do
    6739 6739
    6740 6740 
         True -> do
    6741 6741 
           code_src <- getAnyReg src
    6742 
    -      src_r <- getNewRegNat format
    6742 
    +      -- Sub-word popcounts use 32-bit POPCNT, whose write zero-extends the
    6743 
    +      -- result to the full register.
    6744 
    +      src_r <- getNewRegNat (max II32 format)
    6743 6745 
           let dst_r = getRegisterReg platform  (CmmLocal dst)
    6746 
    +          -- A sub-word argument is a full Word# whose upper bits may be
    6747 
    +          -- dirty, so zero-extend it unless it visibly already is.
    6748 
    +          zx_src
    6749 
    +            | CmmMachOp (MO_UU_Conv from _) [_] <- src, from <= width
    6750 
    +            = nilOL
    6751 
    +            | otherwise
    6752 
    +            = unitOL (MOVZxL format (OpReg src_r) (OpReg src_r))
    6744 6753 
           return $ code_src src_r `appOL`
    6745 
    -          (if width == W8 then
    6746 
    -               -- The POPCNT instruction doesn't take a r/m8
    6747 
    -               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`
    6748 
    -               unitOL (POPCNT II16 (OpReg src_r) dst_r)
    6749 
    -           else
    6750 
    -               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`
    6751 6754 
               (if width == W8 || width == W16 then
    6752 
    -               -- We used a 16-bit destination register above,
    6753 
    -               -- so zero-extend
    6754 
    -               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
    6755 
    -           else nilOL)
    6755 
    +               zx_src `appOL`
    6756 
    +               unitOL (POPCNT II32 (OpReg src_r) dst_r)
    6757 
    +           else
    6758 
    +               unitOL (POPCNT format (OpReg src_r) dst_r))
    6756 6759
    6757 6760 
         False ->
    6758 6761 
           -- generate C call to hs_popcntN in ghc-prim

  • compiler/GHC/Core/Opt/Monad.hs
    ... ... @@ -68,9 +68,9 @@ import GHC.Unit.Module.ModGuts
    68 68 
     import GHC.Unit.External
    69 69
    70 70 
     import Data.Bifunctor ( bimap )
    71 
    +import Data.ByteString.Short ( ShortByteString )
    71 72 
     import Data.Dynamic
    72 73 
     import Data.Maybe (listToMaybe)
    73 
    -import Data.Word
    74 74 
     import Control.Monad
    75 75 
     import Control.Applicative ( Alternative(..) )
    76 76
    ... ... @@ -323,14 +323,14 @@ get_eps = do
    323 323 
     -- annotations.
    324 324 
     --
    325 325 
     -- See Note [Annotations]
    326 
    -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    326 
    +getAnnotations :: Typeable a => (ShortByteString -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    327 327 
     getAnnotations deserialize guts = do
    328 328 
          hsc_env <- getHscEnv
    329 329 
          ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
    330 330 
          return (deserializeAnns deserialize ann_env)
    331 331
    332 332 
     -- | Get at most one annotation of a given type per annotatable item.
    333 
    -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
    333 
    +getFirstAnnotations :: Typeable a => (ShortByteString -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
    334 334 
     getFirstAnnotations deserialize guts
    335 335 
       = bimap mod name <$> getAnnotations deserialize guts
    336 336 
       where

  • compiler/GHC/Tc/Gen/Splice.hs
    ... ... @@ -155,10 +155,10 @@ import Control.DeepSeq
    155 155 
     import Control.Monad
    156 156 
     import Data.Binary
    157 157 
     import Data.Binary.Get
    158 
    +import Data.ByteString.Short (ShortByteString)
    158 159 
     import Data.Containers.ListUtils ( nubOrd )
    159 160 
     import Data.List ( sortBy )
    160 161 
     import Data.Maybe
    161 
    -import qualified Data.ByteString as B
    162 162 
     import qualified Data.ByteString.Lazy as LB
    163 163 
     import Data.Dynamic  ( fromDynamic, toDyn )
    164 164 
     import qualified Data.IntMap as IntMap
    ... ... @@ -1947,7 +1947,7 @@ handleTHMessage msg = case msg of
    1947 1947 
       ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts
    1948 1948 
       ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n
    1949 1949 
       ReifyAnnotations lookup tyrep ->
    1950 
    -    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
    1950 
    +    wrapTHResult $ getAnnotationsByTypeRep lookup tyrep
    1951 1951 
       ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m
    1952 1952 
       ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm
    1953 1953 
       GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot
    ... ... @@ -1967,7 +1967,7 @@ handleTHMessage msg = case msg of
    1967 1967 
       FailIfErrs -> wrapTHResult failIfErrsM
    1968 1968 
       _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
    1969 1969
    1970 
    -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
    1970 
    +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [ShortByteString]
    1971 1971 
     getAnnotationsByTypeRep th_name tyrep
    1972 1972 
       = do { name <- lookupThAnnLookup th_name
    1973 1973 
            ; topEnv <- getTopEnv

  • compiler/GHC/Types/Annotations.hs
    ... ... @@ -27,9 +27,9 @@ import GHC.Utils.Outputable
    27 27 
     import GHC.Serialized
    28 28
    29 29 
     import Control.Monad
    30 
    +import Data.ByteString.Short ( ShortByteString )
    30 31 
     import Data.Maybe
    31 32 
     import Data.Typeable
    32 
    -import Data.Word        ( Word8 )
    33 33 
     import Control.DeepSeq
    34 34
    35 35 
     -- | Represents an annotation after it has been sufficiently desugared from
    ... ... @@ -112,14 +112,14 @@ plusAnnEnv a b =
    112 112 
     -- | Find the annotations attached to the given target as 'Typeable'
    113 113 
     --   values of your choice. If no deserializer is specified,
    114 114 
     --   only transient annotations will be returned.
    115 
    -findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
    115 
    +findAnns :: Typeable a => (ShortByteString -> a) -> AnnEnv -> CoreAnnTarget -> [a]
    116 116 
     findAnns deserialize env
    117 117 
       = mapMaybe (fromSerialized deserialize) . findAnnPayloads env
    118 118
    119 119 
     -- | Find the annotations attached to the given target as 'Typeable'
    120 120 
     --   values of your choice. If no deserializer is specified,
    121 121 
     --   only transient annotations will be returned.
    122 
    -findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
    122 
    +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [ShortByteString]
    123 123 
     findAnnsByTypeRep env target tyrep
    124 124 
       = [ ws | Serialized tyrep' ws <- findAnnPayloads env target
    125 125 
         , tyrep' == tyrep ]
    ... ... @@ -134,7 +134,7 @@ findAnnPayloads env target =
    134 134 
     -- | Deserialize all annotations of a given type. This happens lazily, that is
    135 135 
     --   no deserialization will take place until the [a] is actually demanded and
    136 136 
     --   the [a] can also be empty (the UniqFM is not filtered).
    137 
    -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
    137 
    +deserializeAnns :: Typeable a => (ShortByteString -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
    138 138 
     deserializeAnns deserialize env
    139 139 
       = ( mapModuleEnv deserAnns (ann_mod_env env)
    140 140 
         , mapNameEnv deserAnns (ann_name_env env)

  • compiler/GHC/Utils/Outputable.hs
    ... ... @@ -138,6 +138,7 @@ import GHC.Utils.Misc (lastMaybe, snocView)
    138 138
    139 139 
     import Data.ByteString (ByteString)
    140 140 
     import qualified Data.ByteString as BS
    141 
    +import qualified Data.ByteString.Short as Short
    141 142 
     import Data.Char
    142 143 
     import qualified Data.Map as M
    143 144 
     import Data.Int
    ... ... @@ -1105,7 +1106,7 @@ instance Outputable a => Outputable (SCC a) where
    1105 1106 
        ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
    1106 1107
    1107 1108 
     instance Outputable Serialized where
    1108 
    -    ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type)
    1109 
    +    ppr (Serialized the_type bytes) = int (Short.length bytes) <+> text "of type" <+> text (show the_type)
    1109 1110
    1110 1111 
     instance Outputable Extension where
    1111 1112 
         ppr = text . show

  • libraries/base/tests/.gitignore
    ... ... @@ -275,4 +275,5 @@
    275 275 
     /weak001
    276 276 
     /T9395
    277 277 
     /T9532
    278 
    +/T9809
    278 279 
     /T11555

  • libraries/base/tests/T9809.hs
    1 
    +-- #9809: when many threads registered timeouts at the same time, the
    2 
    +-- TimerManager published unevaluated timeout queues with atomicModifyIORef'.
    3 
    +-- The threads then built long chains of thunks and blocked on each other's
    4 
    +-- black holes, and the heap grew to hundreds of megabytes. all.T runs this
    5 
    +-- test with a heap limit that the old code exceeded.
    6 
    +
    7 
    +import Control.Concurrent
    8 
    +import Control.Monad
    9 
    +import Data.IORef
    10 
    +import GHC.Conc (TVar, atomically, newTVarIO, readTVar, registerDelay, retry, writeTVar)
    11 
    +
    12 
    +main :: IO ()
    13 
    +main = do
    14 
    +    let n = 100000
    15 
    +    ref <- newIORef []
    16 
    +    registered <- newTVarIO (0 :: Int)
    17 
    +    replicateM_ n . forkIO $ do
    18 
    +        tv <- registerDelay 10
    19 
    +        atomicModifyIORef' ref (\tvs -> (tv : tvs, ()))
    20 
    +        atomically $ readTVar registered >>= writeTVar registered . (+ 1)
    21 
    +    atomically $ do
    22 
    +        r <- readTVar registered
    23 
    +        when (r /= n) retry
    24 
    +    readIORef ref >>= mapM_ waitFor
    25 
    +
    26 
    +-- | Block until a delay has fired, so that the test also checks that the
    27 
    +-- TimerManager fires every timeout.
    28 
    +waitFor :: TVar Bool -> IO ()
    29 
    +waitFor tv = atomically $ readTVar tv >>= \fired -> unless fired retry

  • libraries/base/tests/all.T
    ... ... @@ -193,6 +193,12 @@ test('T7653', [when(opsys('mingw32'), skip),
    193 193 
                    omit_ways(prof_ways + ghci_ways)], compile_and_run, [''])
    194 194 
     test('T7787', normal, compile_and_run, [''])
    195 195
    196 
    +# Before the fix for #9809 this needed more than 256MB of heap.
    197 
    +test('T9809', [req_ghc_smp,
    198 
    +               req_target_smp,
    199 
    +               only_ways(['threaded1', 'threaded2', 'nonmoving_thr'])],
    200 
    +               compile_and_run, ['-threaded -with-rtsopts="-N2 -M128m"'])
    201 
    +
    196 202 
     test('topHandler01', [when(opsys('mingw32'), skip), js_broken(22261), req_process], compile_and_run, [''])
    197 203 
     test('topHandler02',
    198 204 
          [when(opsys('mingw32'), skip),

  • libraries/ghc-boot/GHC/Serialized.hs
    ... ... @@ -19,144 +19,68 @@ module GHC.Serialized (
    19 19 
       ) where
    20 20
    21 21 
     import Prelude -- See note [Why do we import Prelude here?]
    22 
    -import Data.Bits
    23 
    -import Data.Word        ( Word8 )
    24 
    -import Data.Data
    25 22 
     import Control.DeepSeq
    23 
    +import Data.Binary
    24 
    +import Data.Binary.Get
    25 
    +import Data.Binary.Put
    26 
    +import Data.ByteString.Short (ShortByteString)
    27 
    +import qualified Data.ByteString.Short as Short
    28 
    +import qualified Data.ByteString.Lazy as ByteString.Lazy
    29 
    +import Data.Data
    26 30
    27 31
    28 32 
     -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
    29 
    -data Serialized = Serialized TypeRep [Word8]
    33 
    +data Serialized = Serialized TypeRep ShortByteString
    30 34
    31 35 
     instance NFData Serialized where
    32 36 
       rnf (Serialized tr ws) = rnf tr `seq` rnf ws
    33 37
    34 38 
     -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
    35 
    -toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
    39 
    +toSerialized :: forall a. Typeable a => (a -> ShortByteString) -> a -> Serialized
    36 40 
     toSerialized serialize what = Serialized (typeOf what) (serialize what)
    37 41
    38 42 
     -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
    39 43 
     -- Otherwise return @Nothing@.
    40 
    -fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
    44 
    +fromSerialized :: forall a. Typeable a => (ShortByteString -> a) -> Serialized -> Maybe a
    41 45 
     fromSerialized deserialize (Serialized the_type bytes)
    42 46 
       | the_type == rep = Just (deserialize bytes)
    43 47 
       | otherwise       = Nothing
    44 48 
       where rep = typeRep (Proxy :: Proxy a)
    45 49
    46 50 
     -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
    47 
    -serializeWithData :: Data a => a -> [Word8]
    48 
    -serializeWithData what = serializeWithData' what []
    49 
    -
    50 
    -serializeWithData' :: Data a => a -> [Word8] -> [Word8]
    51 
    -serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a))
    52 
    -                                       (\x -> (serializeConstr (constrRep (toConstr what)), x))
    53 
    -                                       what
    51 
    +serializeWithData :: Data a => a -> ShortByteString
    52 
    +serializeWithData = Short.toShort . ByteString.Lazy.toStrict . runPut . putData
    54 53
    55 54 
     -- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData'
    56 
    -deserializeWithData :: Data a => [Word8] -> a
    57 
    -deserializeWithData = snd . deserializeWithData'
    58 
    -
    59 
    -deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a)
    60 
    -deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes ->
    61 
    -                             gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b))
    62 
    -                                     (\x -> (bytes, x))
    63 
    -                                     (repConstr (dataTypeOf (undefined :: a)) constr_rep)
    64 
    -
    65 
    -
    66 
    -serializeConstr :: ConstrRep -> [Word8] -> [Word8]
    67 
    -serializeConstr (AlgConstr ix)   = serializeWord8 1 . serializeInt ix
    68 
    -serializeConstr (IntConstr i)    = serializeWord8 2 . serializeInteger i
    69 
    -serializeConstr (FloatConstr r)  = serializeWord8 3 . serializeRational r
    70 
    -serializeConstr (CharConstr c)   = serializeWord8 4 . serializeChar c
    71 
    -
    72 
    -
    73 
    -deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a
    74 
    -deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
    75 
    -                            case constr_ix of
    76 
    -                                1 -> deserializeInt      bytes $ \ix -> k (AlgConstr ix)
    77 
    -                                2 -> deserializeInteger  bytes $ \i  -> k (IntConstr i)
    78 
    -                                3 -> deserializeRational bytes $ \r  -> k (FloatConstr r)
    79 
    -                                4 -> deserializeChar     bytes $ \c  -> k (CharConstr c)
    80 
    -                                x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
    81 
    -
    82 
    -
    83 
    -serializeFixedWidthNum :: forall a. (Integral a, FiniteBits a) => a -> [Word8] -> [Word8]
    84 
    -serializeFixedWidthNum what = go (finiteBitSize what) what
    85 
    -  where
    86 
    -    go :: Int -> a -> [Word8] -> [Word8]
    87 
    -    go size current rest
    88 
    -      | size <= 0 = rest
    89 
    -      | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
    90 
    -
    91 
    -deserializeFixedWidthNum :: forall a b. (Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b
    92 
    -deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k
    93 
    -  where
    94 
    -    go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
    95 
    -    go size bytes k
    96 
    -      | size <= 0 = k 0 bytes
    97 
    -      | otherwise = case bytes of
    98 
    -                        (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte))
    99 
    -                        []           -> error "deserializeFixedWidthNum: unexpected end of stream"
    100 
    -
    101 
    -
    102 
    -serializeEnum :: (Enum a) => a -> [Word8] -> [Word8]
    103 
    -serializeEnum = serializeInt . fromEnum
    104 
    -
    105 
    -deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b
    106 
    -deserializeEnum bytes k = deserializeInt bytes (k . toEnum)
    107 
    -
    108 
    -
    109 
    -serializeWord8 :: Word8 -> [Word8] -> [Word8]
    110 
    -serializeWord8 x = (x:)
    111 
    -
    112 
    -deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a
    113 
    -deserializeWord8 (byte:bytes) k = k byte bytes
    114 
    -deserializeWord8 []           _ = error "deserializeWord8: unexpected end of stream"
    115 
    -
    116 
    -
    117 
    -serializeInt :: Int -> [Word8] -> [Word8]
    118 
    -serializeInt = serializeFixedWidthNum
    119 
    -
    120 
    -deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a
    121 
    -deserializeInt = deserializeFixedWidthNum
    122 
    -
    123 
    -
    124 
    -serializeRational :: (Real a) => a -> [Word8] -> [Word8]
    125 
    -serializeRational = serializeString . show . toRational
    126 
    -
    127 
    -deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b
    128 
    -deserializeRational bytes k = deserializeString bytes (k . fromRational . read)
    129 
    -
    130 
    -
    131 
    -serializeInteger :: Integer -> [Word8] -> [Word8]
    132 
    -serializeInteger = serializeString . show
    133 
    -
    134 
    -deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
    135 
    -deserializeInteger bytes k = deserializeString bytes (k . read)
    136 
    -
    137 
    -
    138 
    -serializeChar :: Char -> [Word8] -> [Word8]
    139 
    -serializeChar = serializeString . show
    140 
    -
    141 
    -deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a
    142 
    -deserializeChar bytes k = deserializeString bytes (k . read)
    143 
    -
    144 
    -
    145 
    -serializeString :: String -> [Word8] -> [Word8]
    146 
    -serializeString = serializeList serializeEnum
    147 
    -
    148 
    -deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a
    149 
    -deserializeString = deserializeList deserializeEnum
    150 
    -
    151 
    -
    152 
    -serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8]
    153 
    -serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs)
    154 
    -
    155 
    -deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c)
    156 
    -                -> [Word8] -> ([a] -> [Word8] -> b) -> b
    157 
    -deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k
    158 
    -  where
    159 
    -    go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b
    160 
    -    go len bytes k
    161 
    -      | len <= 0  = k [] bytes
    162 
    -      | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))
    55 
    +deserializeWithData :: Data a => ShortByteString -> a
    56 
    +deserializeWithData bs =
    57 
    +  case runGetOrFail getData (ByteString.Lazy.fromStrict (Short.fromShort bs)) of
    58 
    +    Right (_, _, x)    -> x
    59 
    +    Left (_, off, msg) ->
    60 
    +      error ("deserializeWithData: " ++ msg ++ " at offset " ++ show off)
    61 
    +
    62 
    +putData :: Data a => a -> Put
    63 
    +putData x = do
    64 
    +  putConstrRep (constrRep (toConstr x))
    65 
    +  sequence_ (gmapQ putData x)
    66 
    +
    67 
    +getData :: forall a. Data a => Get a
    68 
    +getData = do
    69 
    +  rep <- getConstrRep
    70 
    +  fromConstrM getData (repConstr (dataTypeOf (undefined :: a)) rep)
    71 
    +
    72 
    +putConstrRep :: ConstrRep -> Put
    73 
    +putConstrRep (AlgConstr ix)  = putWord8 1 >> put ix
    74 
    +putConstrRep (IntConstr i)   = putWord8 2 >> put i
    75 
    +putConstrRep (FloatConstr r) = putWord8 3 >> put r
    76 
    +putConstrRep (CharConstr c)  = putWord8 4 >> put c
    77 
    +
    78 
    +getConstrRep :: Get ConstrRep
    79 
    +getConstrRep = do
    80 
    +  tag <- getWord8
    81 
    +  case tag of
    82 
    +    1 -> AlgConstr   <$> get
    83 
    +    2 -> IntConstr   <$> get
    84 
    +    3 -> FloatConstr <$> get
    85 
    +    4 -> CharConstr  <$> get
    86 
    +    _ -> fail ("unrecognised constructor tag " ++ show tag)

  • libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs
    ... ... @@ -13,8 +13,10 @@ import GHC.Internal.Types ()
    13 13 
     {-# LANGUAGE CPP #-}
    14 14 
     {-# LANGUAGE ExistentialQuantification #-}
    15 15 
     {-# LANGUAGE FlexibleInstances #-}
    16 
    +{-# LANGUAGE MagicHash #-}
    16 17 
     {-# LANGUAGE NoImplicitPrelude #-}
    17 18 
     {-# LANGUAGE Trustworthy #-}
    19 
    +{-# LANGUAGE UnboxedTuples #-}
    18 20
    19 21 
     -- TODO: use the new Windows IO manager
    20 22 
     module GHC.Internal.Event.TimerManager
    ... ... @@ -53,6 +55,9 @@ import GHC.Internal.Control.Exception (finally)
    53 55 
     import GHC.Internal.Data.Foldable (sequence_)
    54 56 
     import GHC.Internal.Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
    55 57 
                        writeIORef)
    58 
    +import GHC.Internal.IORef (IORef(..))
    59 
    +import GHC.Internal.Prim (casMutVar#, readMutVar#)
    60 
    +import GHC.Internal.STRef (STRef(..))
    56 61 
     import GHC.Internal.Err (errorWithoutStackTrace)
    57 62 
     import GHC.Internal.Clock (getMonotonicTimeNSec)
    58 63 
     import GHC.Internal.Conc.Signal (runHandlers)
    ... ... @@ -260,7 +265,7 @@ updateTimeout mgr (TK key) us = do
    260 265
    261 266 
     editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
    262 267 
     editTimeouts mgr g = do
    263 
    -  wake <- atomicModifyIORef' (emTimeouts mgr) f
    268 
    +  wake <- modifyTimeouts (emTimeouts mgr) f
    264 269 
       when wake (wakeManager mgr)
    265 270 
       where
    266 271 
         f q = (q', wake)
    ... ... @@ -276,4 +281,75 @@ editTimeouts mgr g = do
    276 281 
                           t0 /= t1
    277 282 
                         _ -> True
    278 283
    284 
    +-- | Atomically replace the timeout queue with the first component of
    285 
    +-- @f old@ and return the second component.
    286 
    +--
    287 
    +-- Unlike 'atomicModifyIORef'', the new queue is evaluated /before/ it is
    288 
    +-- published, using a compare-and-swap loop. 'atomicModifyIORef'' installs
    289 
    +-- the new contents as a thunk and only evaluates it afterwards, so when many
    290 
    +-- threads register timeouts at once (#9809) each one builds its insert on
    291 
    +-- top of the previous thread's unevaluated insert, giving long thunk chains,
    292 
    +-- threads blocking on each other's half evaluated updates and lots of extra
    293 
    +-- GC work. Since 'Q.IntPSQ' is spine strict, WHNF means fully evaluated, and
    294 
    +-- other threads only ever see a fully evaluated queue.
    295 
    +--
    296 
    +-- The cost is that a thread whose compare-and-swap loses a race has to redo
    297 
    +-- its O(log n) update. The update runs in constant stack (see #7653).
    298 
    +--
    299 
    +-- Only the short edits made by registering threads use this. The timer
    300 
    +-- manager's own update in 'mkTimeout' (removing every expired timeout) can
    301 
    +-- take much longer, and under a stream of registrations from other
    302 
    +-- capabilities its compare-and-swap would almost never succeed, starving it
    303 
    +-- so that expired timeouts don't fire. It therefore keeps using
    304 
    +-- 'atomicModifyIORef'', which never retries: it publishes a single thunk and
    305 
    +-- evaluates it straight away. A registering thread that reads that thunk
    306 
    +-- evaluates it (or waits for the manager to) before publishing its own fully
    307 
    +-- evaluated queue, so thunks still cannot pile up.
    308 
    +--
    309 
    +-- 'casMutVar#' compares pointers, so the expected value must be exactly the
    310 
    +-- pointer read from the 'MutVar#'. See Note [Pointer equality in
    311 
    +-- modifyTimeouts] for why this function is OPAQUE.
    312 
    +{-# OPAQUE modifyTimeouts #-}
    313 
    +modifyTimeouts :: IORef TimeoutQueue -> (TimeoutQueue -> (TimeoutQueue, b)) -> IO b
    314 
    +modifyTimeouts (IORef (STRef ref)) f = IO modLoop
    315 
    +  where
    316 
    +    modLoop s0 = case readMutVar# ref s0 of
    317 
    +      (# s1, oldVar #) -> case f oldVar of
    318 
    +        (newVar, r) -> newVar `seq` case casMutVar# ref oldVar newVar s1 of
    319 
    +          (# s2, 0#, _ #) -> (# s2, r #)
    320 
    +          (# s2, _, _ #) -> modLoop s2
    321 
    +
    322 
    +{- Note [Pointer equality in modifyTimeouts]
    323 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    324 
    +'casMutVar#' succeeds only if the expected value is the very pointer stored
    325 
    +in the 'MutVar#', so all the difficulties of 'reallyUnsafePtrEquality#'
    326 
    +apply to it. In 'modifyTimeouts' the expected value is @oldVar@, exactly as
    327 
    +'readMutVar#' returned it, and that must survive optimisation.
    328 
    +
    329 
    +The danger is the optimiser seeing a @case@ on @oldVar@ in the same function
    330 
    +as the 'casMutVar#'. That would happen if 'modifyTimeouts' were inlined or
    331 
    +specialised at a call site, bringing in the body of @f@ (in 'editTimeouts',
    332 
    +@f@ inspects the queue to decide whether to wake the manager). The binder
    333 
    +swap (Note [Binder swap] in GHC.Core.Opt.OccurAnal) may then replace @oldVar@
    334 
    +by the case binder, which is the /evaluated/ queue. That is a different
    335 
    +pointer whenever the 'MutVar#' holds a thunk or an indirection, for example
    336 
    +the selector thunk that 'atomicModifyIORef'' in 'mkTimeout' leaves behind.
    337 
    +Case-of-known-constructor can likewise replace it by a freshly built
    338 
    +constructor. Either way the compare-and-swap would keep failing and the
    339 
    +registering thread would spin.
    340 
    +
    341 
    +The OPAQUE pragma keeps @f@ an unknown function inside 'modifyTimeouts', so
    342 
    +there is never a @case@ on @oldVar@ to rewrite. OPAQUE rather than NOINLINE:
    343 
    +both stop inlining and specialisation, but NOINLINE still allows the
    344 
    +worker/wrapper transformation. Today that is harmless (the worker only
    345 
    +unboxes the 'IORef' and still takes @f@ as an argument), but OPAQUE states
    346 
    +the requirement directly: the body must be compiled as written and every call
    347 
    +must go to it. It also costs nothing, since 'editTimeouts' passes a closure
    348 
    +anyway.
    349 
    +
    350 
    +An alternative is to hide the expected pointer in a box built by a NOINLINE
    351 
    +function before @f@ runs (like the @Ticket@ type of the atomic-primops
    352 
    +package), but that allocates on every attempt.
    353 
    +-}
    354 
    +
    279 355 
     #endif

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -297,7 +297,7 @@ data THMessage a where
    297 297 
       ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec])
    298 298 
       ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role])
    299 299 
       ReifyAnnotations :: TH.AnnLookup -> TypeRep
    300 
    -    -> THMessage (THResult [ByteString])
    300 
    +    -> THMessage (THResult [BS.ShortByteString])
    301 301 
       ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo)
    302 302 
       ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
    303 303

  • libraries/ghci/GHCi/TH.hs
    ... ... @@ -100,7 +100,6 @@ import Control.Monad.IO.Class (MonadIO (..))
    100 100 
     import Data.Binary
    101 101 
     import Data.Binary.Put
    102 102 
     import Data.ByteString (ByteString)
    103 
    -import qualified Data.ByteString as B
    104 103 
     import qualified Data.ByteString.Lazy as LB
    105 104 
     import Data.Data
    106 105 
     import Data.Dynamic
    ... ... @@ -169,7 +168,7 @@ instance MonadIO GHCiQ where
    169 168 
       -- serialize irrelevant annotations.
    170 169 
     reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
    171 170 
     reifyAnnotations lookup =
    172 
    -    map (deserializeWithData . B.unpack) <$>
    171 
    +    map deserializeWithData <$>
    173 172 
           ghcCmd (ReifyAnnotations lookup typerep)
    174 173 
         where typerep = typeOf (undefined :: a)
    175 174

  • libraries/ghci/GHCi/TH/Binary.hs
    ... ... @@ -9,7 +9,6 @@ module GHCi.TH.Binary () where
    9 9
    10 10 
     import Prelude -- See note [Why do we import Prelude here?]
    11 11 
     import Data.Binary
    12 
    -import qualified Data.ByteString as B
    13 12 
     import qualified Data.ByteString.Internal as B
    14 13 
     import GHC.Serialized
    15 14 
     import qualified GHC.Boot.TH.Syntax as TH
    ... ... @@ -74,8 +73,8 @@ instance Binary TH.DocLoc
    74 73 
     -- We need Binary TypeRep for serializing annotations
    75 74
    76 75 
     instance Binary Serialized where
    77 
    -    put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)
    78 
    -    get = Serialized <$> get <*> (B.unpack <$> get)
    76 
    +    put (Serialized tyrep wds) = put tyrep >> put wds
    77 
    +    get = Serialized <$> get <*> get
    79 78
    80 79 
     instance Binary TH.Bytes where
    81 80 
        put (TH.Bytes ptr off sz) = put bs

  • testsuite/tests/annotations/should_run/Makefile
    ... ... @@ -9,3 +9,7 @@ config :
    9 9 
     	echo "module Config where" >>$(CONFIG_HS)
    10 10 
     	echo "cTop          :: String" >> $(CONFIG_HS)
    11 11 
     	echo 'cTop          = "$(subst \,\\,$(shell '$(TEST_HC)' --print-libdir))"' >> $(CONFIG_HS)
    12 
    +
    13 
    +T16841:
    14 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c T16841.hs
    15 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface T16841.hi | grep 'annotated by'

  • testsuite/tests/annotations/should_run/T16841.hs
    1 
    +-- | Measures the overhead of serializing annotations of a few types.
    2 
    +module T16841 where
    3 
    +
    4 
    +foo :: Int
    5 
    +foo = 42
    6 
    +
    7 
    +{-# ANN foo (42 :: Int) #-}
    8 
    +{-# ANN foo (2^100 :: Integer) #-}
    9 
    +{-# ANN foo (3.25 :: Double) #-}
    10 
    +{-# ANN foo 'x' #-}
    11 
    +{-# ANN foo "helloworld" #-}
    12 
    +{-# ANN foo (Just True) #-}
    13 
    +{-# ANN foo ([1..100] :: [Int]) #-}
    14 
    +{-# ANN module (Left 7 :: Either Int String) #-}
    15 
    +

  • testsuite/tests/annotations/should_run/T16841.stdout
    1 
    +Module target T16841 annotated by 15 of type Either Int [Char]
    2 
    +Named target foo annotated by 1509 of type [Int]
    3 
    +Named target foo annotated by 18 of type Maybe Bool
    4 
    +Named target foo annotated by 119 of type [Char]
    5 
    +Named target foo annotated by 2 of type Char
    6 
    +Named target foo annotated by 11 of type Double
    7 
    +Named target foo annotated by 24 of type Integer
    8 
    +Named target foo annotated by 6 of type Int
    9 
    +

  • testsuite/tests/annotations/should_run/all.T
    ... ... @@ -16,6 +16,10 @@ test('annrun01',
    16 16 
          multimod_compile_and_run,
    17 17 
          ['annrun01', '-package ghc ' + config.ghc_th_way_flags])
    18 18
    19 
    +# Skipping on windows because of platform-specific failures.  See
    20 
    +# https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16841#note_706770
    21 
    +test('T16841', [req_th, windows_skip, extra_files(['T16841.hs'])], makefile_test, ['T16841'])
    22 
    +
    19 23 
     """"
    20 24 
     Helpful things to C+P:
    21 25

  • testsuite/tests/codeGen/should_gen_asm/T24813.asm
    1 
    +popcnt8:
    2 
    +        movzbl
    3 
    +        popcnt
    4 
    +        movq
    5 
    +        jmp
    6 
    +popcnt16:
    7 
    +        movzwl
    8 
    +        popcnt
    9 
    +        movq
    10 
    +        jmp

  • testsuite/tests/codeGen/should_gen_asm/T24813.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +// Popcount of a zero-extended sub-word value should be a single
    4 
    +// zero-extending load followed by one POPCNT (#24813).
    5 
    +
    6 
    +popcnt8 (W_ p) {
    7 
    +    W_ r;
    8 
    +    (r) = prim %popcnt8(%zx64(bits8[p]));
    9 
    +    return (r);
    10 
    +}
    11 
    +
    12 
    +popcnt16 (W_ p) {
    13 
    +    W_ r;
    14 
    +    (r) = prim %popcnt16(%zx64(bits16[p]));
    15 
    +    return (r);
    16 
    +}

  • testsuite/tests/codeGen/should_gen_asm/all.T
    ... ... @@ -27,6 +27,7 @@ test('T25233', [unless(arch('x86_64'), skip),
    27 27 
                     when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-O'])
    28 28 
     test('T25233b', [unless(arch('x86_64'), skip),
    29 29 
                      when(unregisterised(), skip)], compile_grep_asm, ['cmm', True, ''])
    30 
    +test('T24813', is_amd64_codegen, compile_cmp_asm, ['cmm', '-msse4.2'])
    30 31 
     is_aarch64_codegen = [
    31 32 
         unless(arch('aarch64'), skip),
    32 33 
         when(unregisterised(), skip),

  • testsuite/tests/plugins/T26761Plugin.hs
    ... ... @@ -7,6 +7,7 @@ import GHC
    7 7 
     import GHC.Plugins
    8 8 
     import GHC.Tc.Types
    9 9 
     import GHC.Tc.Utils.Monad
    10 
    +import qualified Data.ByteString.Short as Short
    10 11 
     import qualified Data.Map as Map
    11 12 
     import Data.Word (Word8)
    12 13 
     import System.IO (hFlush, stdout)
    ... ... @@ -38,5 +39,5 @@ plugin = defaultPlugin { typeCheckResultAction = typecheckPlugin }
    38 39 
           -- check that it is visible from other modules.
    39 40 
           let ann = Annotation
    40 41 
                       (ModuleTarget $ tcg_mod gblEnv)
    41 
    -                  (toSerialized id [0])
    42 
    +                  (toSerialized id (Short.pack [0]))
    42 43 
           return gblEnv { tcg_anns = ann : tcg_anns gblEnv }

  • testsuite/tests/plugins/all.T
    ... ... @@ -155,7 +155,7 @@ test('T14335',
    155 155 
            -fexternal-interpreter -package simple-plugin ' + config.plugin_way_flags])
    156 156
    157 157 
     test('T26761', [extra_files(['T26761Plugin.hs', 'T26761a.hs'])],
    158 
    -     multimod_compile, ['T26761', '-package ghc ' + config.plugin_way_flags ])
    158 
    +     multimod_compile, ['T26761', '-package ghc -package bytestring ' + config.plugin_way_flags ])
    159 159
    160 160 
     test('plugin-recomp-pure',
    161 161 
          [extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']),

  • testsuite/tests/rts/pause-resume/all.T
    ... ... @@ -14,6 +14,8 @@ test('pause_resume_via_safe_ffi_concurrent',
    14 14 
          [ only_ways(['threaded1', 'threaded2'])
    15 15 
          , req_c
    16 16 
          , extra_files(['pause_resume.c','pause_resume.h'])
    17 
    +     # Internal watchdog is 60s; give the harness room on loaded Darwin CI.
    18 
    +     , run_timeout_multiplier(2)
    17 19 
          ],
    18 20 
          multi_compile_and_run, ['pause_resume_via_safe_ffi_concurrent', [('pause_resume.c','')], ''])
    19 21 
     test('pause_and_use_rts_api',

  • testsuite/tests/rts/pause-resume/pause_resume_via_safe_ffi_concurrent.hs
    ... ... @@ -8,6 +8,7 @@ import Foreign.Marshal.Alloc
    8 8 
     import Foreign.Ptr
    9 9 
     import Foreign.Storable
    10 10 
     import System.Exit
    11 
    +import System.IO (hFlush, stdout)
    11 12 
     import System.Timeout
    12 13
    13 14 
     foreign import ccall safe "pause_resume.h pauseAndResume"
    ... ... @@ -38,11 +39,17 @@ main = do
    38 39 
             countPtr
    39 40 
           putMVar mvar ()
    40 41
    41 
    -    -- Wait (at least 2n seconds to be safe) for all threads to finish.
    42 
    -    result <- timeout (2 * n * 1000000) (mapM_ takeMVar mvars)
    42 
    +    -- Each pause holds the RTS for about a second, so n concurrent
    43 
    +    -- calls serialize to ~n seconds. 2n (10s) was enough on Linux but
    44 
    +    -- a false deadlock on Darwin CI: rts_pause waits for every
    45 
    +    -- capability, and the counter threads keep hitting the timer
    46 
    +    -- manager via threadDelay. Keep a watchdog so a real hang still
    47 
    +    -- fails, but give 60s of slack.
    48 
    +    result <- timeout (60 * 1000000) (mapM_ takeMVar mvars)
    43 49 
         case result of
    44 50 
           Nothing -> do
    45 51 
             putStrLn "Not all rts_pause/rts_resume threads have finished. Assuming deadlocked and failing test."
    52 
    +        hFlush stdout
    46 53 
             exitFailure
    47 54 
           Just () -> do
    48 55 
             putStrLn "All threads finished"

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/cb573bc9cae5f7b2618ac8f0f310daa892811bd3...bf2d932e3de9e778f5831c2d0a6117dc425ff15c at 1793186910