From: sof Date: Fri, 14 Mar 1997 05:27:50 +0000 (+0000) Subject: [project @ 1997-03-14 05:27:40 by sof] X-Git-Tag: Approximately_1000_patches_recorded~785 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9fa0d9f03cc2c7e1102b762bc65c116c02fac108;p=ghc-hetmet.git [project @ 1997-03-14 05:27:40 by sof] OGI changes through 130397 --- diff --git a/ghc/lib/ghc/ArrBase.lhs b/ghc/lib/ghc/ArrBase.lhs index c46aef5..0440cf0 100644 --- a/ghc/lib/ghc/ArrBase.lhs +++ b/ghc/lib/ghc/ArrBase.lhs @@ -1,13 +1,15 @@ % % (c) The AQUA Project, Glasgow University, 1994-1996 % - \section[ArrBase]{Module @ArrBase@} +Array implementation, @ArrBase@ exports the basic array +types and operations. + \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module ArrBase where +module ArrBase where import {-# SOURCE #-} IOBase ( error ) import Ix @@ -52,6 +54,9 @@ data Ix ix => Array ix elt = Array (ix,ix) (Array# elt) data Ix ix => ByteArray ix = ByteArray (ix,ix) ByteArray# data Ix ix => MutableArray s ix elt = MutableArray (ix,ix) (MutableArray# s elt) data Ix ix => MutableByteArray s ix = MutableByteArray (ix,ix) (MutableByteArray# s) + +-- A one-element mutable array: +type MutableVar s a = MutableArray s Int a \end{code} @@ -93,10 +98,10 @@ arrEleBottom = error "(Array.!): undefined array element" fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s () fill_it_in arr lst - = foldr fill_one_in (returnStrictlyST ()) lst + = foldr fill_one_in (returnST ()) lst where -- **** STRICT **** (but that's OK...) fill_one_in (i, v) rst - = writeArray arr i v `seqStrictlyST` rst + = writeArray arr i v `seqST` rst ----------------------------------------------------------------------- -- these also go better with magic: (//), accum, accumArray @@ -104,9 +109,9 @@ fill_it_in arr lst old_array // ivs = runST ( -- copy the old array: - thawArray old_array `thenStrictlyST` \ arr -> + thawArray old_array `thenST` \ arr -> -- now write the new elements into the new array: - fill_it_in arr ivs `seqStrictlyST` + fill_it_in arr ivs `seqST` freezeArray arr ) where @@ -116,17 +121,17 @@ zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt -- zap_with_f: reads an elem out first, then uses "f" on that and the new value zap_with_f f arr lst - = foldr zap_one (returnStrictlyST ()) lst + = foldr zap_one (returnST ()) lst where zap_one (i, new_v) rst - = readArray arr i `thenStrictlyST` \ old_v -> - writeArray arr i (f old_v new_v) `seqStrictlyST` + = readArray arr i `thenST` \ old_v -> + writeArray arr i (f old_v new_v) `seqST` rst accum f old_array ivs = runST ( -- copy the old array: - thawArray old_array `thenStrictlyST` \ arr -> + thawArray old_array `thenST` \ arr -> -- now zap the elements in question with "f": zap_with_f f arr ivs >> @@ -448,7 +453,7 @@ freezeArray (MutableArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> copy cur# end# from# to# s# | cur# ==# end# = StateAndMutableArray# s# to# - | True + | otherwise = case readArray# from# cur# s# of { StateAndPtr# s1# ele -> case writeArray# to# cur# ele s1# of { s2# -> copy (cur# +# 1#) end# from# to# s2# @@ -481,7 +486,7 @@ freezeCharArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) copy cur# end# from# to# s# | cur# ==# end# = StateAndMutableByteArray# s# to# - | True + | otherwise = case (readCharArray# from# cur# s#) of { StateAndChar# s1# ele -> case (writeCharArray# to# cur# ele s1#) of { s2# -> copy (cur# +# 1#) end# from# to# s2# @@ -514,7 +519,7 @@ freezeIntArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) - copy cur# end# from# to# s# | cur# ==# end# = StateAndMutableByteArray# s# to# - | True + | otherwise = case (readIntArray# from# cur# s#) of { StateAndInt# s1# ele -> case (writeIntArray# to# cur# ele s1#) of { s2# -> copy (cur# +# 1#) end# from# to# s2# @@ -547,7 +552,7 @@ freezeAddrArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) copy cur# end# from# to# s# | cur# ==# end# = StateAndMutableByteArray# s# to# - | True + | otherwise = case (readAddrArray# from# cur# s#) of { StateAndAddr# s1# ele -> case (writeAddrArray# to# cur# ele s1#) of { s2# -> copy (cur# +# 1#) end# from# to# s2# @@ -580,7 +585,7 @@ freezeFloatArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) copy cur# end# from# to# s# | cur# ==# end# = StateAndMutableByteArray# s# to# - | True + | otherwise = case (readFloatArray# from# cur# s#) of { StateAndFloat# s1# ele -> case (writeFloatArray# to# cur# ele s1#) of { s2# -> copy (cur# +# 1#) end# from# to# s2# @@ -613,7 +618,7 @@ freezeDoubleArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s# copy cur# end# from# to# s# | cur# ==# end# = StateAndMutableByteArray# s# to# - | True + | otherwise = case (readDoubleArray# from# cur# s#) of { StateAndDouble# s1# ele -> case (writeDoubleArray# to# cur# ele s1#) of { s2# -> copy (cur# +# 1#) end# from# to# s2# @@ -670,7 +675,7 @@ thawArray (Array ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> copy cur# end# from# to# s# | cur# ==# end# = StateAndMutableArray# s# to# - | True + | otherwise = case indexArray# from# cur# of { Lift ele -> case writeArray# to# cur# ele s# of { s1# -> copy (cur# +# 1#) end# from# to# s1# diff --git a/ghc/lib/ghc/ConcBase.lhs b/ghc/lib/ghc/ConcBase.lhs index 3a53271..8dd4097 100644 --- a/ghc/lib/ghc/ConcBase.lhs +++ b/ghc/lib/ghc/ConcBase.lhs @@ -7,6 +7,7 @@ Basic concurrency stuff \begin{code} +{-# OPTIONS -fno-implicit-prelude #-} module ConcBase( -- Forking and suchlike ST, forkST, @@ -19,14 +20,14 @@ module ConcBase( MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar ) where -import Prelude +import PrelBase import STBase ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) ) -import IOBase ( IO(..) ) +import IOBase ( IO(..), MVar(..) ) import GHCerr ( parError ) import PrelBase ( Int(..) ) import GHC ( fork#, delay#, waitRead#, waitWrite#, SynchVar#, newSynchVar#, takeMVar#, putMVar#, - State#, RealWorld + State#, RealWorld, par# ) infixr 0 `par`, `fork` @@ -90,7 +91,7 @@ are allowed, but there must be at least one read between any two writes. \begin{code} -data MVar a = MVar (SynchVar# RealWorld a) +--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) newEmptyMVar :: IO (MVar a) diff --git a/ghc/lib/ghc/GHC.hi-boot b/ghc/lib/ghc/GHC.hi-boot index 040802b..884bba0 100644 --- a/ghc/lib/ghc/GHC.hi-boot +++ b/ghc/lib/ghc/GHC.hi-boot @@ -11,7 +11,7 @@ GHC -> Void - void +-- void CAF is defined in PrelBase -- I/O primitives RealWorld @@ -20,7 +20,13 @@ GHC fork# delay# - + seq# + par# + parGlobal# + parLocal# + parAt# + parAtForNow# + SynchVar# newSynchVar# takeMVar# @@ -162,6 +168,7 @@ GHC MutableByteArray# sameMutableArray# + sameMutableByteArray# newArray# newCharArray# @@ -177,12 +184,12 @@ GHC indexDoubleArray# indexAddrArray# - indexOffAddr# - indexCharOffAddr# - indexIntOffAddr# - indexFloatOffAddr# - indexDoubleOffAddr# - indexAddrOffAddr# +-- indexOffAddr# +indexCharOffAddr# +indexIntOffAddr# +indexFloatOffAddr# +indexDoubleOffAddr# +indexAddrOffAddr# writeArray# writeCharArray# diff --git a/ghc/lib/ghc/GHCerr.lhs b/ghc/lib/ghc/GHCerr.lhs index c0d508d..8841461 100644 --- a/ghc/lib/ghc/GHCerr.lhs +++ b/ghc/lib/ghc/GHCerr.lhs @@ -12,9 +12,12 @@ We cannot define these functions in a module where they might be used with what the typechecker figures out. \begin{code} +{-# OPTIONS -fno-implicit-prelude #-} module GHCerr where -import Prelude +--import Prelude +import PrelBase +import PrelList ( span ) import IOBase --------------------------------------------------------------- @@ -27,13 +30,20 @@ augment = error "GHCbase.augment" --{-# GENERATE_SPECS build a #-} --build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] --build g = g (:) [] +\end{code} ---------------------------------------------------------------- --- Used for compiler-generated error message; --- encoding saves bytes of string junk. +Used for compiler-generated error message; +encoding saves bytes of string junk. +\begin{code} absentErr, parError :: a + +absentErr = error "Oops! The program has entered an `absent' argument!\n" +parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n" +\end{code} + +\begin{code} irrefutPatError , noDefaultMethodError , noExplicitMethodError @@ -42,31 +52,43 @@ irrefutPatError , recConError , recUpdError :: String -> a -absentErr = error "Oops! The program has entered an `absent' argument!\n" -parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n" - noDefaultMethodError s = error ("noDefaultMethodError:"++s) noExplicitMethodError s = error ("No default method for class operation "++s) +irrefutPatError s = error (untangle s "Irrefutable pattern failed for pattern") +nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in") +patError s = error (untangle s "Non-exhaustive patterns in") +recConError s = error (untangle s "Missing field in record construction:") +recUpdError s = error (untangle s "Record to doesn't contain field(s) to be updated") +\end{code} + -irrefutPatError s = patError__ (untangle s "irrefutable pattern") -nonExhaustiveGuardsError s = patError__ (untangle s "non-exhaustive guards") -patError s = patError__ (untangle s "pattern-matching") +(untangle coded message) expects "coded" to be of the form -patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x) + "location|details" -recConError s = error (untangle s "record constructor") -recUpdError s = error (untangle s "record update") +It prints -untangle coded in_str - = "In " ++ in_str - ++ (if null msg then "" else (": " ++ msg)) - ++ "; at " ++ file - ++ ", line " ++ line + location message details + +\begin{code} +untangle coded message + = location + ++ ": " + ++ message + ++ details ++ "\n" where - (file,line,msg) - = case (span not_bar coded) of { (f, (_:rest)) -> - case (span not_bar rest) of { (l, (_:m)) -> - (f,l,m) }} + (location, details) + = case (span not_bar coded) of { (location, rest) -> + case rest of + ('|':details) -> (location, ' ' : details) + _ -> (location, "") + } not_bar c = c /= '|' \end{code} + +-- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook, +-- but the former does exactly the same as the latter, so I nuked it. +-- SLPJ Jan 97 +-- patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x) + diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs index 8214bd3..4a952f7 100644 --- a/ghc/lib/ghc/IOBase.lhs +++ b/ghc/lib/ghc/IOBase.lhs @@ -19,7 +19,9 @@ import PrelTup import Foreign import PackedString ( unpackCString ) import PrelBase +import PrelRead import GHC +import ArrBase ( ByteArray(..), MutableVar(..) ) infixr 1 `thenIO_Prim` \end{code} @@ -37,12 +39,9 @@ instance Functor IO where map f x = x >>= (return . f) instance Monad IO where -{- No inlining for now... until we can inline some of the - imports, like $, these functions are pretty big. {-# INLINE return #-} {-# INLINE (>>) #-} {-# INLINE (>>=) #-} --} m >> k = m >>= \ _ -> k return x = IO $ ST $ \ s@(S# _) -> (Right x, s) @@ -69,7 +68,7 @@ fail :: IOError -> IO a fail err = IO $ ST $ \ s -> (Left err, s) userError :: String -> IOError -userError str = UserError str +userError str = IOError Nothing UserError str catch :: IO a -> (IOError -> IO a) -> IO a catch (IO (ST m)) k = IO $ ST $ \ s -> @@ -222,107 +221,84 @@ fputs stream (c : cs) %* * %********************************************************* +A value @IOError@ encode errors occurred in the @IO@ monad. +An @IOError@ records a more specific error type, a descriptive +string and maybe the handle that was used when the error was +flagged. + \begin{code} -data IOError - = AlreadyExists String - | HardwareFault String - | IllegalOperation String - | InappropriateType String - | Interrupted String - | InvalidArgument String - | NoSuchThing String - | OtherError String - | PermissionDenied String - | ProtocolError String - | ResourceBusy String - | ResourceExhausted String - | ResourceVanished String - | SystemError String - | TimeExpired String - | UnsatisfiedConstraints String - | UnsupportedOperation String - | UserError String - | EOF +data IOError + = IOError + (Maybe Handle) -- the handle used by the action flagging the + -- the error. + IOErrorType -- what it was. + String -- error type specific information. instance Eq IOError where - -- I don't know what the (pointless) idea is here, - -- presumably just compare them by their tags (WDP) - a == b = tag a == tag b - where - tag (AlreadyExists _) = (1::Int) - tag (HardwareFault _) = 2 - tag (IllegalOperation _) = 3 - tag (InappropriateType _) = 4 - tag (Interrupted _) = 5 - tag (InvalidArgument _) = 6 - tag (NoSuchThing _) = 7 - tag (OtherError _) = 8 - tag (PermissionDenied _) = 9 - tag (ProtocolError _) = 10 - tag (ResourceBusy _) = 11 - tag (ResourceExhausted _) = 12 - tag (ResourceVanished _) = 13 - tag (SystemError _) = 14 - tag (TimeExpired _) = 15 - tag (UnsatisfiedConstraints _) = 16 - tag (UnsupportedOperation _) = 17 - tag (UserError _) = 18 - tag EOF = 19 + (IOError h1 e1 str1) == (IOError h2 e2 str2) = + e1==e2 && str1==str2 && h1==h2 + +data IOErrorType + = AlreadyExists | HardwareFault + | IllegalOperation | InappropriateType + | Interrupted | InvalidArgument + | NoSuchThing | OtherError + | PermissionDenied | ProtocolError + | ResourceBusy | ResourceExhausted + | ResourceVanished | SystemError + | TimeExpired | UnsatisfiedConstraints + | UnsupportedOperation | UserError + | EOF + deriving (Eq, Show) + \end{code} -Predicates on IOError; almost no effort made on these so far... +Predicates on IOError; little effort made on these so far... \begin{code} -isAlreadyExistsError (AlreadyExists _) = True -isAlreadyExistsError _ = False +isAlreadyExistsError (IOError _ AlreadyExists _) = True +isAlreadyExistsError _ = False + +isAlreadyInUseError (IOError _ ResourceBusy _) = True +isAlreadyInUseError _ = False -isAlreadyInUseError (ResourceBusy _) = True -isAlreadyInUseError _ = False +isFullError (IOError _ ResourceExhausted _) = True +isFullError _ = False -isFullError (ResourceExhausted _) = True -isFullError _ = False +isEOFError (IOError _ EOF _) = True +isEOFError _ = True -isEOFError EOF = True -isEOFError _ = True +isIllegalOperation (IOError _ IllegalOperation _) = True +isIllegalOperation _ = False -isIllegalOperation (IllegalOperation _) = True -isIllegalOperation _ = False +isPermissionError (IOError _ PermissionDenied _) = True +isPermissionError _ = False -isPermissionError (PermissionDenied _) = True -isPermissionError _ = False +isDoesNotExistError (IOError _ NoSuchThing _) = True +isDoesNotExistError _ = False -isUserError (UserError s) = Just s -isUserError _ = Nothing +isUserError (IOError _ UserError s) = Just s +isUserError _ = Nothing \end{code} Showing @IOError@s \begin{code} instance Show IOError where - showsPrec p (AlreadyExists s) = show2 "AlreadyExists: " s - showsPrec p (HardwareFault s) = show2 "HardwareFault: " s - showsPrec p (IllegalOperation s) = show2 "IllegalOperation: " s - showsPrec p (InappropriateType s) = show2 "InappropriateType: " s - showsPrec p (Interrupted s) = show2 "Interrupted: " s - showsPrec p (InvalidArgument s) = show2 "InvalidArgument: " s - showsPrec p (NoSuchThing s) = show2 "NoSuchThing: " s - showsPrec p (OtherError s) = show2 "OtherError: " s - showsPrec p (PermissionDenied s) = show2 "PermissionDenied: " s - showsPrec p (ProtocolError s) = show2 "ProtocolError: " s - showsPrec p (ResourceBusy s) = show2 "ResourceBusy: " s - showsPrec p (ResourceExhausted s) = show2 "ResourceExhausted: " s - showsPrec p (ResourceVanished s) = show2 "ResourceVanished: " s - showsPrec p (SystemError s) = show2 "SystemError: " s - showsPrec p (TimeExpired s) = show2 "TimeExpired: " s - showsPrec p (UnsatisfiedConstraints s) = show2 "UnsatisfiedConstraints: " s - showsPrec p (UnsupportedOperation s)= show2 "UnsupportedOperation: " s - showsPrec p (UserError s) = showString s - showsPrec p EOF = showString "EOF" - -show2 x y = showString x . showString y + showsPrec p (IOError _ UserError s) rs = + showString s rs + showsPrec p (IOError _ EOF _) rs = + showsPrec p EOF rs + showsPrec p (IOError _ iot s) rs = + showsPrec p + iot + (case s of { + "" -> rs; + _ -> showString ": " $ + showString s rs}) -{- +\end{code} The @String@ part of an @IOError@ is platform-dependent. However, to provide a uniform mechanism for distinguishing among errors within @@ -331,42 +307,155 @@ the exact strings to be used for particular errors. For errors not explicitly mentioned in the standard, any descriptive string may be used. - SOF 4/96 - added argument to indicate function that flagged error --} -constructErrorAndFail :: String -> IO a -constructError :: String -> PrimIO IOError +\begin{change} +SOF & 4/96 & added argument to indicate function that flagged error +\end{change} +% Hmm..does these envs work?!...SOF +\begin{code} +constructErrorAndFail :: String -> IO a constructErrorAndFail call_site = stToIO (constructError call_site) >>= \ io_error -> fail io_error -constructError call_site - = _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> - _casm_ ``%r = ghc_errstr;'' >>= \ str -> - let - msg = call_site ++ ':' : ' ' : unpackCString str - in - return (case errtype# of - ERR_ALREADYEXISTS# -> AlreadyExists msg - ERR_HARDWAREFAULT# -> HardwareFault msg - ERR_ILLEGALOPERATION# -> IllegalOperation msg - ERR_INAPPROPRIATETYPE# -> InappropriateType msg - ERR_INTERRUPTED# -> Interrupted msg - ERR_INVALIDARGUMENT# -> InvalidArgument msg - ERR_NOSUCHTHING# -> NoSuchThing msg - ERR_OTHERERROR# -> OtherError msg - ERR_PERMISSIONDENIED# -> PermissionDenied msg - ERR_PROTOCOLERROR# -> ProtocolError msg - ERR_RESOURCEBUSY# -> ResourceBusy msg - ERR_RESOURCEEXHAUSTED# -> ResourceExhausted msg - ERR_RESOURCEVANISHED# -> ResourceVanished msg - ERR_SYSTEMERROR# -> SystemError msg - ERR_TIMEEXPIRED# -> TimeExpired msg - ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints msg - ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation msg - ERR_EOF# -> EOF - _ -> OtherError "bad error construct" - ) \end{code} +This doesn't seem to be documented/spelled out anywhere, +so here goes: (SOF) + +The implementation of the IO prelude uses various C stubs +to do the actual interaction with the OS. The bandwidth +\tr{C<->Haskell} is somewhat limited, so the general strategy +for flaggging any errors (apart from possibly using the +return code of the external call), is to set the @ghc_errtype@ +to a value that is one of the \tr{#define}s in @includes/error.h@. +@ghc_errstr@ holds a character string providing error-specific +information. + +\begin{code} +constructError :: String -> PrimIO IOError +constructError call_site = + _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> + _casm_ ``%r = ghc_errstr;'' >>= \ str -> + let + iot = + case errtype# of + ERR_ALREADYEXISTS# -> AlreadyExists + ERR_HARDWAREFAULT# -> HardwareFault + ERR_ILLEGALOPERATION# -> IllegalOperation + ERR_INAPPROPRIATETYPE# -> InappropriateType + ERR_INTERRUPTED# -> Interrupted + ERR_INVALIDARGUMENT# -> InvalidArgument + ERR_NOSUCHTHING# -> NoSuchThing + ERR_OTHERERROR# -> OtherError + ERR_PERMISSIONDENIED# -> PermissionDenied + ERR_PROTOCOLERROR# -> ProtocolError + ERR_RESOURCEBUSY# -> ResourceBusy + ERR_RESOURCEEXHAUSTED# -> ResourceExhausted + ERR_RESOURCEVANISHED# -> ResourceVanished + ERR_SYSTEMERROR# -> SystemError + ERR_TIMEEXPIRED# -> TimeExpired + ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints + ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation + ERR_EOF# -> EOF + _ -> OtherError + + msg = + case iot of + EOF -> "" + OtherError -> "bad error construct" + _ -> call_site ++ ':' : ' ' : unpackCString str + in + return (IOError Nothing iot msg) +\end{code} +%********************************************************* +%* * +\subsection{Types @Handle@, @Handle__@} +%* * +%********************************************************* + +The type for @Handle@ is defined rather than in @IOHandle@ +module, as the @IOError@ type uses it..all operations over +a handles reside in @IOHandle@. + +\begin{code} + +{- + Sigh, the MVar ops in ConcBase depend on IO, the IO + representation here depend on MVars for handles (when + compiling a concurrent way). Break the cycle by having + the definition of MVars go here: + +-} +data MVar a = MVar (SynchVar# RealWorld a) + +#if defined(__CONCURRENT_HASKELL__) +type Handle = MVar Handle__ +#else +type Handle = MutableVar RealWorld Handle__ +#endif + +data Handle__ + = ErrorHandle IOError + | ClosedHandle + | SemiClosedHandle ForeignObj (Addr, Int) + | ReadHandle ForeignObj (Maybe BufferMode) Bool + | WriteHandle ForeignObj (Maybe BufferMode) Bool + | AppendHandle ForeignObj (Maybe BufferMode) Bool + | ReadWriteHandle ForeignObj (Maybe BufferMode) Bool + +-- Standard Instances as defined by the Report.. + +instance Eq Handle {-partain:????-} +instance Show Handle where {showsPrec p h = showString "<>"} + +\end{code} + +%********************************************************* +%* * +\subsection[BufferMode]{Buffering modes} +%* * +%********************************************************* + +Three kinds of buffering are supported: line-buffering, +block-buffering or no-buffering. These modes have the following +effects. For output, items are written out from the internal +buffer according to the buffer mode: + +\begin{itemize} +\item[line-buffering] the entire output buffer is written +out whenever a newline is output, the output buffer overflows, +a flush is issued, or the handle is closed. + +\item[block-buffering] the entire output buffer is written out whenever +it overflows, a flush is issued, or the handle +is closed. + +\item[no-buffering] output is written immediately, and never stored +in the output buffer. +\end{itemize} + +The output buffer is emptied as soon as it has been written out. + +Similarly, input occurs according to the buffer mode for handle {\em hdl}. +\begin{itemize} +\item[line-buffering] when the input buffer for {\em hdl} is not empty, +the next item is obtained from the buffer; +otherwise, when the input buffer is empty, +characters up to and including the next newline +character are read into the buffer. No characters +are available until the newline character is +available. +\item[block-buffering] when the input buffer for {\em hdl} becomes empty, +the next block of data is read into this buffer. +\item[no-buffering] the next input item is read and returned. +\end{itemize} +For most implementations, physical files will normally be block-buffered +and terminals will normally be line-buffered. + +\begin{code} +data BufferMode + = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) + deriving (Eq, Ord, Read, Show) +\end{code} diff --git a/ghc/lib/ghc/IOHandle.lhs b/ghc/lib/ghc/IOHandle.lhs index 3e88c46..50e1300 100644 --- a/ghc/lib/ghc/IOHandle.lhs +++ b/ghc/lib/ghc/IOHandle.lhs @@ -10,7 +10,7 @@ which are supported for them. \begin{code} #include "error.h" -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} module IOHandle where @@ -23,7 +23,11 @@ import IOBase import PrelTup import PrelBase import GHC - +import Foreign ( makeForeignObj ) +import PrelList (span) +#if defined(__CONCURRENT_HASKELL__) +import ConcBase +#endif \end{code} @@ -33,43 +37,28 @@ import GHC %* * %********************************************************* +The @Handle@ and @Handle__@ types are defined in @IOBase@. + \begin{code} type FilePath = String -#if defined(__CONCURRENT_HASKELL__) -type Handle = MVar Handle__ +{-# INLINE newHandle #-} +{-# INLINE readHandle #-} +{-# INLINE writeHandle #-} +newHandle :: Handle__ -> IO Handle +readHandle :: Handle -> IO Handle__ +writeHandle :: Handle -> Handle__ -> IO () +#if defined(__CONCURRENT_HASKELL__) newHandle = newMVar readHandle = takeMVar writeHandle = putMVar - -#else -type Handle = MutableVar RealWorld Handle__ - +#else newHandle v = stToIO (newVar v) readHandle h = stToIO (readVar h) writeHandle h v = stToIO (writeVar h v) +#endif -#endif {- __CONCURRENT_HASKELL__ -} - -data Handle__ - = ErrorHandle IOError - | ClosedHandle - | SemiClosedHandle Addr (Addr, Int) - | ReadHandle Addr (Maybe BufferMode) Bool - | WriteHandle Addr (Maybe BufferMode) Bool - | AppendHandle Addr (Maybe BufferMode) Bool - | ReadWriteHandle Addr (Maybe BufferMode) Bool - -instance Eq Handle{-partain:????-} - -{-# INLINE newHandle #-} -{-# INLINE readHandle #-} -{-# INLINE writeHandle #-} - -newHandle :: Handle__ -> IO Handle -readHandle :: Handle -> IO Handle__ -writeHandle :: Handle -> Handle__ -> IO () \end{code} %********************************************************* @@ -79,7 +68,7 @@ writeHandle :: Handle -> Handle__ -> IO () %********************************************************* \begin{code} -filePtr :: Handle__ -> Addr +filePtr :: Handle__ -> ForeignObj filePtr (SemiClosedHandle fp _) = fp filePtr (ReadHandle fp _ _) = fp filePtr (WriteHandle fp _ _) = fp @@ -127,7 +116,8 @@ stdin = unsafePerformPrimIO ( _ccall_ getLock (``stdin''::Addr) 0 >>= \ rc -> (case rc of 0 -> new_handle ClosedHandle - 1 -> new_handle (ReadHandle ``stdin'' Nothing False) + 1 -> makeForeignObj (``stdin''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> + new_handle (ReadHandle fp Nothing False) _ -> constructError "stdin" >>= \ ioError -> new_handle (ErrorHandle ioError) ) >>= \ handle -> @@ -140,7 +130,8 @@ stdout = unsafePerformPrimIO ( _ccall_ getLock (``stdout''::Addr) 1 >>= \ rc -> (case rc of 0 -> new_handle ClosedHandle - 1 -> new_handle (WriteHandle ``stdout'' Nothing False) + 1 -> makeForeignObj (``stdout''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> + new_handle (WriteHandle fp Nothing False) _ -> constructError "stdout" >>= \ ioError -> new_handle (ErrorHandle ioError) ) >>= \ handle -> @@ -153,7 +144,8 @@ stderr = unsafePerformPrimIO ( _ccall_ getLock (``stderr''::Addr) 1 >>= \ rc -> (case rc of 0 -> new_handle ClosedHandle - 1 -> new_handle (WriteHandle ``stderr'' (Just NoBuffering) False) + 1 -> makeForeignObj (``stderr''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> + new_handle (WriteHandle fp (Just NoBuffering) False) _ -> constructError "stderr" >>= \ ioError -> new_handle (ErrorHandle ioError) ) >>= \ handle -> @@ -176,18 +168,19 @@ data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode openFile :: FilePath -> IOMode -> IO Handle openFile f m = - stToIO (_ccall_ openFile f m') >>= \ ptr -> + stToIO (_ccall_ openFile f m') >>= \ ptr -> if ptr /= ``NULL'' then - newHandle (htype ptr Nothing False) + stToIO (makeForeignObj ptr ((``&freeFile'')::Addr)) >>= \ fp -> + newHandle (htype fp Nothing False) else - stToIO (constructError "openFile") >>= \ ioError -> + stToIO (constructError "openFile") >>= \ ioError@(IOError hn iot msg) -> let improved_error -- a HACK, I guess - = case ioError of - AlreadyExists msg -> AlreadyExists (msg ++ ": " ++ f) - NoSuchThing msg -> NoSuchThing (msg ++ ": " ++ f) - PermissionDenied msg -> PermissionDenied (msg ++ ": " ++ f) - _ -> ioError + = case iot of + AlreadyExists -> IOError hn AlreadyExists (msg ++ ": " ++ f) + NoSuchThing -> IOError hn NoSuchThing (msg ++ ": " ++ f) + PermissionDenied -> IOError hn PermissionDenied (msg ++ ": " ++ f) + _ -> ioError in fail improved_error where @@ -238,20 +231,28 @@ hClose handle = ErrorHandle ioError -> fail ioError ClosedHandle -> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle fp (buf,_) -> (if buf /= ``NULL'' then _ccall_ free buf else returnPrimIO ()) `thenIO_Prim` \ () -> - if fp /= ``NULL'' then - _ccall_ closeFile fp `thenIO_Prim` \ rc -> - if rc == 0 then + _casm_ `` %r = (char *)%0; '' fp `thenIO_Prim` \ fp_a -> + if fp_a /= (``NULL''::Addr) then -- Under what condition can this be NULL? + _ccall_ closeFile fp `thenIO_Prim` \ rc -> + {- We explicitly close a file object so that we can be told + if there were any errors. Note that after @hClose@ + has been performed, the ForeignObj embedded in the Handle + is still lying around in the heap, so care is taken + to avoid closing the file object when the ForeignObj + is finalised. (see freeFile()) -} + if rc == 0 then return () - else + else constructErrorAndFail "hClose" - else - return () + + else + return () other -> _ccall_ closeFile (filePtr other) `thenIO_Prim` \ rc -> if rc == 0 then @@ -285,10 +286,10 @@ hFileSize handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> -- HACK! We build a unique MP_INT of the right shape to hold -- a single unsigned word, and we let the C routine change the data bits @@ -322,16 +323,16 @@ hIsEOF handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle WriteHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") AppendHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") other -> _ccall_ fileEOF (filePtr other) `thenIO_Prim` \ rc -> writeHandle handle (markHandle htype) >> @@ -351,62 +352,26 @@ isEOF = hIsEOF stdin %********************************************************* Three kinds of buffering are supported: line-buffering, -block-buffering or no-buffering. These modes have the following effects. -For output, items are written out from the internal buffer -according to the buffer mode: -\begin{itemize} -\item[line-buffering] the entire output buffer is written -out whenever a newline is output, the output buffer overflows, -a flush is issued, or the handle is closed. - -\item[block-buffering] the entire output buffer is written out whenever -it overflows, a flush is issued, or the handle -is closed. - -\item[no-buffering] output is written immediately, and never stored -in the output buffer. -\end{itemize} - -The output buffer is emptied as soon as it has been written out. - -Similarly, input occurs according to the buffer mode for handle {\em hdl}. -\begin{itemize} -\item[line-buffering] when the input buffer for {\em hdl} is not empty, -the next item is obtained from the buffer; -otherwise, when the input buffer is empty, -characters up to and including the next newline -character are read into the buffer. No characters -are available until the newline character is -available. -\item[block-buffering] when the input buffer for {\em hdl} becomes empty, -the next block of data is read into this buffer. -\item[no-buffering] the next input item is read and returned. -\end{itemize} -For most implementations, physical files will normally be block-buffered -and terminals will normally be line-buffered. - -\begin{code} -data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) - deriving (Eq, Ord, Read, Show) -\end{code} +block-buffering or no-buffering. See @IOBase@ for definition +and further explanation of what the type represent. -Computation $hSetBuffering hdl mode$ sets the mode of buffering for +Computation @hSetBuffering hdl mode@ sets the mode of buffering for handle {\em hdl} on subsequent reads and writes. \begin{itemize} \item -If {\em mode} is $LineBuffering$, line-buffering should be +If {\em mode} is @LineBuffering@, line-buffering should be enabled if possible. \item -If {\em mode} is $BlockBuffering$ {\em size}, then block-buffering +If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering should be enabled if possible. The size of the buffer is {\em n} items -if {\em size} is $Just${\em n} and is otherwise implementation-dependent. +if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent. \item -If {\em mode} is $NoBuffering$, then buffering is disabled if possible. +If {\em mode} is @NoBuffering@, then buffering is disabled if possible. \end{itemize} -If the buffer mode is changed from $BlockBuffering$ or $LineBuffering$ -to $NoBuffering$, then any items in the output buffer are written to +If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@ +to @NoBuffering@, then any items in the output buffer are written to the device, and any items in the input buffer are discarded. The default buffering mode when a handle is opened is implementation-dependent and may depend on the object which is @@ -418,12 +383,14 @@ hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = case mode of (BlockBuffering (Just n)) - | n <= 0 -> fail (InvalidArgument "illegal buffer size") + | n <= 0 -> fail (IOError (Just handle) InvalidArgument "illegal buffer size") other -> readHandle handle >>= \ htype -> if isMarked htype then writeHandle handle htype >> - fail (UnsupportedOperation "can't set buffering for a dirty handle") + fail (IOError (Just handle) + UnsupportedOperation + "can't set buffering for a dirty handle") else case htype of ErrorHandle ioError -> @@ -431,10 +398,10 @@ hSetBuffering handle mode = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> _ccall_ setBuffering (filePtr other) bsize `thenIO_Prim` \ rc -> @@ -460,7 +427,7 @@ hSetBuffering handle mode = BlockBuffering Nothing -> -2 BlockBuffering (Just n) -> n - hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__) + hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__) hcon (ReadHandle _ _ _) = ReadHandle hcon (WriteHandle _ _ _) = WriteHandle hcon (AppendHandle _ _ _) = AppendHandle @@ -480,10 +447,10 @@ hFlush handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> _ccall_ flushFile (filePtr other) `thenIO_Prim` \ rc -> writeHandle handle (markHandle htype) >> @@ -524,10 +491,10 @@ hGetPosn handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> _ccall_ getFilePosn (filePtr other) `thenIO_Prim` \ posn -> writeHandle handle htype >> @@ -545,13 +512,13 @@ hSetPosn (HandlePosn handle posn) = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle AppendHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not seekable") + fail (IOError (Just handle) IllegalOperation "handle is not seekable") other -> _ccall_ setFilePosn (filePtr other) posn `thenIO_Prim` \ rc -> writeHandle handle (markHandle htype) >> @@ -591,13 +558,13 @@ hSeek handle mode offset@(J# _ s# d#) = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle AppendHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not seekable") + fail (IOError (Just handle) IllegalOperation "handle is not seekable") other -> _ccall_ seekFile (filePtr other) whence (I# s#) (ByteArray (0,0) d#) `thenIO_Prim` \ rc -> @@ -671,10 +638,10 @@ hIsReadable handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> writeHandle handle htype >> return (isReadable other) @@ -692,10 +659,10 @@ hIsWritable handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> writeHandle handle htype >> return (isWritable other) @@ -735,10 +702,10 @@ hIsBlockBuffered handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> getBufferMode other `thenIO_Prim` \ other -> case bufferMode other of @@ -760,10 +727,10 @@ hIsLineBuffered handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> getBufferMode other `thenIO_Prim` \ other -> case bufferMode other of @@ -785,10 +752,10 @@ hIsNotBuffered handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle other -> getBufferMode other `thenIO_Prim` \ other -> case bufferMode other of @@ -802,23 +769,23 @@ hIsNotBuffered handle = constructErrorAndFail "hIsNotBuffered" hGetBuffering :: Handle -> IO BufferMode -hGetBuffering hndl = - readHandle hndl >>= \ htype -> +hGetBuffering handle = + readHandle handle >>= \ htype -> case htype of ErrorHandle ioError -> - writeHandle hndl htype >> + writeHandle handle htype >> fail ioError ClosedHandle -> - writeHandle hndl htype >> - fail (IllegalOperation "handle is closed") + writeHandle handle htype >> + ioe_closedHandle handle SemiClosedHandle _ _ -> - writeHandle hndl htype >> - fail (IllegalOperation "handle is closed") + writeHandle handle htype >> + ioe_closedHandle handle other -> getBufferMode other `thenIO_Prim` \ other -> case bufferMode other of Just v -> - writeHandle hndl other >> + writeHandle handle other >> return v Nothing -> constructErrorAndFail "hGetBuffering" @@ -832,10 +799,10 @@ hIsSeekable handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle AppendHandle _ _ _ -> writeHandle handle htype >> return False @@ -859,10 +826,28 @@ These two functions are meant to get things out of @IOErrors@. They don't! \begin{code} ioeGetFileName :: IOError -> Maybe FilePath +ioeGetErrorString :: IOError -> String ioeGetHandle :: IOError -> Maybe Handle +ioeGetHandle (IOError h _ _) = h +ioeGetErrorString (IOError _ iot str) = + case iot of + EOF -> "end of file" + _ -> str + +ioeGetFileName (IOError _ _ str) = + case span (/=':') str of + (fs,[]) -> Nothing + (fs,_) -> Just fs -ioeGetHandle _ = Nothing -- a stub, essentially -ioeGetFileName _ = Nothing -- a stub, essentially \end{code} +Internal function for creating an @IOError@ representing the +access of a closed file. + +\begin{code} + +ioe_closedHandle :: Handle -> IO a +ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed") + +\end{code} diff --git a/ghc/lib/ghc/Main.hi-boot b/ghc/lib/ghc/Main.hi-boot index 0358a0d..5eba82e 100644 --- a/ghc/lib/ghc/Main.hi-boot +++ b/ghc/lib/ghc/Main.hi-boot @@ -10,4 +10,4 @@ _interface_ Main 1 _exports_ Main main ; _declarations_ -1 main :: IOBase.IO PrelBase.();; +1 main _:_ IOBase.IO PrelBase.();; diff --git a/ghc/lib/ghc/PrelBase.lhs b/ghc/lib/ghc/PrelBase.lhs index e83a391..f4a5b1c 100644 --- a/ghc/lib/ghc/PrelBase.lhs +++ b/ghc/lib/ghc/PrelBase.lhs @@ -7,7 +7,11 @@ \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module PrelBase where +module PrelBase( + module PrelBase, + module GHC -- Re-export GHC, to avoid lots of people having + -- to import it explicitly + ) where import {-# SOURCE #-} IOBase ( error ) import GHC @@ -148,11 +152,7 @@ class Show a where showsPrec :: Int -> a -> ShowS showList :: [a] -> ShowS - showList [] = showString "[]" - showList (x:xs) - = showChar '[' . shows x . showl xs - where showl [] = showChar ']' - showl (x:xs) = showString ", " . shows x . showl xs + showList ls = showList__ (showsPrec 0) ls \end{code} %********************************************************* @@ -168,8 +168,7 @@ data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) instance (Eq a) => Eq [a] where [] == [] = True (x:xs) == (y:ys) = x == y && xs == ys - [] == ys = False - xs == [] = False + xs == ys = False xs /= ys = if (xs == ys) then False else True instance (Ord a) => Ord [a] where @@ -195,6 +194,7 @@ instance Functor [] where instance Monad [] where m >>= k = foldr ((++) . k) [] m + m >> k = foldr ((++) . (\ _ -> k)) [] m return x = [x] instance MonadZero [] where @@ -205,7 +205,7 @@ instance MonadPlus [] where instance (Show a) => Show [a] where showsPrec p = showList - showList = showList__ (showsPrec 0) + showList ls = showList__ (showsPrec 0) ls \end{code} \end{code} @@ -253,9 +253,12 @@ dropWhile p xs@(x:xs') The type @Void@ is built in, but it needs a @Show@ instance. \begin{code} +void :: Void +void = error "You tried to evaluate void" + instance Show Void where showsPrec p f = showString "<>" - showList = showList__ (showsPrec 0) + showList ls = showList__ (showsPrec 0) ls \end{code} @@ -272,8 +275,8 @@ data Bool = False | True deriving (Eq, Ord, Enum, Bounded, Show {- Read -}) (&&), (||) :: Bool -> Bool -> Bool True && x = x -False && _ = False -True || _ = True +False && x = False +True || x = True False || x = x not :: Bool -> Bool @@ -294,6 +297,10 @@ otherwise = True \begin{code} data Maybe a = Nothing | Just a deriving (Eq, Ord, Show {- Read -}) +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n f Nothing = n +maybe n f (Just x) = f x + instance Functor Maybe where map f Nothing = Nothing map f (Just a) = Just (f a) @@ -301,6 +308,10 @@ instance Functor Maybe where instance Monad Maybe where (Just x) >>= k = k x Nothing >>= k = Nothing + + (Just x) >> k = k + Nothing >> k = Nothing + return = Just instance MonadZero Maybe where @@ -328,7 +339,6 @@ it here seems more direct. \begin{code} data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) -- (avoids weird-named functions, e.g., con2tag_()# - instance Eq () where () == () = True () /= () = False @@ -357,6 +367,7 @@ instance Bounded () where instance Show () where showsPrec p () = showString "()" + showList ls = showList__ (showsPrec 0) ls \end{code} %********************************************************* @@ -398,11 +409,12 @@ data Char = C# Char# deriving (Eq, Ord) instance Enum Char where toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i) - | otherwise = error "Prelude.Enum.Char.toEnum:out of range" + | otherwise = error ("Prelude.Enum.Char.toEnum:out of range: " ++ show (I# i)) fromEnum (C# c) = I# (ord# c) enumFrom (C# c) = eftt (ord# c) 1# 255# enumFromThen (C# c1) (C# c2) = eftt (ord# c1) (ord# c2 -# ord# c1) 255# + enumFromTo (C# c1) (C# c2) = eftt (ord# c1) 1# (ord# c2) enumFromThenTo (C# c1) (C# c2) (C# c3) = eftt (ord# c1) (ord# c2 -# ord# c1) (ord# c3) eftt :: Int# -> Int# -> Int# -> [Char] @@ -428,9 +440,10 @@ instance Show Char where \begin{code} -isAscii, isControl, isPrint, isSpace, isUpper, +isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool isAscii c = fromEnum c < 128 +isLatin1 c = c <= '\xff' isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f' isPrint c = not (isControl c) @@ -455,19 +468,19 @@ isUpper c = c >= 'A' && c <= 'Z' || isLower c = c >= 'a' && c <= 'z' || c >= '\xDF' && c <= '\xF6' || c >= '\xF8' && c <= '\xFF' -isAlpha c = isUpper c || isLower c +isAlpha c = isLower c || isUpper c isDigit c = c >= '0' && c <= '9' isOctDigit c = c >= '0' && c <= '7' isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' isAlphanum c = isAlpha c || isDigit c --- These almost work for ISO-Latin-1 (except for =DF <-> =FF) +-- Case-changing operations toUpper, toLower :: Char -> Char -toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' - + fromEnum 'A') - | otherwise = c +toUpper c | isLower c && c /= '\xDF' && c /= '\xFF' + = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A') + | otherwise = c toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a') @@ -491,19 +504,22 @@ asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ') data Int = I# Int# instance Eq Int where - (I# x) == (I# y) = x ==# y + (==) x y = x `eqInt` y + (/=) x y = x `neInt` y instance Ord Int where - (I# x) `compare` (I# y) | x <# y = LT - | x ==# y = EQ - | otherwise = GT - - (I# x) < (I# y) = x <# y - (I# x) <= (I# y) = x <=# y - (I# x) >= (I# y) = x >=# y - (I# x) > (I# y) = x ># y + compare x y = compareInt x y + (<) x y = ltInt x y + (<=) x y = leInt x y + (>=) x y = geInt x y + (>) x y = gtInt x y + max x y = case (compareInt x y) of { LT -> y ; EQ -> x ; GT -> x } + min x y = case (compareInt x y) of { LT -> x ; EQ -> x ; GT -> y } +(I# x) `compareInt` (I# y) | x <# y = LT + | x ==# y = EQ + | otherwise = GT instance Enum Int where toEnum x = x @@ -524,6 +540,7 @@ instance Enum Int where enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p)) (enumFromThen n m) + instance Bounded Int where minBound = negate 2147483647 -- ********************** maxBound = 2147483647 -- ********************** @@ -546,7 +563,7 @@ instance Num Int where instance Show Int where showsPrec p n = showSignedInt p n - showList = showList__ (showsPrec 0) + showList ls = showList__ (showsPrec 0) ls \end{code} @@ -576,7 +593,8 @@ data Integer = J# Int# Int# ByteArray# \begin{code} instance Show (a -> b) where showsPrec p f = showString "<>" - showList = showList__ (showsPrec 0) + showList ls = showList__ (showsPrec 0) ls + -- identity function id :: a -> a @@ -624,6 +642,7 @@ asTypeOf = const \begin{code} data Addr = A# Addr# deriving (Eq, Ord) -- Glasgow extension data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension +data ForeignObj = ForeignObj ForeignObj# -- another one data Lift a = Lift a {-# GENERATE_SPECS data a :: Lift a #-} @@ -727,6 +746,9 @@ Definitions of the boxed PrimOps; these will be used in the case of partial applications, etc. \begin{code} +{-# INLINE eqInt #-} +{-# INLINE neInt #-} + plusInt (I# x) (I# y) = I# (x +# y) minusInt(I# x) (I# y) = I# (x -# y) timesInt(I# x) (I# y) = I# (x *# y) diff --git a/ghc/lib/ghc/PrelNum.lhs b/ghc/lib/ghc/PrelNum.lhs index 940a57b..cadad79 100644 --- a/ghc/lib/ghc/PrelNum.lhs +++ b/ghc/lib/ghc/PrelNum.lhs @@ -21,6 +21,8 @@ module PrelNum where import {-# SOURCE #-} IOBase ( error ) import PrelList import PrelBase +import ArrBase ( Array, array, (!) ) +import Ix ( Ix(..) ) import GHC infixr 8 ^, ^^, ** @@ -338,8 +340,18 @@ instance Show Integer where showsPrec x = showSignedInteger x showList = showList__ (showsPrec 0) +instance Ix Integer where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = fromInteger (i - m) + | otherwise = error "Integer.index: Index out of range." + inRange (m,n) i = m <= i && i <= n + integer_0, integer_1, integer_2, integer_m1 :: Integer -integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1 +integer_0 = int2Integer# 0# +integer_1 = int2Integer# 1# +integer_2 = int2Integer# 2# +integer_m1 = int2Integer# (negateInt# 1#) \end{code} @@ -361,7 +373,7 @@ instance Ord Float where (F# x) < (F# y) = x `ltFloat#` y (F# x) <= (F# y) = x `leFloat#` y (F# x) >= (F# y) = x `geFloat#` y - (F# x) > (F# y) = x `geFloat#` y + (F# x) > (F# y) = x `gtFloat#` y instance Num Float where (+) x y = plusFloat x y @@ -662,7 +674,7 @@ numericEnumFromThen n m = iterate (+(m-n)) n %********************************************************* \begin{code} -data (Integral a) => Ratio a = a :% a deriving (Eq) +data (Integral a) => Ratio a = !a :% !a deriving (Eq) type Rational = Ratio Integer \end{code} @@ -671,11 +683,19 @@ type Rational = Ratio Integer numerator, denominator :: (Integral a) => Ratio a -> a approxRational :: (RealFrac a) => a -> a -> Rational +\end{code} + +\tr{reduce} is a subsidiary function used only in this module . +It normalises a ratio by dividing both numerator and denominator by +their greatest common divisor. +\begin{code} reduce _ 0 = error "{Ratio.%}: zero denominator" reduce x y = (x `quot` d) :% (y `quot` d) where d = gcd x y +\end{code} +\begin{code} x % y = reduce (x * signum y) (abs y) numerator (x:%y) = x @@ -754,23 +774,27 @@ instance (Integral a) => Show (Ratio a) where (shows x . showString " % " . shows y) \end{code} -{- -[In response to a request by simonpj, Joe Fasel writes:] +[In response to a request for documentation of how fromRational works, +Joe Fasel writes:] A quite reasonable request! This code was added to +the Prelude just before the 1.2 release, when Lennart, working with an +early version of hbi, noticed that (read . show) was not the identity +for floating-point numbers. (There was a one-bit error about half the +time.) The original version of the conversion function was in fact +simply a floating-point divide, as you suggest above. The new version +is, I grant you, somewhat denser. -A quite reasonable request! This code was added to the Prelude just -before the 1.2 release, when Lennart, working with an early version -of hbi, noticed that (read . show) was not the identity for -floating-point numbers. (There was a one-bit error about half the time.) -The original version of the conversion function was in fact simply -a floating-point divide, as you suggest above. The new version is, -I grant you, somewhat denser. +Unfortunately, Joe's code doesn't work! Here's an example: -How's this? +main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n") -Joe --} +This program prints + 0.0000000000000000 +instead of + 1.8217369128763981e-300 -\begin{code} +Lennart's code follows, and it works... + +\begin{pseudocode} {-# GENERATE_SPECS fromRational__ a{Double#,Double} #-} fromRational__ :: (RealFloat a) => Rational -> a fromRational__ x = x' @@ -796,8 +820,76 @@ fromRational__ x = x' (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' / fromInteger (denominator x)) -\end{code} +\end{pseudocode} +Now, here's Lennart's code. + +\begin{code} +fromRational__ :: (RealFloat a) => Rational -> a +fromRational__ x = + if x == 0 then encodeFloat 0 0 -- Handle exceptional cases + else if x < 0 then - fromRat' (-x) -- first. + else fromRat' x + +-- Conversion process: +-- Scale the rational number by the RealFloat base until +-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat). +-- Then round the rational to an Integer and encode it with the exponent +-- that we got from the scaling. +-- To speed up the scaling process we compute the log2 of the number to get +-- a first guess of the exponent. + +fromRat' :: (RealFloat a) => Rational -> a +fromRat' x = r + where b = floatRadix r + p = floatDigits r + (minExp0, _) = floatRange r + minExp = minExp0 - p -- the real minimum exponent + xMin = toRational (expt b (p-1)) + xMax = toRational (expt b p) + p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp + f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1 + (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f) + r = encodeFloat (round x') p' + +-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp. +scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int) +scaleRat b minExp xMin xMax p x = + if p <= minExp then + (x, p) + else if x >= xMax then + scaleRat b minExp xMin xMax (p+1) (x/b) + else if x < xMin then + scaleRat b minExp xMin xMax (p-1) (x*b) + else + (x, p) + +-- Exponentiation with a cache for the most common numbers. +minExpt = 0::Int +maxExpt = 1100::Int +expt :: Integer -> Int -> Integer +expt base n = + if base == 2 && n >= minExpt && n <= maxExpt then + expts!n + else + base^n +expts :: Array Int Integer +expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] + +-- Compute the (floor of the) log of i in base b. +-- Simplest way would be just divide i by b until it's smaller then b, but that would +-- be very slow! We are just slightly more clever. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b i = + if i < b then + 0 + else + -- Try squaring the base first to cut down the number of divisions. + let l = 2 * integerLogBase (b*b) i + doDiv :: Integer -> Int -> Int + doDiv i l = if i < b then l else doDiv (i `div` b) (l+1) + in doDiv (i `div` (b^l)) l +\end{code} %********************************************************* %* * diff --git a/ghc/lib/ghc/PrelRead.lhs b/ghc/lib/ghc/PrelRead.lhs index 683c42b..b8693c5 100644 --- a/ghc/lib/ghc/PrelRead.lhs +++ b/ghc/lib/ghc/PrelRead.lhs @@ -367,9 +367,10 @@ lex (c:s) | isSingle c = [([c],s)] isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" isIdChar c = isAlphanum c || c `elem` "_'" - lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, - (e,u) <- lexExp t] - lexFracExp s = [("",s)] + lexFracExp ('.':c:cs) | isDigit c + = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs), + (e,u) <- lexExp t] + lexFracExp s = [("",s)] lexExp (e:s) | e `elem` "eE" = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", diff --git a/ghc/lib/ghc/STBase.lhs b/ghc/lib/ghc/STBase.lhs index 9cff092..afc3d51 100644 --- a/ghc/lib/ghc/STBase.lhs +++ b/ghc/lib/ghc/STBase.lhs @@ -54,33 +54,6 @@ returnST = return thenST = (>>=) seqST = (>>) --- not sure whether to 1.3-ize these or what... -{-# INLINE returnStrictlyST #-} -{-# INLINE thenStrictlyST #-} -{-# INLINE seqStrictlyST #-} - -{-# GENERATE_SPECS returnStrictlyST a #-} -returnStrictlyST :: a -> ST s a - -{-# GENERATE_SPECS thenStrictlyST a b #-} -thenStrictlyST :: ST s a -> (a -> ST s b) -> ST s b - -{-# GENERATE_SPECS seqStrictlyST a b #-} -seqStrictlyST :: ST s a -> ST s b -> ST s b - -returnStrictlyST a = ST $ \ s@(S# _) -> (a, s) - -thenStrictlyST (ST m) k = ST $ \ s -> -- @(S# _) Omitted SLPJ [May95] no need to evaluate the state - case (m s) of { (r, new_s) -> - case (k r) of { ST k2 -> - (k2 new_s) }} - -seqStrictlyST (ST m) (ST k) = ST $ \ s -> -- @(S# _) Omitted SLPJ [May95] no need to evaluate the state - case (m s) of { (_, new_s) -> - (k new_s) } - --- BUILT-IN: runST (see Builtin.hs) - unsafeInterleaveST :: ST s a -> ST s a -- ToDo: put in state-interface.tex unsafeInterleaveST (ST m) = ST $ \ s -> let