diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -430,7 +430,10 @@ if bound then do mv <- newEmptyMVar - _ <- forkIO (Exception.try action >>= putMVar mv) + b <- blocked + _ <- block $ forkIO $ + Exception.try (if b then action else unblock action) >>= + putMVar mv takeMVar mv >>= \ei -> case ei of Left exception -> Exception.throw (exception :: SomeException) Right result -> return result @@ -479,7 +482,7 @@ withThread :: IO a -> IO a withThread io = do m <- newEmptyMVar - _ <- forkIO $ try io >>= putMVar m + _ <- block $ forkIO $ try io >>= putMVar m x <- takeMVar m case x of Right a -> return a diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs --- a/Control/Concurrent/SampleVar.hs +++ b/Control/Concurrent/SampleVar.hs @@ -30,6 +30,8 @@ import Control.Concurrent.MVar +import Control.Exception ( block ) + -- | -- Sample variables are slightly different from a normal 'MVar': -- @@ -66,41 +68,43 @@ -- |If the SampleVar is full, leave it empty. Otherwise, do nothing. emptySampleVar :: SampleVar a -> IO () -emptySampleVar v = do - (readers, var) <- takeMVar v +emptySampleVar v = block $ do + s@(readers, var) <- block $ takeMVar v if readers > 0 then do _ <- takeMVar var putMVar v (0,var) else - putMVar v (readers,var) + putMVar v s -- |Wait for a value to become available, then take it and return. readSampleVar :: SampleVar a -> IO a -readSampleVar svar = do +readSampleVar svar = block $ do -- -- filled => make empty and grab sample -- not filled => try to grab value, empty when read val. -- (readers,val) <- takeMVar svar - putMVar svar (readers-1,val) + let readers' = readers-1 + readers' `seq` putMVar svar (readers',val) takeMVar val -- |Write a value into the 'SampleVar', overwriting any previous value that -- was there. writeSampleVar :: SampleVar a -> a -> IO () -writeSampleVar svar v = do +writeSampleVar svar v = block $ do -- -- filled => overwrite -- not filled => fill, write val -- - (readers,val) <- takeMVar svar + s@(readers,val) <- takeMVar svar case readers of - 1 -> - swapMVar val v >> - putMVar svar (1,val) - _ -> - putMVar val v >> - putMVar svar (min 1 (readers+1), val) + 1 -> + swapMVar val v >> + putMVar svar s + _ -> + putMVar val v >> + let readers' = min 1 (readers+1) + in readers' `seq` putMVar svar (readers', val) -- | Returns 'True' if the 'SampleVar' is currently empty. -- diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -275,16 +275,11 @@ Just StackOverflow -> reportStackOverflow _ -> reportError se -{- | 'killThread' terminates the given thread (GHC only). -Any work already done by the thread isn\'t -lost: the computation is suspended until required by another thread. -The memory used by the thread will be garbage collected if it isn\'t -referenced from anywhere. The 'killThread' function is defined in -terms of 'throwTo': +{- | 'killThread' raises the 'ThreadKilled' exception in the given +thread (GHC only). > killThread tid = throwTo tid ThreadKilled -Killthread is a no-op if the target thread has already completed. -} killThread :: ThreadId -> IO () killThread tid = throwTo tid ThreadKilled @@ -299,6 +294,10 @@ can kill each other, it is guaranteed that only one of the threads will get to kill the other. +Whatever work the target thread was doing when the exception was +raised is not lost: the computation is suspended until required by +another thread. + If the target thread is currently making a foreign call, then the exception will not be raised (and hence 'throwTo' will not return) until the call has completed. This is the case regardless of whether @@ -313,12 +312,17 @@ Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of the paper). -There is currently no guarantee that the exception delivered by 'throwTo' will be -delivered at the first possible opportunity. In particular, a thread may -unblock and then re-block exceptions (using 'unblock' and 'block') without receiving -a pending 'throwTo'. This is arguably undesirable behaviour. +There is no guarantee that the exception will be delivered promptly, +although the runtime will endeavour to ensure that arbitrary +delays don't occur. In GHC, an exception can only be raised when a +thread reaches a /safe point/, where a safe point is where memory +allocation occurs. Some loops do not perform any memory allocation +inside the loop and therefore cannot be interrupted by a 'throwTo'. - -} +Blocked 'throwTo' is fair: if multiple threads are trying to throw an +exception to the same target thread, they will succeed in FIFO order. + + -} throwTo :: Exception e => ThreadId -> e -> IO () throwTo (ThreadId tid) ex = IO $ \ s -> case (killThread# tid (toException ex) s) of s1 -> (# s1, () #) diff --git a/GHC/IO/Exception.hs b/GHC/IO/Exception.hs --- a/GHC/IO/Exception.hs +++ b/GHC/IO/Exception.hs @@ -193,7 +193,7 @@ -- | The Haskell 98 type for exceptions in the 'IO' monad. -- Any I\/O operation may raise an 'IOError' instead of returning a result. -- For a more general type of exception, including also those that arise --- in pure code, see 'Control.Exception.Exception'. +-- in pure code, see "Control.Exception.Exception". -- -- In Haskell 98, this is an opaque type. type IOError = IOException diff --git a/GHC/IO/Handle.hs b/GHC/IO/Handle.hs --- a/GHC/IO/Handle.hs +++ b/GHC/IO/Handle.hs @@ -268,7 +268,7 @@ -- hSetEncoding :: Handle -> TextEncoding -> IO () hSetEncoding hdl encoding = do - withHandle "hSetEncoding" hdl $ \h_@Handle__{..} -> do + withAllHandles__ "hSetEncoding" hdl $ \h_@Handle__{..} -> do flushCharBuffer h_ openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do bbuf <- readIORef haByteBuffer @@ -276,8 +276,7 @@ return (Handle__{ haLastDecode = ref, haDecoder = mb_decoder, haEncoder = mb_encoder, - haCodec = Just encoding, .. }, - ()) + haCodec = Just encoding, .. }) -- | Return the current 'TextEncoding' for the specified 'Handle', or -- 'Nothing' if the 'Handle' is in binary mode. diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs --- a/GHC/IO/Handle/Internals.hs +++ b/GHC/IO/Handle/Internals.hs @@ -37,6 +37,7 @@ flushCharBuffer, flushByteReadBuffer, readTextDevice, writeTextDevice, readTextDeviceNonBlocking, + decodeByteBuf, augmentIOError, ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, @@ -785,22 +786,28 @@ readTextDeviceNonBlocking h_@Handle__{..} cbuf = do -- bbuf0 <- readIORef haByteBuffer - bbuf1 <- if not (isEmptyBuffer bbuf0) - then return bbuf0 - else do - (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0 - if isNothing r then ioe_EOF else do -- raise EOF - return bbuf1 + when (isEmptyBuffer bbuf0) $ do + (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0 + if isNothing r then ioe_EOF else do -- raise EOF + writeIORef haByteBuffer bbuf1 + decodeByteBuf h_ cbuf + +-- Decode bytes from the byte buffer into the supplied CharBuffer. +decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer +decodeByteBuf h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer + (bbuf2,cbuf') <- case haDecoder of Nothing -> do - writeIORef haLastDecode (error "codec_state", bbuf1) - latin1_decode bbuf1 cbuf + writeIORef haLastDecode (error "codec_state", bbuf0) + latin1_decode bbuf0 cbuf Just decoder -> do state <- getState decoder - writeIORef haLastDecode (state, bbuf1) - (encode decoder) bbuf1 cbuf + writeIORef haLastDecode (state, bbuf0) + (encode decoder) bbuf0 cbuf writeIORef haByteBuffer bbuf2 return cbuf' diff --git a/GHC/IO/Handle/Text.hs b/GHC/IO/Handle/Text.hs --- a/GHC/IO/Handle/Text.hs +++ b/GHC/IO/Handle/Text.hs @@ -89,7 +89,7 @@ return True else do -- there might be bytes in the byte buffer waiting to be decoded - cbuf' <- readTextDeviceNonBlocking handle_ cbuf + cbuf' <- decodeByteBuf handle_ cbuf writeIORef haCharBuffer cbuf' if not (isEmptyBuffer cbuf') then return True else do diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs --- a/System/Posix/Internals.hs +++ b/System/Posix/Internals.hs @@ -327,8 +327,8 @@ let flags' | set = flags .|. o_NONBLOCK | otherwise = flags .&. complement o_NONBLOCK unless (flags == flags') $ do - throwErrnoIfMinus1Retry_ "fcntl_write" $ - c_fcntl_write fd const_f_setfl (fromIntegral flags') + _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags') + return () #else -- bogus defns for win32 diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,5 +1,5 @@ name: base -version: 4.2.0.1 +version: 4.2.0.2 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org diff --git a/include/HsBaseConfig.h b/include/HsBaseConfig.h --- a/include/HsBaseConfig.h +++ b/include/HsBaseConfig.h @@ -425,7 +425,7 @@ #define HTYPE_CHAR Int8 /* Define to Haskell type for clock_t */ -#define HTYPE_CLOCK_T Int32 +#define HTYPE_CLOCK_T Int64 /* Define to Haskell type for dev_t */ #define HTYPE_DEV_T Word64 @@ -449,10 +449,10 @@ #define HTYPE_INTMAX_T Int64 /* Define to Haskell type for intptr_t */ -#define HTYPE_INTPTR_T Int32 +#define HTYPE_INTPTR_T Int64 /* Define to Haskell type for long */ -#define HTYPE_LONG Int32 +#define HTYPE_LONG Int64 /* Define to Haskell type for long long */ #define HTYPE_LONG_LONG Int64 @@ -461,7 +461,7 @@ #define HTYPE_MODE_T Word32 /* Define to Haskell type for nlink_t */ -#define HTYPE_NLINK_T Word32 +#define HTYPE_NLINK_T Word64 /* Define to Haskell type for off_t */ #define HTYPE_OFF_T Int64 @@ -470,7 +470,7 @@ #define HTYPE_PID_T Int32 /* Define to Haskell type for ptrdiff_t */ -#define HTYPE_PTRDIFF_T Int32 +#define HTYPE_PTRDIFF_T Int64 /* Define to Haskell type for rlim_t */ #define HTYPE_RLIM_T Word64 @@ -485,19 +485,19 @@ #define HTYPE_SIG_ATOMIC_T Int32 /* Define to Haskell type for size_t */ -#define HTYPE_SIZE_T Word32 +#define HTYPE_SIZE_T Word64 /* Define to Haskell type for speed_t */ #define HTYPE_SPEED_T Word32 /* Define to Haskell type for ssize_t */ -#define HTYPE_SSIZE_T Int32 +#define HTYPE_SSIZE_T Int64 /* Define to Haskell type for tcflag_t */ #define HTYPE_TCFLAG_T Word32 /* Define to Haskell type for time_t */ -#define HTYPE_TIME_T Int32 +#define HTYPE_TIME_T Int64 /* Define to Haskell type for uid_t */ #define HTYPE_UID_T Word32 @@ -506,7 +506,7 @@ #define HTYPE_UINTMAX_T Word64 /* Define to Haskell type for uintptr_t */ -#define HTYPE_UINTPTR_T Word32 +#define HTYPE_UINTPTR_T Word64 /* Define to Haskell type for unsigned char */ #define HTYPE_UNSIGNED_CHAR Word8 @@ -515,7 +515,7 @@ #define HTYPE_UNSIGNED_INT Word32 /* Define to Haskell type for unsigned long */ -#define HTYPE_UNSIGNED_LONG Word32 +#define HTYPE_UNSIGNED_LONG Word64 /* Define to Haskell type for unsigned long long */ #define HTYPE_UNSIGNED_LONG_LONG Word64 @@ -548,7 +548,7 @@ #define STDC_HEADERS 1 /* Number of bits in a file offset, on hosts where this is settable. */ -#define _FILE_OFFSET_BITS 64 +/* #undef _FILE_OFFSET_BITS */ /* Define for large files, on AIX-style hosts. */ /* #undef _LARGE_FILES */