diff --git a/Data/Bits.hs b/Data/Bits.hs --- a/Data/Bits.hs +++ b/Data/Bits.hs @@ -515,8 +515,12 @@ complement = complementInteger shift x i@(I# i#) | i >= 0 = shiftLInteger x i# | otherwise = shiftRInteger x (negateInt# i#) - shiftL x (I# i#) = shiftLInteger x i# - shiftR x (I# i#) = shiftRInteger x i# + shiftL x i@(I# i#) + | i < 0 = error "Bits.shiftL(Integer): negative shift" + | otherwise = shiftLInteger x i# + shiftR x i@(I# i#) + | i < 0 = error "Bits.shiftR(Integer): negative shift" + | otherwise = shiftRInteger x i# testBit x (I# i) = testBitInteger x i diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs --- a/GHC/ForeignPtr.hs +++ b/GHC/ForeignPtr.hs @@ -250,12 +250,19 @@ -- finalizer will run /before/ all other finalizers for the same -- object which have already been registered. addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of - PlainForeignPtr r -> f r >> return () - MallocPtr _ r -> f r >> return () + PlainForeignPtr r -> insertCFinalizer r fp 0# nullAddr# p () + MallocPtr _ r -> insertCFinalizer r fp 0# nullAddr# p c _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" - where - f r = insertCFinalizer r fp 0# nullAddr# p +-- Note [MallocPtr finalizers] (#10904) +-- +-- When we have C finalizers for a MallocPtr, the memory is +-- heap-resident and would normally be recovered by the GC before the +-- finalizers run. To prevent the memory from being reused too early, +-- we attach the MallocPtr constructor to the "value" field of the +-- weak pointer when we call mkWeak# in ensureCFinalizerWeak below. +-- The GC will keep this field alive until the finalizers have run. + addForeignPtrFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO () -- ^ Like 'addForeignPtrFinalizerEnv' but allows the finalizer to be @@ -263,11 +270,9 @@ -- finalizer. The environment passed to the finalizer is fixed by the -- second argument to 'addForeignPtrFinalizerEnv' addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of - PlainForeignPtr r -> f r >> return () - MallocPtr _ r -> f r >> return () + PlainForeignPtr r -> insertCFinalizer r fp 1# ep p () + MallocPtr _ r -> insertCFinalizer r fp 1# ep p c _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" - where - f r = insertCFinalizer r fp 1# ep p addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO () -- ^This function adds a finalizer to the given @ForeignPtr@. The @@ -319,9 +324,9 @@ data MyWeak = MyWeak (Weak# ()) insertCFinalizer :: - IORef Finalizers -> Addr# -> Int# -> Addr# -> Addr# -> IO () -insertCFinalizer r fp flag ep p = do - MyWeak w <- ensureCFinalizerWeak r + IORef Finalizers -> Addr# -> Int# -> Addr# -> Addr# -> value -> IO () +insertCFinalizer r fp flag ep p val = do + MyWeak w <- ensureCFinalizerWeak r val IO $ \s -> case addCFinalizerToWeak# fp p flag ep w s of (# s1, 1# #) -> (# s1, () #) @@ -329,16 +334,17 @@ -- has finalized w by calling foreignPtrFinalizer. We retry now. -- This won't be an infinite loop because that thread must have -- replaced the content of r before calling finalizeWeak#. - (# s1, _ #) -> unIO (insertCFinalizer r fp flag ep p) s1 + (# s1, _ #) -> unIO (insertCFinalizer r fp flag ep p val) s1 -ensureCFinalizerWeak :: IORef Finalizers -> IO MyWeak -ensureCFinalizerWeak ref@(IORef (STRef r#)) = do +ensureCFinalizerWeak :: IORef Finalizers -> value -> IO MyWeak +ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do fin <- readIORef ref case fin of CFinalizers weak -> return (MyWeak weak) HaskellFinalizers{} -> noMixingError NoFinalizers -> IO $ \s -> - case mkWeakNoFinalizer# r# () s of { (# s1, w #) -> + case mkWeakNoFinalizer# r# (unsafeCoerce# value) s of { (# s1, w #) -> + -- See Note [MallocPtr finalizers] (#10904) case atomicModifyMutVar# r# (update w) s1 of { (# s2, (weak, needKill ) #) -> if needKill diff --git a/GHC/IO.hs b/GHC/IO.hs --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -436,8 +436,9 @@ mask io = do b <- getMaskingState case b of - Unmasked -> block $ io unblock - _ -> io id + Unmasked -> block $ io unblock + MaskedInterruptible -> io block + MaskedUninterruptible -> io blockUninterruptible uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io @@ -446,7 +447,7 @@ case b of Unmasked -> blockUninterruptible $ io unblock MaskedInterruptible -> blockUninterruptible $ io block - MaskedUninterruptible -> io id + MaskedUninterruptible -> io blockUninterruptible bracket :: IO a -- ^ computation to run first (\"acquire resource\") diff --git a/GHC/List.hs b/GHC/List.hs --- a/GHC/List.hs +++ b/GHC/List.hs @@ -355,9 +355,11 @@ -- and thus must be applied to non-empty lists. foldr1 :: (a -> a -> a) -> [a] -> a -foldr1 _ [x] = x -foldr1 f (x:xs) = f x (foldr1 f xs) -foldr1 _ [] = errorEmptyList "foldr1" +foldr1 f = go + where go [x] = x + go (x:xs) = f x (go xs) + go [] = errorEmptyList "foldr1" +{-# INLINE [0] foldr1 #-} -- | 'scanr' is the right-to-left dual of 'scanl'. -- Note that diff --git a/GHC/RTS/Flags.hsc b/GHC/RTS/Flags.hsc --- a/GHC/RTS/Flags.hsc +++ b/GHC/RTS/Flags.hsc @@ -9,13 +9,19 @@ -- @since 4.8.0.0 -- module GHC.RTS.Flags - ( RTSFlags (..) + ( RtsTime + , RtsNat + , RTSFlags (..) + , GiveGCStats (..) , GCFlags (..) , ConcFlags (..) , MiscFlags (..) , DebugFlags (..) + , DoCostCentres (..) , CCFlags (..) + , DoHeapProfile (..) , ProfFlags (..) + , DoTrace (..) , TraceFlags (..) , TickyFlags (..) , getRTSFlags @@ -48,11 +54,19 @@ import GHC.Word -- | @'Time'@ is defined as a @'StgWord64'@ in @stg/Types.h@ -type Time = Word64 +-- +-- @since 4.8.2.0 +type RtsTime = Word64 -- | @'nat'@ defined in @rts/Types.h@ -type Nat = #{type unsigned int} +-- +-- @since 4.8.2.0 +type RtsNat = #{type unsigned int} +-- | Should we produce a summary of the garbage collector statistics after the +-- program has exited? +-- +-- @since 4.8.2.0 data GiveGCStats = NoGCStats | CollectGCStats @@ -75,22 +89,25 @@ toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats toEnum e = error ("invalid enum for GiveGCStats: " ++ show e) +-- | Parameters of the garbage collector. +-- +-- @since 4.8.0.0 data GCFlags = GCFlags { statsFile :: Maybe FilePath , giveStats :: GiveGCStats - , maxStkSize :: Nat - , initialStkSize :: Nat - , stkChunkSize :: Nat - , stkChunkBufferSize :: Nat - , maxHeapSize :: Nat - , minAllocAreaSize :: Nat - , minOldGenSize :: Nat - , heapSizeSuggestion :: Nat + , maxStkSize :: RtsNat + , initialStkSize :: RtsNat + , stkChunkSize :: RtsNat + , stkChunkBufferSize :: RtsNat + , maxHeapSize :: RtsNat + , minAllocAreaSize :: RtsNat + , minOldGenSize :: RtsNat + , heapSizeSuggestion :: RtsNat , heapSizeSuggestionAuto :: Bool , oldGenFactor :: Double , pcFreeHeap :: Double - , generations :: Nat - , steps :: Nat + , generations :: RtsNat + , steps :: RtsNat , squeezeUpdFrames :: Bool , compact :: Bool -- ^ True <=> "compact all the time" , compactThreshold :: Double @@ -98,19 +115,25 @@ -- ^ use "mostly mark-sweep" instead of copying for the oldest generation , ringBell :: Bool , frontpanel :: Bool - , idleGCDelayTime :: Time + , idleGCDelayTime :: RtsTime , doIdleGC :: Bool , heapBase :: Word -- ^ address to ask the OS for memory , allocLimitGrace :: Word } deriving (Show) +-- | Parameters concerning context switching +-- +-- @since 4.8.0.0 data ConcFlags = ConcFlags - { ctxtSwitchTime :: Time + { ctxtSwitchTime :: RtsTime , ctxtSwitchTicks :: Int } deriving (Show) +-- | Miscellaneous parameters +-- +-- @since 4.8.0.0 data MiscFlags = MiscFlags - { tickInterval :: Time + { tickInterval :: RtsTime , installSignalHandlers :: Bool , machineReadable :: Bool , linkerMemBase :: Word @@ -119,6 +142,8 @@ -- | Flags to control debugging output & extra checking in various -- subsystems. +-- +-- @since 4.8.0.0 data DebugFlags = DebugFlags { scheduler :: Bool -- ^ 's' , interpreter :: Bool -- ^ 'i' @@ -137,6 +162,9 @@ , sparks :: Bool -- ^ 'r' } deriving (Show) +-- | Should the RTS produce a cost-center summary? +-- +-- @since 4.8.2.0 data DoCostCentres = CostCentresNone | CostCentresSummary @@ -159,12 +187,18 @@ toEnum #{const COST_CENTRES_XML} = CostCentresXML toEnum e = error ("invalid enum for DoCostCentres: " ++ show e) +-- | Parameters pertaining to the cost-center profiler. +-- +-- @since 4.8.0.0 data CCFlags = CCFlags { doCostCentres :: DoCostCentres , profilerTicks :: Int , msecsPerTick :: Int } deriving (Show) +-- | What sort of heap profile are we collecting? +-- +-- @since 4.8.2.0 data DoHeapProfile = NoHeapProfiling | HeapByCCS @@ -196,10 +230,13 @@ toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType toEnum e = error ("invalid enum for DoHeapProfile: " ++ show e) +-- | Parameters of the cost-center profiler +-- +-- @since 4.8.0.0 data ProfFlags = ProfFlags { doHeapProfile :: DoHeapProfile - , heapProfileInterval :: Time -- ^ time between samples - , heapProfileIntervalTicks :: Word -- ^ ticks between samples (derived) + , heapProfileInterval :: RtsTime -- ^ time between samples + , heapProfileIntervalTicks :: Word -- ^ ticks between samples (derived) , includeTSOs :: Bool , showCCSOnException :: Bool , maxRetainerSetSize :: Word @@ -213,10 +250,13 @@ , bioSelector :: Maybe String } deriving (Show) +-- | Is event tracing enabled? +-- +-- @since 4.8.2.0 data DoTrace - = TraceNone - | TraceEventLog - | TraceStderr + = TraceNone -- ^ no tracing + | TraceEventLog -- ^ send tracing events to the event log + | TraceStderr -- ^ send tracing events to @stderr@ deriving (Show) instance Enum DoTrace where @@ -229,6 +269,9 @@ toEnum #{const TRACE_STDERR} = TraceStderr toEnum e = error ("invalid enum for DoTrace: " ++ show e) +-- | Parameters pertaining to event tracing +-- +-- @since 4.8.0.0 data TraceFlags = TraceFlags { tracing :: DoTrace , timestamp :: Bool -- ^ show timestamp in stderr output @@ -239,11 +282,17 @@ , user :: Bool -- ^ trace user events (emitted from Haskell code) } deriving (Show) +-- | Parameters pertaining to ticky-ticky profiler +-- +-- @since 4.8.0.0 data TickyFlags = TickyFlags { showTickyStats :: Bool , tickyFile :: Maybe FilePath } deriving (Show) +-- | Parameters of the runtime system +-- +-- @since 4.8.0.0 data RTSFlags = RTSFlags { gcFlags :: GCFlags , concurrentFlags :: ConcFlags @@ -305,7 +354,7 @@ ptr <- getGcFlagsPtr GCFlags <$> (peekFilePath =<< #{peek GC_FLAGS, statsFile} ptr) <*> (toEnum . fromIntegral <$> - (#{peek GC_FLAGS, giveStats} ptr :: IO Nat)) + (#{peek GC_FLAGS, giveStats} ptr :: IO RtsNat)) <*> #{peek GC_FLAGS, maxStkSize} ptr <*> #{peek GC_FLAGS, initialStkSize} ptr <*> #{peek GC_FLAGS, stkChunkSize} ptr @@ -367,7 +416,7 @@ getCCFlags = do ptr <- getCcFlagsPtr CCFlags <$> (toEnum . fromIntegral - <$> (#{peek COST_CENTRE_FLAGS, doCostCentres} ptr :: IO Nat)) + <$> (#{peek COST_CENTRE_FLAGS, doCostCentres} ptr :: IO RtsNat)) <*> #{peek COST_CENTRE_FLAGS, profilerTicks} ptr <*> #{peek COST_CENTRE_FLAGS, msecsPerTick} ptr diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,5 +1,5 @@ name: base -version: 4.8.1.0 +version: 4.8.2.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,15 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.8.2.0 *Oct 2015* + + * Bundled with GHC 7.10.3 + + * The restore operation provided by `mask` and `uninterruptibleMask` now + restores the previous masking state whatever the current masking state is. + + * Exported `GiveGCStats`, `DoCostCentres`, `DoHeapProfile`, `DoTrace`, + `RtsTime`, and `RtsNat` from `GHC.RTS.Flags` + ## 4.8.1.0 *Jul 2015* * Bundled with GHC 7.10.2