base 4.2.0.1 → 4.2.0.2

raw patch · 10 files changed

+73/−56 lines, 10 files

Files

• Control/Concurrent.hs +5/−2
• Control/Concurrent/SampleVar.hs +17/−13
• GHC/Conc.lhs +16/−12
• GHC/IO/Exception.hs +1/−1
• GHC/IO/Handle.hs +2/−3
• GHC/IO/Handle/Internals.hs +17/−10
• GHC/IO/Handle/Text.hs +1/−1
• System/Posix/Internals.hs +2/−2
• base.cabal +1/−1
• include/HsBaseConfig.h +11/−11

@@ -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

@@ -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. --

@@ -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, () #)

@@ -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

@@ -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.

@@ -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'

@@ -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

@@ -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

@@ -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

@@ -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 */