diff --git a/Control/Arrow.hs b/Control/Arrow.hs --- a/Control/Arrow.hs +++ b/Control/Arrow.hs @@ -94,8 +94,6 @@ f &&& g = arr (\b -> (b,b)) >>> f *** g {-# RULES -"identity" - arr id = id "compose/arr" forall f g . (arr f) . (arr g) = arr (f . g) "first/arr" forall f . @@ -217,9 +215,9 @@ "fanin/arr" forall f g . arr f ||| arr g = arr (f ||| g) "compose/left" forall f g . - left f >>> left g = left (f >>> g) + left f . left g = left (f . g) "compose/right" forall f g . - right f >>> right g = right (f >>> g) + right f . right g = right (f . g) #-} instance ArrowChoice (->) where diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -525,7 +525,7 @@ The "System.IO" library manages multiplexing in its own way. On Windows systems it uses @safe@ foreign calls to ensure that threads doing I\/O operations don't block the whole runtime, - whereas on Unix systems all the currently blocked I\/O reqwests + whereas on Unix systems all the currently blocked I\/O requests are managed by a single thread (the /IO manager thread/) using @select@. diff --git a/Control/Exception.hs b/Control/Exception.hs --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -5,7 +5,7 @@ -- Module : Control.Exception -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (extended exceptions) @@ -25,6 +25,9 @@ -- * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton -- Jones, Andy Moran and John Reppy, in /PLDI'01/. -- +-- * /An Extensible Dynamically-Typed Hierarchy of Exceptions/, +-- by Simon Marlow, in /Haskell '06/. +-- ----------------------------------------------------------------------------- module Control.Exception ( @@ -47,7 +50,7 @@ NestedAtomically(..), #endif #ifdef __NHC__ - System.ExitCode(), -- instance Exception + System.ExitCode(), -- instance Exception #endif BlockedOnDeadMVar(..), @@ -61,38 +64,39 @@ ErrorCall(..), -- * Throwing exceptions - throwIO, -- :: Exception -> IO a - throw, -- :: Exception -> a - ioError, -- :: IOError -> IO a + throw, + throwIO, + ioError, #ifdef __GLASGOW_HASKELL__ - throwTo, -- :: ThreadId -> Exception -> a + throwTo, #endif -- * Catching Exceptions - -- |There are several functions for catching and examining - -- exceptions; all of them may only be used from within the - -- 'IO' monad. + -- $catching + -- ** Catching all exceptions + + -- $catchall + -- ** The @catch@ functions - catch, -- :: IO a -> (Exception -> IO a) -> IO a + catch, catches, Handler(..), - catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a + catchJust, -- ** The @handle@ functions - handle, -- :: (Exception -> IO a) -> IO a -> IO a - handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a + handle, + handleJust, -- ** The @try@ functions - try, -- :: IO a -> IO (Either Exception a) - tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a) - onException, + try, + tryJust, -- ** The @evaluate@ function - evaluate, -- :: a -> IO a + evaluate, -- ** The @mapException@ function - mapException, -- :: (Exception -> Exception) -> a -> a + mapException, -- * Asynchronous Exceptions @@ -103,9 +107,9 @@ -- |The following two functions allow a thread to control delivery of -- asynchronous exceptions during a critical region. - block, -- :: IO a -> IO a - unblock, -- :: IO a -> IO a - blocked, -- :: IO Bool + block, + unblock, + blocked, -- *** Applying @block@ to an exception handler @@ -117,15 +121,17 @@ -- * Assertions - assert, -- :: Bool -> a -> a + assert, -- * Utilities - bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO () - bracket_, -- :: IO a -> IO b -> IO c -> IO () + bracket, + bracket_, bracketOnError, - finally, -- :: IO a -> IO b -> IO a + finally, + onException, + ) where import Control.Exception.Base @@ -142,8 +148,27 @@ import System (ExitCode()) #endif +-- | You need this when using 'catches'. data Handler a = forall e . Exception e => Handler (e -> IO a) +{- | +Sometimes you want to catch two different sorts of exception. You could +do something like + +> f = expr `catch` \ (ex :: ArithException) -> handleArith ex +> `catch` \ (ex :: IOException) -> handleIO ex + +However, there are a couple of problems with this approach. The first is +that having two exception handlers is inefficient. However, the more +serious issue is that the second exception handler will catch exceptions +in the first, e.g. in the example above, if @handleArith@ throws an +@IOException@ then the second exception handler will catch it. + +Instead, we provide a function 'catches', which would be used thus: + +> f = expr `catches` [Handler (\ (ex :: ArithException) -> handleArith ex), +> Handler (\ (ex :: IOException) -> handleIO ex)] +-} catches :: IO a -> [Handler a] -> IO a catches io handlers = io `catch` catchesHandler handlers @@ -155,6 +180,45 @@ Nothing -> res -- ----------------------------------------------------------------------------- +-- Catching exceptions + +{- $catching + +There are several functions for catching and examining +exceptions; all of them may only be used from within the +'IO' monad. + +Here's a rule of thumb for deciding which catch-style function to +use: + + * If you want to do some cleanup in the event that an exception + is raised, use 'finally', 'bracket' or 'onException'. + + * To recover after an exception and do something else, the best + choice is to use one of the 'try' family. + + * ... unless you are recovering from an asynchronous exception, in which + case use 'catch' or 'catchJust'. + +The difference between using 'try' and 'catch' for recovery is that in +'catch' the handler is inside an implicit 'block' (see \"Asynchronous +Exceptions\") which is important when catching asynchronous +exceptions, but when catching other kinds of exception it is +unnecessary. Furthermore it is possible to accidentally stay inside +the implicit 'block' by tail-calling rather than returning from the +handler, which is why we recommend using 'try' rather than 'catch' for +ordinary exception recovery. + +A typical use of 'tryJust' for recovery looks like this: + +> do r <- tryJust (guard . isDoesNotExistError) $ getEnv "HOME" +> case r of +> Left e -> ... +> Right home -> ... + +-} + +-- ----------------------------------------------------------------------------- -- Asynchronous exceptions {- $async @@ -198,9 +262,8 @@ handler, just use 'unblock' as normal. Note that 'try' and friends /do not/ have a similar default, because -there is no exception handler in this case. If you want to use 'try' -in an asynchronous-exception-safe way, you will need to use -'block'. +there is no exception handler in this case. Don't use 'try' for +recovering from an asynchronous exception. -} {- $interruptible @@ -230,3 +293,47 @@ Similar arguments apply for other interruptible operations like 'System.IO.openFile'. -} + +{- $catchall + +It is possible to catch all exceptions, by using the type 'SomeException': + +> catch f (\e -> ... (e :: SomeException) ...) + +HOWEVER, this is normally not what you want to do! + +For example, suppose you want to read a file, but if it doesn't exist +then continue as if it contained \"\". You might be tempted to just +catch all exceptions and return \"\" in the handler. However, this has +all sorts of undesirable consequences. For example, if the user +presses control-C at just the right moment then the 'UserInterrupt' +exception will be caught, and the program will continue running under +the belief that the file contains \"\". Similarly, if another thread +tries to kill the thread reading the file then the 'ThreadKilled' +exception will be ignored. + +Instead, you should only catch exactly the exceptions that you really +want. In this case, this would likely be more specific than even +\"any IO exception\"; a permissions error would likely also want to be +handled differently. Instead, you would probably want something like: + +> e <- tryJust (guard . isDoesNotExistError) (readFile f) +> let str = either (const "") id e + +There are occassions when you really do need to catch any sort of +exception. However, in most cases this is just so you can do some +cleaning up; you aren't actually interested in the exception itself. +For example, if you open a file then you want to close it again, +whether processing the file executes normally or throws an exception. +However, in these cases you can use functions like 'bracket', 'finally' +and 'onException', which never actually pass you the exception, but +just call the cleanup functions at the appropriate points. + +But sometimes you really do need to catch any exception, and actually +see what the exception is. One example is at the very top-level of a +program, you may wish to catch any exception, print it to a logfile or +the screen, and then exit gracefully. For these cases, you can use +'catch' (or one of the other exception-catching functions) with the +'SomeException' type. +-} + diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -333,31 +333,35 @@ -- the \"handler\" is executed, with the value of the exception passed as an -- argument. Otherwise, the result is returned as normal. For example: -- --- > catch (openFile f ReadMode) --- > (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e)) +-- > catch (readFile f) +-- > (\e -> do let err = show (e :: IOException) +-- > hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err) +-- > return "") -- +-- Note that we have to give a type signature to @e@, or the program +-- will not typecheck as the type is ambiguous. While it is possible +-- to catch exceptions of any type, see $catchall for an explanation +-- of the problems with doing so. +-- -- For catching exceptions in pure (non-'IO') expressions, see the -- function 'evaluate'. -- -- Note that due to Haskell\'s unspecified evaluation order, an --- expression may return one of several possible exceptions: consider --- the expression @error \"urk\" + 1 \`div\` 0@. Does --- 'catch' execute the handler passing --- @ErrorCall \"urk\"@, or @ArithError DivideByZero@? --- --- The answer is \"either\": 'catch' makes a --- non-deterministic choice about which exception to catch. If you --- call it again, you might get a different exception back. This is --- ok, because 'catch' is an 'IO' computation. +-- expression may throw one of several possible exceptions: consider +-- the expression @(error \"urk\") + (1 \`div\` 0)@. Does +-- the expression throw +-- @ErrorCall \"urk\"@, or @DivideByZero@? -- --- Note that 'catch' catches all types of exceptions, and is generally --- used for \"cleaning up\" before passing on the exception using --- 'throwIO'. It is not good practice to discard the exception and --- continue, without first checking the type of the exception (it --- might be a 'ThreadKilled', for example). In this case it is usually better --- to use 'catchJust' and select the kinds of exceptions to catch. +-- The answer is \"it might throw either\"; the choice is +-- non-deterministic. If you are catching any type of exception then you +-- might catch either. If you are calling @catch@ with type +-- @IO Int -> (ArithException -> IO Int) -> IO Int@ then the handler may +-- get run with @DivideByZero@ as an argument, or an @ErrorCall \"urk\"@ +-- exception may be propogated further up. If you call it again, you +-- might get a the opposite behaviour. This is ok, because 'catch' is an +-- 'IO' computation. -- --- Also note that the "Prelude" also exports a function called +-- Note that the "Prelude" also exports a function called -- 'Prelude.catch' with a similar type to 'Control.Exception.catch', -- except that the "Prelude" version only catches the IO and user -- families of exceptions (as required by Haskell 98). @@ -392,11 +396,14 @@ -- argument which is an /exception predicate/, a function which -- selects which type of exceptions we\'re interested in. -- --- > result <- catchJust errorCalls thing_to_try handler +-- > catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing) +-- > (readFile f) +-- > (\_ -> do hPutStrLn stderr ("No such file: " ++ show f) +-- > return "") -- -- Any other exceptions which are not matched by the predicate -- are re-raised, and may be caught by an enclosing --- 'catch' or 'catchJust'. +-- 'catch', 'catchJust', etc. catchJust :: Exception e => (e -> Maybe b) -- ^ Predicate to select exceptions @@ -411,7 +418,7 @@ -- | A version of 'catch' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. For example: -- --- > do handle (\e -> exitWith (ExitFailure 1)) $ +-- > do handle (\NonTermination -> exitWith (ExitFailure 1)) $ -- > ... handle :: Exception e => (e -> IO a) -> IO a -> IO a handle = flip catch @@ -437,16 +444,14 @@ -- 'try' and variations. -- | Similar to 'catch', but returns an 'Either' result which is --- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an --- exception was raised and its value is @e@. +-- @('Right' a)@ if no exception of type @e@ was raised, or @('Left' ex)@ +-- if an exception of type @e@ was raised and its value is @ex@. +-- If any other type of exception is raised than it will be propogated +-- up to the next enclosing exception handler. -- -- > try a = catch (Right `liftM` a) (return . Left) -- --- Note: as with 'catch', it is only polite to use this variant if you intend --- to re-throw the exception after performing whatever cleanup is needed. --- Otherwise, 'tryJust' is generally considered to be better. --- --- Also note that "System.IO.Error" also exports a function called +-- Note that "System.IO.Error" also exports a function called -- 'System.IO.Error.try' with a similar type to 'Control.Exception.try', -- except that it catches only the IO and user families of exceptions -- (as required by the Haskell 98 @IO@ module). @@ -466,6 +471,8 @@ Nothing -> throw e Just b -> return (Left b) +-- | Like 'finally', but only performs the final action if there was an +-- exception raised by the computation. onException :: IO a -> IO b -> IO a onException io what = io `catch` \e -> do what throw (e :: SomeException) @@ -485,7 +492,7 @@ -- > bracket -- > (openFile "filename" ReadMode) -- > (hClose) --- > (\handle -> do { ... }) +-- > (\fileHandle -> do { ... }) -- -- The arguments to 'bracket' are in this order so that we can partially apply -- it, e.g.: @@ -526,7 +533,7 @@ bracket_ :: IO a -> IO b -> IO c -> IO c bracket_ before after thing = bracket before (const after) (const thing) --- | Like bracket, but only performs the final action if there was an +-- | Like 'bracket', but only performs the final action if there was an -- exception raised by the in-between computation. bracketOnError :: IO a -- ^ computation to run first (\"acquire resource\") @@ -548,6 +555,8 @@ ----- #if __GLASGOW_HASKELL__ || __HUGS__ +-- |A pattern match failed. The @String@ gives information about the +-- source location of the pattern. data PatternMatchFail = PatternMatchFail String INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail") @@ -565,6 +574,11 @@ ----- +-- |A record selector was applied to a constructor without the +-- appropriate field. This can only happen with a datatype with +-- multiple constructors, where some fields are in one constructor +-- but not another. The @String@ gives information about the source +-- location of the record selector. data RecSelError = RecSelError String INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError") @@ -582,6 +596,9 @@ ----- +-- |An uninitialised record field was used. The @String@ gives +-- information about the source location where the record was +-- constructed. data RecConError = RecConError String INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError") @@ -599,6 +616,11 @@ ----- +-- |A record update was performed on a constructor without the +-- appropriate field. This can only happen with a datatype with +-- multiple constructors, where some fields are in one constructor +-- but not another. The @String@ gives information about the source +-- location of the record update. data RecUpdError = RecUpdError String INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError") @@ -616,6 +638,9 @@ ----- +-- |A class method without a definition (neither a default definition, +-- nor a definition in the appropriate instance) was called. The +-- @String@ gives information about which method it was. data NoMethodError = NoMethodError String INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError") @@ -633,6 +658,10 @@ ----- +-- |Thrown when the runtime system detects that the computation is +-- guaranteed not to terminate. Note that there is no guarantee that +-- the runtime system will notice whether any given computation is +-- guaranteed to terminate or not. data NonTermination = NonTermination INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination") @@ -650,6 +679,8 @@ ----- +-- |Thrown when the program attempts to call @atomically@, from the @stm@ +-- package, inside another call to @atomically@. data NestedAtomically = NestedAtomically INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically") diff --git a/Control/OldException.hs b/Control/OldException.hs --- a/Control/OldException.hs +++ b/Control/OldException.hs @@ -727,7 +727,12 @@ Caster (\(New.PatternMatchFail err) -> PatternMatchFail err), Caster (\(New.RecConError err) -> RecConError err), Caster (\(New.RecSelError err) -> RecSelError err), - Caster (\(New.RecUpdError err) -> RecUpdError err)] + Caster (\(New.RecUpdError err) -> RecUpdError err), + -- Anything else gets taken as a Dynamic exception. It's + -- important that we put all exceptions into the old Exception + -- type somehow, or throwing a new exception wouldn't cause + -- the cleanup code for bracket, finally etc to happen. + Caster (\exc -> DynException (toDyn (exc :: New.SomeException)))] -- Unbundle exceptions. toException (ArithException exc) = toException exc @@ -738,7 +743,13 @@ toException BlockedIndefinitely = toException New.BlockedIndefinitely toException NestedAtomically = toException New.NestedAtomically toException Deadlock = toException New.Deadlock - toException (DynException exc) = toException exc + -- If a dynamic exception is a SomeException then resurrect it, so + -- that bracket, catch+throw etc rethrow the same exception even + -- when the exception is in the new style. + -- If it's not a SomeException, then just throw the Dynamic. + toException (DynException exc) = case fromDynamic exc of + Just exc' -> exc' + Nothing -> toException exc toException (ErrorCall err) = toException (New.ErrorCall err) toException (ExitException exc) = toException exc toException (IOException exc) = toException exc diff --git a/Data/Data.hs b/Data/Data.hs --- a/Data/Data.hs +++ b/Data/Data.hs @@ -1177,7 +1177,7 @@ tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix tuple3DataType :: DataType -tuple3DataType = mkDataType "Prelude.(,)" [tuple3Constr] +tuple3DataType = mkDataType "Prelude.(,,)" [tuple3Constr] instance (Data a, Data b, Data c) => Data (a,b,c) where gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c diff --git a/Foreign/ForeignPtr.hs b/Foreign/ForeignPtr.hs --- a/Foreign/ForeignPtr.hs +++ b/Foreign/ForeignPtr.hs @@ -152,24 +152,6 @@ return fObj #endif /* __HUGS__ */ -#ifdef __GLASGOW_HASKELL__ -type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ()) - --- | like 'addForeignPtrFinalizerEnv' but allows the finalizer to be --- passed an additional environment parameter to be passed to the --- finalizer. The environment passed to the finalizer is fixed by the --- second argument to 'addForeignPtrFinalizerEnv' -addForeignPtrFinalizerEnv :: - FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO () -addForeignPtrFinalizerEnv finalizer env fptr = - addForeignPtrConcFinalizer fptr - (mkFinalizerEnv finalizer env (unsafeForeignPtrToPtr fptr)) - -foreign import ccall "dynamic" - mkFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO () -#endif - - #ifndef __GLASGOW_HASKELL__ mallocForeignPtr :: Storable a => IO (ForeignPtr a) mallocForeignPtr = do diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -32,7 +32,7 @@ import Data.Maybe import Foreign.C.Types ( CSize ) -import Foreign.Storable ( Storable(sizeOf) ) +import Foreign.Storable ( Storable(sizeOf,alignment) ) #ifndef __GLASGOW_HASKELL__ import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) @@ -97,7 +97,7 @@ alloca = doAlloca undefined where doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' - doAlloca dummy = allocaBytes (sizeOf dummy) + doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument -- a pointer to a temporarily allocated block of memory of @n@ bytes. @@ -118,9 +118,23 @@ case touch# barr# s3 of { s4 -> (# s4, r #) }}}}} + +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b +allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> + case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) -> + case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) -> + let addr = Ptr (byteArrayContents# barr#) in + case action addr of { IO action' -> + case action' s2 of { (# s3, r #) -> + case touch# barr# s3 of { s4 -> + (# s4, r #) + }}}}} #else allocaBytes :: Int -> (Ptr a -> IO b) -> IO b allocaBytes size = bracket (mallocBytes size) free + +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b +allocaBytesAligned size align = allocaBytes size -- wrong #endif -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -86,10 +86,13 @@ #endif #ifndef mingw32_HOST_OS - , signalHandlerLock + , Signal, HandlerFun, setHandler, runHandlers #endif , ensureIOManagerIsRunning +#ifndef mingw32_HOST_OS + , syncIOManager +#endif #ifdef mingw32_HOST_OS , ConsoleEvent(..) @@ -109,6 +112,10 @@ import Foreign import Foreign.C +#ifndef mingw32_HOST_OS +import Data.Dynamic +import Control.Monad +#endif import Data.Maybe import GHC.Base @@ -116,6 +123,9 @@ import GHC.IOBase import GHC.Num ( Num(..) ) import GHC.Real ( fromIntegral ) +#ifndef mingw32_HOST_OS +import GHC.Arr ( inRange ) +#endif #ifdef mingw32_HOST_OS import GHC.Real ( div ) import GHC.Ptr ( plusPtr, FunPtr(..) ) @@ -296,12 +306,12 @@ (). In the paper, 'throwTo' is non-blocking; but the library implementation adopts a more synchronous design in which 'throwTo' does not return until the exception -is received by the target thread. The trade-off is discussed in Section 8 of the paper. -Like any blocking operation, 'throwTo' is therefore interruptible (see Section 4.3 of +is received by the target thread. The trade-off is discussed in Section 9 of the paper. +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, if a thread may +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. @@ -669,15 +679,6 @@ addMVarFinalizer :: MVar a -> IO () -> IO () addMVarFinalizer (MVar m) finalizer = IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } - -withMVar :: MVar a -> (a -> IO b) -> IO b -withMVar m io = - block $ do - a <- takeMVar m - b <- catchAny (unblock (io a)) - (\e -> do putMVar m a; throw e) - putMVar m a - return b \end{code} @@ -932,7 +933,8 @@ service_cont :: HANDLE -> [DelayReq] -> IO () service_cont wakeup delays = do - atomicModifyIORef prodding (\_ -> (False,False)) + r <- atomicModifyIORef prodding (\_ -> (False,False)) + r `seq` return () -- avoid space leak service_loop wakeup delays -- must agree with rts/win32/ThrIOManager.c @@ -1033,6 +1035,10 @@ throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds) rd_end <- peekElemOff fds 0 wr_end <- peekElemOff fds 1 + setNonBlockingFD wr_end -- writes happen in a signal handler, we + -- don't want them to block. + setCloseOnExec rd_end + setCloseOnExec wr_end writeIORef stick (fromIntegral wr_end) c_setIOManagerPipe wr_end forkIO $ do @@ -1100,17 +1106,24 @@ if b == 0 then return False else alloca $ \p -> do - c_read (fromIntegral wakeup) p 1; return () + c_read (fromIntegral wakeup) p 1 s <- peek p case s of _ | s == io_MANAGER_WAKEUP -> return False _ | s == io_MANAGER_DIE -> return True - _ -> withMVar signalHandlerLock $ \_ -> do - handler_tbl <- peek handlers - sp <- peekElemOff handler_tbl (fromIntegral s) - io <- deRefStablePtr sp - forkIO io - return False + _ | s == io_MANAGER_SYNC -> do + mvars <- readIORef sync + mapM_ (flip putMVar ()) mvars + return False + _ -> do + fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) + withForeignPtr fp $ \p_siginfo -> do + r <- c_read (fromIntegral wakeup) (castPtr p_siginfo) + sizeof_siginfo_t + when (r /= fromIntegral sizeof_siginfo_t) $ + error "failed to read siginfo_t" + runHandlers' fp (fromIntegral s) + return False if exit then return () else do @@ -1121,31 +1134,87 @@ service_loop wakeup readfds writefds ptimeval reqs' delays' -io_MANAGER_WAKEUP, io_MANAGER_DIE :: CChar +io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: CChar io_MANAGER_WAKEUP = 0xff io_MANAGER_DIE = 0xfe +io_MANAGER_SYNC = 0xfd +-- | the stick is for poking the IO manager with stick :: IORef Fd {-# NOINLINE stick #-} stick = unsafePerformIO (newIORef 0) +{-# NOINLINE sync #-} +sync :: IORef [MVar ()] +sync = unsafePerformIO (newIORef []) + +-- waits for the IO manager to drain the pipe +syncIOManager :: IO () +syncIOManager = do + m <- newEmptyMVar + atomicModifyIORef sync (\old -> (m:old,())) + fd <- readIORef stick + with io_MANAGER_SYNC $ \pbuf -> do + c_write (fromIntegral fd) pbuf 1; return () + takeMVar m + wakeupIOManager :: IO () wakeupIOManager = do fd <- readIORef stick with io_MANAGER_WAKEUP $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return () --- Lock used to protect concurrent access to signal_handlers. Symptom of --- this race condition is #1922, although that bug was on Windows a similar --- bug also exists on Unix. -signalHandlerLock :: MVar () -signalHandlerLock = unsafePerformIO (newMVar ()) +-- For the non-threaded RTS +runHandlers :: Ptr Word8 -> Int -> IO () +runHandlers p_info sig = do + fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) + withForeignPtr fp $ \p -> do + copyBytes p p_info (fromIntegral sizeof_siginfo_t) + free p_info + runHandlers' fp (fromIntegral sig) -foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr (IO ()))) +runHandlers' :: ForeignPtr Word8 -> Signal -> IO () +runHandlers' p_info sig = do + let int = fromIntegral sig + withMVar signal_handlers $ \arr -> + if not (inRange (boundsIOArray arr) int) + then return () + else do handler <- unsafeReadIOArray arr int + case handler of + Nothing -> return () + Just (f,_) -> do forkIO (f p_info); return () foreign import ccall "setIOManagerPipe" c_setIOManagerPipe :: CInt -> IO () +foreign import ccall "__hscore_sizeof_siginfo_t" + sizeof_siginfo_t :: CSize + +type Signal = CInt + +maxSig = 64 :: Int + +type HandlerFun = ForeignPtr Word8 -> IO () + +-- Lock used to protect concurrent access to signal_handlers. Symptom of +-- this race condition is #1922, although that bug was on Windows a similar +-- bug also exists on Unix. +{-# NOINLINE signal_handlers #-} +signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic))) +signal_handlers = unsafePerformIO $ do + arr <- newIOArray (0,maxSig) Nothing + newMVar arr + +setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic)) +setHandler sig handler = do + let int = fromIntegral sig + withMVar signal_handlers $ \arr -> + if not (inRange (boundsIOArray arr) int) + then error "GHC.Conc.setHandler: signal out of range" + else do old <- unsafeReadIOArray arr int + unsafeWriteIOArray arr int handler + return old + -- ----------------------------------------------------------------------------- -- IO requests @@ -1306,4 +1375,14 @@ getUncaughtExceptionHandler :: IO (SomeException -> IO ()) getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler + + +withMVar :: MVar a -> (a -> IO b) -> IO b +withMVar m io = + block $ do + a <- takeMVar m + b <- catchAny (unblock (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a + return b \end{code} diff --git a/GHC/Desugar.hs b/GHC/Desugar.hs --- a/GHC/Desugar.hs +++ b/GHC/Desugar.hs @@ -28,3 +28,4 @@ -- Yes, this is a bit grotesque, but heck it works and the whole -- arrows stuff needs reworking anyway! f >>> g = g . f + diff --git a/GHC/Exception.lhs b/GHC/Exception.lhs --- a/GHC/Exception.lhs +++ b/GHC/Exception.lhs @@ -31,12 +31,105 @@ %********************************************************* \begin{code} +{- | +The @SomeException@ type is the root of the exception type hierarchy. +When an exception of type @e@ is thrown, behind the scenes it is +encapsulated in a @SomeException@. +-} data SomeException = forall e . Exception e => SomeException e deriving Typeable instance Show SomeException where showsPrec p (SomeException e) = showsPrec p e +{- | +Any type that you wish to throw or catch as an exception must be an +instance of the @Exception@ class. The simplest case is a new exception +type directly below the root: + +> data MyException = ThisException | ThatException +> deriving (Show, Typeable) +> +> instance Exception MyException + +The default method definitions in the @Exception@ class do what we need +in this case. You can now throw and catch @ThisException@ and +@ThatException@ as exceptions: + +@ +*Main> throw ThisException `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +Caught ThisException +@ + +In more complicated examples, you may wish to define a whole hierarchy +of exceptions: + +> --------------------------------------------------------------------- +> -- Make the root exception type for all the exceptions in a compiler +> +> data SomeCompilerException = forall e . Exception e => SomeCompilerException e +> deriving Typeable +> +> instance Show SomeCompilerException where +> show (SomeCompilerException e) = show e +> +> instance Exception SomeCompilerException +> +> compilerExceptionToException :: Exception e => e -> SomeException +> compilerExceptionToException = toException . SomeCompilerException +> +> compilerExceptionFromException :: Exception e => SomeException -> Maybe e +> compilerExceptionFromException x = do +> SomeCompilerException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make a subhierarchy for exceptions in the frontend of the compiler +> +> data SomeFrontendException = forall e . Exception e => SomeFrontendException e +> deriving Typeable +> +> instance Show SomeFrontendException where +> show (SomeFrontendException e) = show e +> +> instance Exception SomeFrontendException where +> toException = compilerExceptionToException +> fromException = compilerExceptionFromException +> +> frontendExceptionToException :: Exception e => e -> SomeException +> frontendExceptionToException = toException . SomeFrontendException +> +> frontendExceptionFromException :: Exception e => SomeException -> Maybe e +> frontendExceptionFromException x = do +> SomeFrontendException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make an exception type for a particular frontend compiler exception +> +> data MismatchedParentheses = MismatchedParentheses +> deriving (Typeable, Show) +> +> instance Exception MismatchedParentheses where +> toException = frontendExceptionToException +> fromException = frontendExceptionFromException + +We can now catch a @MismatchedParentheses@ exception as +@MismatchedParentheses@, @SomeFrontendException@ or +@SomeCompilerException@, but not other types, e.g. @IOException@: + +@ +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses `catch` \e -> putStrLn (\"Caught \" ++ show (e :: IOException)) +*** Exception: MismatchedParentheses +@ + +-} class (Typeable e, Show e) => Exception e where toException :: e -> SomeException fromException :: SomeException -> Maybe e @@ -63,6 +156,8 @@ \end{code} \begin{code} +-- |This is thrown when the user calls 'error'. The @String@ is the +-- argument given to 'error'. data ErrorCall = ErrorCall String deriving Typeable @@ -73,7 +168,7 @@ ----- --- |The type of arithmetic exceptions +-- |Arithmetic exceptions. data ArithException = Overflow | Underflow diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs --- a/GHC/ForeignPtr.hs +++ b/GHC/ForeignPtr.hs @@ -19,12 +19,14 @@ ( ForeignPtr(..), FinalizerPtr, + FinalizerEnvPtr, newForeignPtr_, mallocForeignPtr, mallocPlainForeignPtr, mallocForeignPtrBytes, mallocPlainForeignPtrBytes, - addForeignPtrFinalizer, + addForeignPtrFinalizer, + addForeignPtrFinalizerEnv, touchForeignPtr, unsafeForeignPtrToPtr, castForeignPtr, @@ -42,7 +44,7 @@ import GHC.Base import GHC.IOBase import GHC.STRef ( STRef(..) ) -import GHC.Ptr ( Ptr(..), FunPtr ) +import GHC.Ptr ( Ptr(..), FunPtr(..) ) import GHC.Err #include "Typeable.h" @@ -76,9 +78,15 @@ INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr") +data Finalizers + = NoFinalizers + | CFinalizers + | HaskellFinalizers + deriving Eq + data ForeignPtrContents - = PlainForeignPtr !(IORef [IO ()]) - | MallocPtr (MutableByteArray# RealWorld) !(IORef [IO ()]) + = PlainForeignPtr !(IORef (Finalizers, [IO ()])) + | MallocPtr (MutableByteArray# RealWorld) !(IORef (Finalizers, [IO ()])) | PlainPtr (MutableByteArray# RealWorld) instance Eq (ForeignPtr a) where @@ -95,7 +103,8 @@ -- finalisation time, gets as an argument a plain pointer variant of the -- foreign pointer that the finalizer is associated with. -- -type FinalizerPtr a = FunPtr (Ptr a -> IO ()) +type FinalizerPtr a = FunPtr (Ptr a -> IO ()) +type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ()) newConcForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a) -- @@ -141,19 +150,20 @@ mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc a = do - r <- newIORef [] + r <- newIORef (NoFinalizers, []) IO $ \s -> - case newPinnedByteArray# size s of { (# s', mbarr# #) -> + case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (MallocPtr mbarr# r) #) } - where (I# size) = sizeOf a + where (I# size) = sizeOf a + (I# align) = alignment a -- | This function is similar to 'mallocForeignPtr', except that the -- size of the memory required is given explicitly as a number of bytes. mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) mallocForeignPtrBytes (I# size) = do - r <- newIORef [] + r <- newIORef (NoFinalizers, []) IO $ \s -> case newPinnedByteArray# size s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -177,11 +187,12 @@ mallocPlainForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc a = IO $ \s -> - case newPinnedByteArray# size s of { (# s', mbarr# #) -> + case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) } - where (I# size) = sizeOf a + where (I# size) = sizeOf a + (I# align) = alignment a -- | This function is similar to 'mallocForeignPtrBytes', except that -- the internally an optimised ForeignPtr representation with no @@ -198,10 +209,42 @@ -- ^This function adds a finalizer to the given foreign object. The -- finalizer will run /before/ all other finalizers for the same -- object which have already been registered. -addForeignPtrFinalizer finalizer fptr = - addForeignPtrConcFinalizer fptr - (mkFinalizer finalizer (unsafeForeignPtrToPtr fptr)) +addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of + PlainForeignPtr r -> f r >> return () + MallocPtr _ r -> f r >> return () + _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + where + f r = + noMixing CFinalizers r $ + IO $ \s -> + case r of { IORef (STRef r#) -> + case mkWeakForeignEnv# r# () fp p 0# nullAddr# s of { (# s1, w #) -> + (# s1, finalizeForeign w #) }} +addForeignPtrFinalizerEnv :: + FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO () +-- ^ like 'addForeignPtrFinalizerEnv' but allows the finalizer to be +-- passed an additional environment parameter to be passed to the +-- 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 () + _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + where + f r = + noMixing CFinalizers r $ + IO $ \s -> + case r of { IORef (STRef r#) -> + case mkWeakForeignEnv# r# () fp p 1# ep s of { (# s1, w #) -> + (# s1, finalizeForeign w #) }} + +finalizeForeign :: Weak# () -> IO () +finalizeForeign w = IO $ \s -> + case finalizeWeak# w s of + (# s1, 0#, _ #) -> (# s1, () #) + (# s1, _ , f #) -> f s1 + addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO () -- ^This function adds a finalizer to the given @ForeignPtr@. The -- finalizer will run /before/ all other finalizers for the same @@ -222,18 +265,16 @@ addForeignPtrConcFinalizer_ :: ForeignPtrContents -> IO () -> IO () addForeignPtrConcFinalizer_ (PlainForeignPtr r) finalizer = do - fs <- readIORef r - writeIORef r (finalizer : fs) - if (null fs) + noFinalizers <- noMixing HaskellFinalizers r (return finalizer) + if noFinalizers then IO $ \s -> case r of { IORef (STRef r#) -> case mkWeak# r# () (foreignPtrFinalizer r) s of { (# s1, _ #) -> (# s1, () #) }} else return () -addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do - fs <- readIORef r - writeIORef r (finalizer : fs) - if (null fs) +addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do + noFinalizers <- noMixing HaskellFinalizers r (return finalizer) + if noFinalizers then IO $ \s -> case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of (# s1, _ #) -> (# s1, () #) @@ -242,17 +283,26 @@ addForeignPtrConcFinalizer_ _ _ = error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer" -foreign import ccall "dynamic" - mkFinalizer :: FinalizerPtr a -> Ptr a -> IO () +noMixing :: + Finalizers -> IORef (Finalizers, [IO ()]) -> IO (IO ()) -> IO Bool +noMixing ftype0 r mkF = do + (ftype, fs) <- readIORef r + if ftype /= NoFinalizers && ftype /= ftype0 + then error ("GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++ + "in the same ForeignPtr") + else do + f <- mkF + writeIORef r (ftype0, f : fs) + return (null fs) -foreignPtrFinalizer :: IORef [IO ()] -> IO () -foreignPtrFinalizer r = do fs <- readIORef r; sequence_ fs +foreignPtrFinalizer :: IORef (Finalizers, [IO ()]) -> IO () +foreignPtrFinalizer r = do (_, fs) <- readIORef r; sequence_ fs newForeignPtr_ :: Ptr a -> IO (ForeignPtr a) -- ^Turns a plain memory reference into a foreign pointer that may be -- associated with finalizers by using 'addForeignPtrFinalizer'. newForeignPtr_ (Ptr obj) = do - r <- newIORef [] + r <- newIORef (NoFinalizers, []) return (ForeignPtr obj (PlainForeignPtr r)) touchForeignPtr :: ForeignPtr a -> IO () @@ -312,9 +362,9 @@ finalizeForeignPtr :: ForeignPtr a -> IO () finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect finalizeForeignPtr (ForeignPtr _ foreignPtr) = do - finalizers <- readIORef refFinalizers + (ftype, finalizers) <- readIORef refFinalizers sequence_ finalizers - writeIORef refFinalizers [] + writeIORef refFinalizers (ftype, []) where refFinalizers = case foreignPtr of (PlainForeignPtr ref) -> ref diff --git a/GHC/Handle.hs b/GHC/Handle.hs --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -925,7 +925,11 @@ stat@(fd_type,_,_) <- fdStat fd - h <- fdToHandle_stat fd (Just stat) False filepath mode binary + h <- fdToHandle_stat fd (Just stat) + False -- set_non_blocking + True -- is_non_blocking + False -- is_socket + filepath mode binary `catchAny` \e -> do c_close fd; throw e -- NB. don't forget to close the FD if fdToHandle' fails, otherwise -- this FD leaks. @@ -959,22 +963,26 @@ fdToHandle_stat :: FD -> Maybe (FDType, CDev, CIno) - -> Bool + -> Bool -- set_non_blocking + -> Bool -- is_non_blocking + -> Bool -- is_socket -> FilePath -> IOMode -> Bool -> IO Handle -fdToHandle_stat fd mb_stat is_socket filepath mode binary = do +fdToHandle_stat fd mb_stat set_non_blocking is_non_blocking is_socket + filepath mode binary = do #ifdef mingw32_HOST_OS - -- On Windows, the is_socket flag indicates that the Handle is a socket + -- On Windows, the is_stream flag indicates that the Handle is a socket + let is_stream = is_socket #else - -- On Unix, the is_socket flag indicates that the FD can be made non-blocking - let non_blocking = is_socket - - when non_blocking $ setNonBlockingFD fd + when set_non_blocking $ setNonBlockingFD fd -- turn on non-blocking mode + + -- On Unix, the is_stream flag indicates that the FD is in non-blocking mode + let is_stream = is_non_blocking || set_non_blocking #endif let (ha_type, write) = @@ -1007,18 +1015,18 @@ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing) #endif - mkFileHandle fd is_socket filepath ha_type binary + mkFileHandle fd is_stream filepath ha_type binary Stream -- only *Streams* can be DuplexHandles. Other read/write -- Handles must share a buffer. | ReadWriteHandle <- ha_type -> - mkDuplexHandle fd is_socket filepath binary + mkDuplexHandle fd is_stream filepath binary | otherwise -> - mkFileHandle fd is_socket filepath ha_type binary + mkFileHandle fd is_stream filepath ha_type binary RawDevice -> - mkFileHandle fd is_socket filepath ha_type binary + mkFileHandle fd is_stream filepath ha_type binary -- | Old API kept to avoid breaking clients fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool @@ -1031,16 +1039,21 @@ Just RegularFile -> Nothing -- no stat required for streams etc.: Just other -> Just (other,0,0) - fdToHandle_stat fd mb_stat is_socket filepath mode binary + fdToHandle_stat fd mb_stat + is_socket -- set_non_blocking + False -- is_non_blocking + is_socket -- is_socket + filepath mode binary fdToHandle :: FD -> IO Handle fdToHandle fd = do mode <- fdGetMode fd let fd_str = "" - fdToHandle_stat fd Nothing False fd_str mode True{-bin mode-} - -- NB. the is_socket flag is False, meaning that: - -- on Unix the file descriptor will *not* be put in non-blocking mode - -- on Windows we're guessing this is not a socket (XXX) + fdToHandle_stat fd Nothing + False -- set_non_blocking + False -- is_non_blocking + False -- is_socket (guess XXX) + fd_str mode True{-bin mode-} #ifndef mingw32_HOST_OS foreign import ccall unsafe "lockFile" diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -27,7 +27,8 @@ -- References IORef(..), newIORef, readIORef, writeIORef, - IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray, + IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, + unsafeWriteIOArray, boundsIOArray, MVar(..), -- Handles, file descriptors, @@ -606,6 +607,9 @@ writeIOArray :: Ix i => IOArray i e -> i -> e -> IO () writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) +{-# INLINE boundsIOArray #-} +boundsIOArray :: IOArray i e -> (i,i) +boundsIOArray (IOArray marr) = boundsSTArray marr -- --------------------------------------------------------------------------- -- Show instance for Handles @@ -634,6 +638,8 @@ -- ------------------------------------------------------------------------ -- Exception datatypes and operations +-- |The thread is blocked on an @MVar@, but there are no other references +-- to the @MVar@ so it can't ever continue. data BlockedOnDeadMVar = BlockedOnDeadMVar deriving Typeable @@ -647,6 +653,8 @@ ----- +-- |The thread is awiting to retry an STM transaction, but there are no +-- other references to any @TVar@s involved, so it can't ever continue. data BlockedIndefinitely = BlockedIndefinitely deriving Typeable @@ -660,6 +668,8 @@ ----- +-- |There are no runnable threads, so the program is deadlocked. +-- The @Deadlock@ exception is raised in the main thread only. data Deadlock = Deadlock deriving Typeable @@ -670,6 +680,8 @@ ----- +-- |Exceptions generated by 'assert'. The @String@ gives information +-- about the source location of the assertion. data AssertionFailed = AssertionFailed String deriving Typeable @@ -680,7 +692,7 @@ ----- --- |Asynchronous exceptions +-- |Asynchronous exceptions. data AsyncException = StackOverflow -- ^The current thread\'s stack exceeded its limit. @@ -913,7 +925,7 @@ catchAny (IO io) handler = IO $ catch# io handler' where handler' (SomeException e) = unIO (handler e) --- | A variant of 'throw' that can be used within the 'IO' monad. +-- | A variant of 'throw' that can only be used within the 'IO' monad. -- -- Although 'throwIO' has a type that is an instance of the type of 'throw', the -- two functions are subtly different: @@ -974,9 +986,10 @@ \end{code} \begin{code} --- | Forces its argument to be evaluated when the resultant 'IO' action --- is executed. It can be used to order evaluation with respect to --- other 'IO' operations; its semantics are given by +-- | Forces its argument to be evaluated to weak head normal form when +-- the resultant 'IO' action is executed. It can be used to order +-- evaluation with respect to other 'IO' operations; its semantics are +-- given by -- -- > evaluate x `seq` y ==> y -- > evaluate x `catch` f ==> (return $! x) `catch` f diff --git a/GHC/Real.lhs b/GHC/Real.lhs --- a/GHC/Real.lhs +++ b/GHC/Real.lhs @@ -173,7 +173,8 @@ properFraction :: (Integral b) => a -> (b,a) -- | @'truncate' x@ returns the integer nearest @x@ between zero and @x@ truncate :: (Integral b) => a -> b - -- | @'round' x@ returns the nearest integer to @x@ + -- | @'round' x@ returns the nearest integer to @x@; + -- the even integer if @x@ is equidistant between two integers round :: (Integral b) => a -> b -- | @'ceiling' x@ returns the least integer not less than @x@ ceiling :: (Integral b) => a -> b @@ -449,16 +450,16 @@ {-# RULES "gcd/Int->Int->Int" gcd = gcdInt +"gcd/Integer->Integer->Integer" gcd = gcdInteger' +"lcm/Integer->Integer->Integer" lcm = lcmInteger #-} --- XXX these optimisation rules are disabled for now to make it easier --- to experiment with other Integer implementations --- "gcd/Integer->Integer->Integer" gcd = gcdInteger' --- "lcm/Integer->Integer->Integer" lcm = lcmInteger +-- XXX to use another Integer implementation, you might need to disable +-- the gcd/Integer and lcm/Integer RULES above -- --- gcdInteger' :: Integer -> Integer -> Integer --- gcdInteger' 0 0 = error "GHC.Real.gcdInteger': gcd 0 0 is undefined" --- gcdInteger' a b = gcdInteger a b +gcdInteger' :: Integer -> Integer -> Integer +gcdInteger' 0 0 = error "GHC.Real.gcdInteger': gcd 0 0 is undefined" +gcdInteger' a b = gcdInteger a b integralEnumFrom :: (Integral a, Bounded a) => a -> [a] integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)] diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs --- a/GHC/TopHandler.lhs +++ b/GHC/TopHandler.lhs @@ -28,6 +28,7 @@ import Control.Exception import Data.Maybe +import Data.Dynamic (toDyn) import Foreign import Foreign.C @@ -79,27 +80,18 @@ -- isn't available here. install_interrupt_handler handler = do let sig = CONST_SIGINT :: CInt - withSignalHandlerLock $ - alloca $ \p_sp -> do - sptr <- newStablePtr handler - poke p_sp sptr - stg_sig_install sig STG_SIG_RST p_sp nullPtr - return () - -withSignalHandlerLock :: IO () -> IO () -withSignalHandlerLock io - = block $ do - takeMVar signalHandlerLock - catchAny (unblock io) (\e -> do putMVar signalHandlerLock (); throw e) - putMVar signalHandlerLock () + setHandler sig (Just (const handler, toDyn handler)) + stg_sig_install sig STG_SIG_RST nullPtr + -- STG_SIG_RST: the second ^C kills us for real, just in case the + -- RTS or program is unresponsive. + return () foreign import ccall unsafe stg_sig_install :: CInt -- sig no. -> CInt -- action code (STG_SIG_HAN etc.) - -> Ptr (StablePtr (IO ())) -- (in, out) Haskell handler -> Ptr () -- (in, out) blocked - -> IO CInt -- (ret) action code + -> IO CInt -- (ret) old action code #endif -- make a weak pointer to a ThreadId: holding the weak pointer doesn't diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs --- a/System/Posix/Internals.hs +++ b/System/Posix/Internals.hs @@ -317,6 +317,17 @@ #endif -- ----------------------------------------------------------------------------- +-- Set close-on-exec for a file descriptor + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +setCloseOnExec :: FD -> IO () +setCloseOnExec fd = do + throwErrnoIfMinus1 "setCloseOnExec" $ + c_fcntl_write fd const_f_setfd const_fd_cloexec + return () +#endif + +-- ----------------------------------------------------------------------------- -- foreign imports foreign import ccall unsafe "HsBase.h access" @@ -499,6 +510,8 @@ foreign import ccall unsafe "HsBase.h __hscore_sig_setmask" const_sig_setmask :: CInt foreign import ccall unsafe "HsBase.h __hscore_f_getfl" const_f_getfl :: CInt foreign import ccall unsafe "HsBase.h __hscore_f_setfl" const_f_setfl :: CInt +foreign import ccall unsafe "HsBase.h __hscore_f_setfd" const_f_setfd :: CInt +foreign import ccall unsafe "HsBase.h __hscore_fd_cloexec" const_fd_cloexec :: CLong #if defined(HTYPE_TCFLAG_T) foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios" sizeof_termios :: Int diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,5 +1,5 @@ name: base -version: 4.0.0.0 +version: 4.1.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -8,7 +8,7 @@ This package contains the Prelude and its support libraries, and a large collection of useful libraries ranging from data structures to parsing combinators and debugging utilities. -cabal-version: >= 1.2.3 +cabal-version: >=1.2 build-type: Configure extra-tmp-files: config.log config.status autom4te.cache @@ -61,8 +61,12 @@ ScopedTypeVariables, UnboxedTuples, ForeignFunctionInterface, UnliftedFFITypes, DeriveDataTypeable, GeneralizedNewtypeDeriving, - FlexibleInstances, PatternSignatures, StandaloneDeriving, + FlexibleInstances, StandaloneDeriving, PatternGuards, EmptyDataDecls + + if impl(ghc < 6.10) + -- PatternSignatures was deprecated in 6.10 + extensions: PatternSignatures } exposed-modules: Control.Applicative, diff --git a/config.guess b/config.guess --- a/config.guess +++ b/config.guess @@ -1,10 +1,10 @@ #! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 -# Free Software Foundation, Inc. +# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, +# Inc. -timestamp='2008-01-23' +timestamp='2006-07-02' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -56,8 +56,8 @@ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, -2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 +Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -161,7 +161,6 @@ arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; - sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched @@ -330,7 +329,7 @@ sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; - i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + i86pc:SunOS:5.*:*) echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) @@ -532,7 +531,7 @@ echo rs6000-ibm-aix3.2 fi exit ;; - *:AIX:*:[456]) + *:AIX:*:[45]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 @@ -781,7 +780,7 @@ i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; - *:MINGW*:*) + i*:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:windows32*:*) @@ -791,18 +790,12 @@ i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; - *:Interix*:[3456]*) - case ${UNAME_MACHINE} in - x86) - echo i586-pc-interix${UNAME_RELEASE} - exit ;; - EM64T | authenticamd) - echo x86_64-unknown-interix${UNAME_RELEASE} - exit ;; - IA64) - echo ia64-unknown-interix${UNAME_RELEASE} - exit ;; - esac ;; + x86:Interix*:[3456]*) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + EM64T:Interix*:[3456]*) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; @@ -836,14 +829,7 @@ echo ${UNAME_MACHINE}-pc-minix exit ;; arm*:Linux:*:*) - eval $set_cc_for_build - if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_EABI__ - then - echo ${UNAME_MACHINE}-unknown-linux-gnu - else - echo ${UNAME_MACHINE}-unknown-linux-gnueabi - fi + echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu @@ -964,9 +950,6 @@ x86_64:Linux:*:*) echo x86_64-unknown-linux-gnu exit ;; - xtensa*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; i*86:Linux:*:*) # The BFD linker knows what the default object file format is, so # first see if it will tell us. cd to the root directory to prevent @@ -1225,15 +1208,6 @@ SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; - SX-7:SUPER-UX:*:*) - echo sx7-nec-superux${UNAME_RELEASE} - exit ;; - SX-8:SUPER-UX:*:*) - echo sx8-nec-superux${UNAME_RELEASE} - exit ;; - SX-8R:SUPER-UX:*:*) - echo sx8r-nec-superux${UNAME_RELEASE} - exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; @@ -1484,9 +1458,9 @@ the operating system you are using. It is advised that you download the most up to date version of the config scripts from - http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD + http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.guess and - http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD + http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.sub If the version you run ($0) is already up to date, please send the following data and any information you think might be diff --git a/config.sub b/config.sub --- a/config.sub +++ b/config.sub @@ -1,10 +1,10 @@ #! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 -# Free Software Foundation, Inc. +# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, +# Inc. -timestamp='2008-01-16' +timestamp='2006-07-02' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software @@ -72,8 +72,8 @@ version="\ GNU config.sub ($timestamp) -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, -2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 +Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -245,12 +245,12 @@ | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx \ - | fido | fr30 | frv \ + | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ - | maxq | mb | microblaze | mcore | mep \ + | maxq | mb | microblaze | mcore \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ @@ -276,7 +276,6 @@ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ | pyramid \ - | score \ | sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ @@ -285,7 +284,7 @@ | tahoe | thumb | tic4x | tic80 | tron \ | v850 | v850e \ | we32k \ - | x86 | xc16x | xscale | xscalee[bl] | xstormy16 | xtensa \ + | x86 | xscale | xscalee[bl] | xstormy16 | xtensa \ | z8k) basic_machine=$basic_machine-unknown ;; @@ -324,7 +323,7 @@ | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ - | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ + | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | i*86-* | i860-* | i960-* | ia64-* \ @@ -368,15 +367,11 @@ | tron-* \ | v850-* | v850e-* | vax-* \ | we32k-* \ - | x86-* | x86_64-* | xc16x-* | xps100-* | xscale-* | xscalee[bl]-* \ - | xstormy16-* | xtensa*-* \ + | x86-* | x86_64-* | xps100-* | xscale-* | xscalee[bl]-* \ + | xstormy16-* | xtensa-* \ | ymp-* \ | z8k-*) ;; - # Recognize the basic CPU types without company name, with glob match. - xtensa*) - basic_machine=$basic_machine-unknown - ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) @@ -447,14 +442,6 @@ basic_machine=ns32k-sequent os=-dynix ;; - blackfin) - basic_machine=bfin-unknown - os=-linux - ;; - blackfin-*) - basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; c90) basic_machine=c90-cray os=-unicos @@ -487,8 +474,8 @@ basic_machine=craynv-cray os=-unicosmp ;; - cr16) - basic_machine=cr16-unknown + cr16c) + basic_machine=cr16c-unknown os=-elf ;; crds | unos) @@ -680,14 +667,6 @@ basic_machine=m68k-isi os=-sysv ;; - m68knommu) - basic_machine=m68k-unknown - os=-linux - ;; - m68knommu-*) - basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; m88k-omron*) basic_machine=m88k-omron ;; @@ -703,10 +682,6 @@ basic_machine=i386-pc os=-mingw32 ;; - mingw32ce) - basic_machine=arm-unknown - os=-mingw32ce - ;; miniframe) basic_machine=m68000-convergent ;; @@ -833,14 +808,6 @@ basic_machine=i860-intel os=-osf ;; - parisc) - basic_machine=hppa-unknown - os=-linux - ;; - parisc-*) - basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; pbd) basic_machine=sparc-tti ;; @@ -942,10 +909,6 @@ sb1el) basic_machine=mipsisa64sb1el-unknown ;; - sde) - basic_machine=mipsisa32-sde - os=-elf - ;; sei) basic_machine=mips-sei os=-seiux @@ -957,9 +920,6 @@ basic_machine=sh-hitachi os=-hms ;; - sh5el) - basic_machine=sh5le-unknown - ;; sh64) basic_machine=sh64-unknown ;; @@ -1049,10 +1009,6 @@ basic_machine=tic6x-unknown os=-coff ;; - tile*) - basic_machine=tile-unknown - os=-linux-gnu - ;; tx39) basic_machine=mipstx39-unknown ;; @@ -1258,7 +1214,7 @@ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ - | -skyos* | -haiku* | -rdos* | -toppers* | -drops*) + | -skyos* | -haiku* | -rdos* | -toppers*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) @@ -1410,9 +1366,6 @@ # system, and we'll never get to this point. case $basic_machine in - score-*) - os=-elf - ;; spu-*) os=-elf ;; @@ -1452,9 +1405,6 @@ ;; m68*-cisco) os=-aout - ;; - mep-*) - os=-elf ;; mips*-cisco) os=-elf diff --git a/include/HsBase.h b/include/HsBase.h --- a/include/HsBase.h +++ b/include/HsBase.h @@ -628,6 +628,13 @@ #endif } +#ifndef __MINGW32__ +INLINE size_t __hscore_sizeof_siginfo_t (void) +{ + return sizeof(siginfo_t); +} +#endif + INLINE int __hscore_f_getfl( void ) { @@ -643,6 +650,26 @@ { #ifdef F_SETFL return F_SETFL; +#else + return 0; +#endif +} + +INLINE int +__hscore_f_setfd( void ) +{ +#ifdef F_SETFD + return F_SETFD; +#else + return 0; +#endif +} + +INLINE long +__hscore_fd_cloexec( void ) +{ +#ifdef FD_CLOEXEC + return FD_CLOEXEC; #else return 0; #endif diff --git a/install-sh b/install-sh --- a/install-sh +++ b/install-sh @@ -1,7 +1,7 @@ #!/bin/sh # install - install a program, script, or datafile -scriptversion=2006-12-25.00 +scriptversion=2006-10-14.15 # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the @@ -48,7 +48,7 @@ # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. -doit=${DOITPROG-} +doit="${DOITPROG-}" if test -z "$doit"; then doit_exec=exec else @@ -58,49 +58,34 @@ # Put in absolute file names if you don't have them in your path; # or use environment vars. -chgrpprog=${CHGRPPROG-chgrp} -chmodprog=${CHMODPROG-chmod} -chownprog=${CHOWNPROG-chown} -cmpprog=${CMPPROG-cmp} -cpprog=${CPPROG-cp} -mkdirprog=${MKDIRPROG-mkdir} -mvprog=${MVPROG-mv} -rmprog=${RMPROG-rm} -stripprog=${STRIPPROG-strip} - -posix_glob='?' -initialize_posix_glob=' - test "$posix_glob" != "?" || { - if (set -f) 2>/dev/null; then - posix_glob= - else - posix_glob=: - fi - } -' +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" +posix_glob= posix_mkdir= # Desired mode of installed file. mode=0755 -chgrpcmd= chmodcmd=$chmodprog chowncmd= -mvcmd=$mvprog -rmcmd="$rmprog -f" +chgrpcmd= stripcmd= - +rmcmd="$rmprog -f" +mvcmd="$mvprog" src= dst= dir_arg= -dst_arg= - -copy_on_change=false +dstarg= no_target_directory= -usage="\ -Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE +usage="Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... @@ -110,55 +95,65 @@ In the 4th, create DIRECTORIES. Options: - --help display this help and exit. - --version display version info and exit. - - -c (ignored) - -C install only if different (preserve the last data modification time) - -d create directories instead of installing files. - -g GROUP $chgrpprog installed files to GROUP. - -m MODE $chmodprog installed files to MODE. - -o USER $chownprog installed files to USER. - -s $stripprog installed files. - -t DIRECTORY install into DIRECTORY. - -T report an error if DSTFILE is a directory. +-c (ignored) +-d create directories instead of installing files. +-g GROUP $chgrpprog installed files to GROUP. +-m MODE $chmodprog installed files to MODE. +-o USER $chownprog installed files to USER. +-s $stripprog installed files. +-t DIRECTORY install into DIRECTORY. +-T report an error if DSTFILE is a directory. +--help display this help and exit. +--version display version info and exit. Environment variables override the default commands: - CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG - RMPROG STRIPPROG + CHGRPPROG CHMODPROG CHOWNPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in - -c) ;; - - -C) copy_on_change=true;; + -c) shift + continue;; - -d) dir_arg=true;; + -d) dir_arg=true + shift + continue;; -g) chgrpcmd="$chgrpprog $2" - shift;; + shift + shift + continue;; --help) echo "$usage"; exit $?;; -m) mode=$2 + shift + shift case $mode in *' '* | *' '* | *' '* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac - shift;; + continue;; -o) chowncmd="$chownprog $2" - shift;; + shift + shift + continue;; - -s) stripcmd=$stripprog;; + -s) stripcmd=$stripprog + shift + continue;; - -t) dst_arg=$2 - shift;; + -t) dstarg=$2 + shift + shift + continue;; - -T) no_target_directory=true;; + -T) no_target_directory=true + shift + continue;; --version) echo "$0 $scriptversion"; exit $?;; @@ -170,22 +165,21 @@ *) break;; esac - shift done -if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then +if test $# -ne 0 && test -z "$dir_arg$dstarg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do - if test -n "$dst_arg"; then + if test -n "$dstarg"; then # $@ is not empty: it contains at least $arg. - set fnord "$@" "$dst_arg" + set fnord "$@" "$dstarg" shift # fnord fi shift # arg - dst_arg=$arg + dstarg=$arg done fi @@ -230,7 +224,7 @@ do # Protect names starting with `-'. case $src in - -*) src=./$src;; + -*) src=./$src ;; esac if test -n "$dir_arg"; then @@ -248,22 +242,22 @@ exit 1 fi - if test -z "$dst_arg"; then + if test -z "$dstarg"; then echo "$0: no destination specified." >&2 exit 1 fi - dst=$dst_arg + dst=$dstarg # Protect names starting with `-'. case $dst in - -*) dst=./$dst;; + -*) dst=./$dst ;; esac # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test -n "$no_target_directory"; then - echo "$0: $dst_arg: Is a directory" >&2 + echo "$0: $dstarg: Is a directory" >&2 exit 1 fi dstdir=$dst @@ -384,19 +378,26 @@ # directory the slow way, step by step, checking for races as we go. case $dstdir in - /*) prefix='/';; - -*) prefix='./';; - *) prefix='';; + /*) prefix=/ ;; + -*) prefix=./ ;; + *) prefix= ;; esac - eval "$initialize_posix_glob" + case $posix_glob in + '') + if (set -f) 2>/dev/null; then + posix_glob=true + else + posix_glob=false + fi ;; + esac oIFS=$IFS IFS=/ - $posix_glob set -f + $posix_glob && set -f set fnord $dstdir shift - $posix_glob set +f + $posix_glob && set +f IFS=$oIFS prefixes= @@ -458,54 +459,41 @@ # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # - { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && - { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && - { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && - { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && - - # If -C, don't bother to copy if it wouldn't change the file. - if $copy_on_change && - old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && - new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && - - eval "$initialize_posix_glob" && - $posix_glob set -f && - set X $old && old=:$2:$4:$5:$6 && - set X $new && new=:$2:$4:$5:$6 && - $posix_glob set +f && + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } \ + && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } \ + && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } \ + && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && - test "$old" = "$new" && - $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 - then - rm -f "$dsttmp" - else - # Rename the file to the real destination. - $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || + # Now rename the file to the real destination. + { $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null \ + || { + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. - # The rename failed, perhaps because mv can't rename something else - # to itself, or perhaps because mv is so ancient that it does not - # support -f. - { - # Now remove or move aside any old file at destination location. - # We try this two ways since rm can't unlink itself on some - # systems and the destination file might be busy for other - # reasons. In this case, the final cleanup might fail but the new - # file should still install successfully. - { - test ! -f "$dst" || - $doit $rmcmd -f "$dst" 2>/dev/null || - { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && - { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } - } || - { echo "$0: cannot unlink or rename $dst" >&2 - (exit 1); exit 1 - } - } && + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + if test -f "$dst"; then + $doit $rmcmd -f "$dst" 2>/dev/null \ + || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null \ + && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }; }\ + || { + echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + else + : + fi + } && - # Now rename the file to the real destination. - $doit $mvcmd "$dsttmp" "$dst" - } - fi || exit 1 + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + } || exit 1 trap '' 0 fi