Commit 9fa0d9f0 authored by sof's avatar sof

[project @ 1997-03-14 05:27:40 by sof]

OGI changes through 130397
parent 27c1aa88
%
% (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#
......
......@@ -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)
......
......@@ -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#
......
......@@ -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)
......@@ -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 "<<Handle>>"}
\end{code}
%*********************************************************
%* *
\subsection[BufferMode]{Buffering modes}
%* *
%*********************************************************
Three kinds of buffering are supported: line-buffering,