base 4.0.0.0 → 4.1.0.0
raw patch · 22 files changed
+759/−416 lines, 22 files
Files
- Control/Arrow.hs +2/−4
- Control/Concurrent.hs +1/−1
- Control/Exception.hs +135/−28
- Control/Exception/Base.hs +61/−30
- Control/OldException.hs +13/−2
- Data/Data.hs +1/−1
- Foreign/ForeignPtr.hs +0/−18
- Foreign/Marshal/Alloc.hs +16/−2
- GHC/Conc.lhs +107/−28
- GHC/Desugar.hs +1/−0
- GHC/Exception.lhs +96/−1
- GHC/ForeignPtr.hs +78/−28
- GHC/Handle.hs +30/−17
- GHC/IOBase.lhs +19/−6
- GHC/Real.lhs +9/−8
- GHC/TopHandler.lhs +7/−15
- System/Posix/Internals.hs +13/−0
- base.cabal +7/−3
- config.guess +17/−43
- config.sub +14/−64
- include/HsBase.h +27/−0
- install-sh +105/−117
Control/Arrow.hs view
@@ -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
Control/Concurrent.hs view
@@ -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@.
Control/Exception.hs view
@@ -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.+-}+
Control/Exception/Base.hs view
@@ -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")
Control/OldException.hs view
@@ -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
Data/Data.hs view
@@ -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
Foreign/ForeignPtr.hs view
@@ -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
Foreign/Marshal/Alloc.hs view
@@ -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'
GHC/Conc.lhs view
@@ -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 @@ (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>). 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}
GHC/Desugar.hs view
@@ -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+
GHC/Exception.lhs view
@@ -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
GHC/ForeignPtr.hs view
@@ -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
GHC/Handle.hs view
@@ -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 = "<file descriptor: " ++ show fd ++ ">"- 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"
GHC/IOBase.lhs view
@@ -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
GHC/Real.lhs view
@@ -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)]
GHC/TopHandler.lhs view
@@ -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
System/Posix/Internals.hs view
@@ -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
base.cabal view
@@ -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,
config.guess view
@@ -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
config.sub view
@@ -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
include/HsBase.h view
@@ -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
install-sh view
@@ -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